diff --git a/.headroom.yaml b/.headroom.yaml index 3f60736..eaafb6c 100644 --- a/.headroom.yaml +++ b/.headroom.yaml @@ -23,8 +23,8 @@ license-headers: put-after: ["^{-#"] put-before: ["^module"] margin-top-code: 1 - margin-bottom-code: 1 - margin-bottom-file: 1 + line-comment: + prefixed-by: ^-- post-process: update-copyright: diff --git a/CHANGELOG.md b/CHANGELOG.md index ef8c62a..222b357 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ All notable changes to this project will be documented in this file. - [#87] FIXED: Misleading error message when YAML syntax of .headroom.yaml is invalid - [#88] Add support for _Python_ - [#89] Support GHC 9.2 +- [#92] Switch to fourmolu source code formatter - [#93] FIXED: Haddock module header detection is faulty - Bump _LTS Haskell_ to `19.9` diff --git a/Makefile b/Makefile index 60dc4f8..f51bf3b 100644 --- a/Makefile +++ b/Makefile @@ -23,12 +23,9 @@ microsite: .PHONY: pretty pretty: - find ./app -name '*.hs' | xargs stylish-haskell -i -v - find ./src -name '*.hs' | xargs stylish-haskell -i -v - find ./test -name '*.hs' | xargs stylish-haskell -i -v - find ./app -name '*.hs' | xargs brittany --write-mode=inplace - find ./src -name '*.hs' | xargs brittany --write-mode=inplace - find ./test -name '*.hs' | xargs brittany --write-mode=inplace + find ./app -name '*.hs' | xargs fourmolu -i + find ./src -name '*.hs' | xargs fourmolu -i + find ./test -name '*.hs' | xargs fourmolu -i .PHONY: fresh fresh: clean build diff --git a/app/Main.hs b/app/Main.hs index 4ca7a3f..b776fda 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,55 +1,54 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{-| -Module : Main -Description : Main application launcher -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Code responsible for booting up the application and parsing command line -arguments. --} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Main +-- Description : Main application launcher +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Code responsible for booting up the application and parsing command line +-- arguments. 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 RIO -import System.IO ( hPutStrLn ) - +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) main :: IO () main = do - command' <- execParser commandParser - catch - (bootstrap command') - (\ex -> do - hPutStrLn stderr $ "ERROR: " <> displayException (ex :: HeadroomError) - exitWith $ ExitFailure 1 - ) + command' <- execParser commandParser + catch + (bootstrap command') + ( \ex -> do + hPutStrLn stderr $ "ERROR: " <> displayException (ex :: HeadroomError) + exitWith $ ExitFailure 1 + ) bootstrap :: Command -> IO () bootstrap = \case - c@(Gen _ _) -> do - cgoGenMode <- parseGenMode c - commandGen CommandGenOptions { .. } - Init cioLicenseType cioSourcePaths -> commandInit CommandInitOptions { .. } - Run croSourcePaths croExcludedPaths croExcludeIgnoredPaths croBuiltInTemplates croTemplateRefs croVariables croRunMode croDebug croDryRun - -> commandRun CommandRunOptions { .. } + c@(Gen _ _) -> do + cgoGenMode <- parseGenMode c + commandGen CommandGenOptions{..} + Init cioLicenseType cioSourcePaths -> commandInit CommandInitOptions{..} + Run croSourcePaths croExcludedPaths croExcludeIgnoredPaths croBuiltInTemplates croTemplateRefs croVariables croRunMode croDebug croDryRun -> + commandRun CommandRunOptions{..} diff --git a/doc/templates/haskell.mustache b/doc/templates/haskell.mustache index 7fab279..4db52b8 100644 --- a/doc/templates/haskell.mustache +++ b/doc/templates/haskell.mustache @@ -1,11 +1,10 @@ -{-| -Module : {{{ _haskell_module_name }}} -Description : {{{ _haskell_module_shortdesc }}} -Copyright : (c) {{ year }} {{ author }} -License : {{ license }} -Maintainer : {{ email }} -Stability : experimental -Portability : POSIX - -{{{ _haskell_module_longdesc }}} --} \ No newline at end of file +-- | +-- Module : {{{ _haskell_module_name }}} +-- Description : {{{ _haskell_module_shortdesc }}} +-- Copyright : (c) {{ year }} {{ author }} +-- License : {{ license }} +-- Maintainer : {{ email }} +-- Stability : experimental +-- Portability : POSIX +-- +-- {{{ _haskell_module_longdesc }}} \ No newline at end of file diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..28699dc --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,3 @@ +comma-style: leading +haddock-style: single-line +import-export-comma-style: leading diff --git a/src/Headroom/Command.hs b/src/Headroom/Command.hs index e68c5c6..dc23052 100644 --- a/src/Headroom/Command.hs +++ b/src/Headroom/Command.hs @@ -1,183 +1,217 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.Command -Description : Support for parsing command line arguments -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains code responsible for parsing command line arguments, using -the /optparse-applicative/ library. --} - -module Headroom.Command - ( commandParser - ) -where - -import Headroom.Command.Readers ( licenseReader - , licenseTypeReader - , regexReader - , templateRefReader - ) -import Headroom.Command.Types ( Command(..) ) -import Headroom.Config.Types ( LicenseType - , RunMode(..) - ) -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 +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.Command +-- Description : Support for parsing command line arguments +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains code responsible for parsing command line arguments, using +-- the /optparse-applicative/ library. +module Headroom.Command ( + commandParser +) where + +import Headroom.Command.Readers ( + licenseReader + , licenseTypeReader + , regexReader + , templateRefReader + ) +import Headroom.Command.Types (Command (..)) +import Headroom.Config.Types ( + LicenseType + , RunMode (..) + ) +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 ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Parses command line arguments. commandParser :: ParserInfo Command -commandParser = info - (helper <*> versionP <*> commandP) - (fullDesc <> progDesc (T.unpack productDesc) <> header (T.unpack productInfo)) - +commandParser = + info + (helper <*> versionP <*> commandP) + (fullDesc <> progDesc (T.unpack productDesc) <> header (T.unpack productInfo)) ------------------------------ PRIVATE FUNCTIONS ----------------------------- versionP :: Parser (a -> a) versionP = versionInfoP <*> versionNumP - where - 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") - + where + 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) - (progDesc "add, replace, drop or check source code headers") - ) - genCommand = command - "gen" - (info (genOptions <**> helper) - (progDesc "generate stub configuration and template files") - ) - initCommand = command - "init" - (info (initOptions <**> helper) - (progDesc "initialize current project for Headroom") - ) - + where + runCommand = + command + "run" + ( info + (runOptions <**> helper) + (progDesc "add, replace, drop or check source code headers") + ) + genCommand = + command + "gen" + ( info + (genOptions <**> helper) + (progDesc "generate stub configuration and template files") + ) + initCommand = + command + "init" + ( info + (initOptions <**> helper) + (progDesc "initialize current project for Headroom") + ) runOptions :: Parser Command runOptions = - Run - <$> many - (strOption - (long "source-path" <> short 's' <> metavar "PATH" <> help - "path to source code file/directory" - ) - ) - <*> many - (option - regexReader - (long "excluded-path" <> short 'e' <> metavar "REGEX" <> help - "path to exclude from source code file paths" + Run + <$> many + ( strOption + ( long "source-path" + <> short 's' + <> metavar "PATH" + <> help + "path to source code file/directory" + ) ) - ) - <*> switch - ( long "exclude-ignored-paths" - <> help "exclude paths ignored by used VCS" - ) - <*> optional - (option - licenseTypeReader - (long "builtin-templates" <> metavar "licenseType" <> help - "use built-in templates of selected license type" + <*> many + ( option + regexReader + ( long "excluded-path" + <> short 'e' + <> metavar "REGEX" + <> help + "path to exclude from source code file paths" + ) ) - ) - <*> many - (option - templateRefReader - (long "template-path" <> short 't' <> metavar "PATH" <> help - "path to template, can be either local file or directory or URL" + <*> switch + ( long "exclude-ignored-paths" + <> help "exclude paths ignored by used VCS" ) - ) - <*> many - (strOption - (long "variable" <> short 'v' <> metavar "KEY=VALUE" <> help - "value for template variable" + <*> optional + ( option + licenseTypeReader + ( long "builtin-templates" + <> metavar "licenseType" + <> help + "use built-in templates of selected license type" + ) ) - ) - <*> optional - ( flag' - Add - (long "add-headers" <> short 'a' <> help - "only adds missing license headers" - ) - <|> flag' - Check - (long "check-headers" <> short 'c' <> help - "check whether existing headers are up-to-date" + <*> many + ( option + templateRefReader + ( long "template-path" + <> short 't' + <> metavar "PATH" + <> help + "path to template, can be either local file or directory or URL" ) - <|> flag' - Replace - (long "replace-headers" <> short 'r' <> help - "force replace existing license headers" + ) + <*> many + ( strOption + ( long "variable" + <> short 'v' + <> metavar "KEY=VALUE" + <> help + "value for template variable" ) - <|> flag' - Drop - (long "drop-headers" <> short 'd' <> help - "drop existing license headers only" + ) + <*> optional + ( flag' + Add + ( long "add-headers" + <> short 'a' + <> help + "only adds missing license headers" ) - ) - <*> switch (long "debug" <> help "produce more verbose output") - <*> switch (long "dry-run" <> help "execute dry run (no changes to files)") - + <|> flag' + Check + ( long "check-headers" + <> short 'c' + <> help + "check whether existing headers are up-to-date" + ) + <|> flag' + Replace + ( long "replace-headers" + <> short 'r' + <> help + "force replace existing license headers" + ) + <|> flag' + Drop + ( long "drop-headers" + <> short 'd' + <> help + "drop existing license headers only" + ) + ) + <*> 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 - <$> switch - (long "config-file" <> short 'c' <> help - "generate stub YAML config file to stdout" - ) - <*> optional - (option - licenseReader - ( long "license" - <> short 'l' - <> metavar "licenseType:fileType" - <> help "generate template for license and file type" + Gen + <$> switch + ( long "config-file" + <> short 'c' + <> help + "generate stub YAML config file to stdout" + ) + <*> optional + ( option + licenseReader + ( long "license" + <> short 'l' + <> metavar "licenseType:fileType" + <> help "generate template for license and file type" + ) ) - ) - initOptions :: Parser Command initOptions = - Init - <$> option - licenseTypeReader - (long "license-type" <> short 'l' <> metavar "TYPE" <> help - ( "type of open source license, available options: " - <> T.unpack (T.toLower (allValuesToText @LicenseType)) + Init + <$> option + licenseTypeReader + ( long "license-type" + <> short 'l' + <> metavar "TYPE" + <> help + ( "type of open source license, available options: " + <> T.unpack (T.toLower (allValuesToText @LicenseType)) + ) ) - ) - <*> some - (strOption - (long "source-path" <> short 's' <> metavar "PATH" <> help - "path to source code file/directory" + <*> some + ( strOption + ( long "source-path" + <> short 's' + <> metavar "PATH" + <> help + "path to source code file/directory" + ) ) - ) diff --git a/src/Headroom/Command/Bootstrap.hs b/src/Headroom/Command/Bootstrap.hs index 9fd5cfd..62759bd 100644 --- a/src/Headroom/Command/Bootstrap.hs +++ b/src/Headroom/Command/Bootstrap.hs @@ -1,140 +1,142 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Headroom.Command.Bootstrap -Description : Logic for bootstrapping Headroom -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Logic for running shared code and bootstrapping all /Headroom/ command /RIO/ -applications. --} - -module Headroom.Command.Bootstrap - ( BootstrapEnv(..) - , bootstrap - , runRIO' - , globalKVStore - ) -where - -import Data.String.Interpolate ( iii ) -import Headroom.Config.Global ( GlobalConfig(..) - , globalConfigPath - , initGlobalConfigIfNeeded - , loadGlobalConfig - ) -import Headroom.Data.Has ( Has(..) - , HasRIO - ) -import Headroom.IO.FileSystem ( FileSystem(..) ) -import Headroom.IO.KVStore ( KVStore - , StorePath(..) - , sqliteKVStore - ) -import Headroom.IO.Network ( Network ) -import Headroom.Meta ( cacheFileName - , globalConfigDirName - , productInfo - , webRepo - ) -import Headroom.Meta.Version ( Version - , printVersionP - ) -import Headroom.UI.Message ( messageInfo ) -import Headroom.Updater ( UpdaterError(..) - , checkUpdates - ) -import RIO -import RIO.FilePath ( () ) -import qualified RIO.Text as T +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.Command.Bootstrap +-- Description : Logic for bootstrapping Headroom +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Logic for running shared code and bootstrapping all /Headroom/ command /RIO/ +-- applications. +module Headroom.Command.Bootstrap ( + BootstrapEnv (..) + , bootstrap + , runRIO' + , globalKVStore +) where + +import Data.String.Interpolate (iii) +import Headroom.Config.Global ( + GlobalConfig (..) + , globalConfigPath + , initGlobalConfigIfNeeded + , loadGlobalConfig + ) +import Headroom.Data.Has ( + Has (..) + , HasRIO + ) +import Headroom.IO.FileSystem (FileSystem (..)) +import Headroom.IO.KVStore ( + KVStore + , StorePath (..) + , sqliteKVStore + ) +import Headroom.IO.Network (Network) +import Headroom.Meta ( + cacheFileName + , globalConfigDirName + , productInfo + , webRepo + ) +import Headroom.Meta.Version ( + Version + , printVersionP + ) +import Headroom.UI.Message (messageInfo) +import Headroom.Updater ( + UpdaterError (..) + , checkUpdates + ) +import RIO +import RIO.FilePath (()) +import qualified RIO.Text as T -- | Bootstrap environment, containing pieces shared between all commands. data BootstrapEnv = BootstrapEnv - { beGlobalConfig :: GlobalConfig -- ^ loaded global configuration - } - + { beGlobalConfig :: GlobalConfig + -- ^ loaded global configuration + } -- | Runs /RIO/ application using provided environment data and flag -- whether to run in debug mode. -runRIO' :: (LogFunc -> IO env) - -- ^ function returning environment data - -> Bool - -- ^ whether to run in debug mode - -> RIO env a - -- ^ /RIO/ application to execute - -> IO a - -- ^ execution result +runRIO' :: + -- | function returning environment data + (LogFunc -> IO env) -> + -- | whether to run in debug mode + Bool -> + -- | /RIO/ application to execute + RIO env a -> + -- | execution result + IO a runRIO' enfFn isDebug logic = do - defLogOptions <- logOptionsHandle stderr isDebug - withLogFunc (setLogUseLoc False defLogOptions) $ \logFunc -> do - env <- liftIO $ enfFn logFunc - runRIO env logic - + defLogOptions <- logOptionsHandle stderr isDebug + withLogFunc (setLogUseLoc False defLogOptions) $ \logFunc -> do + env <- liftIO $ enfFn logFunc + runRIO env logic -- | Executes the initialization logic that should be performed before any other -- code is executed. During this bootstrap, for example /global configuration/ -- is initialized and loaded, welcome message is printed to console and updates -- are checked. -bootstrap :: ( HasRIO FileSystem env - , HasRIO KVStore env - , HasRIO Network env - , HasLogFunc env - ) - => RIO env BootstrapEnv +bootstrap :: + ( HasRIO FileSystem env + , HasRIO KVStore env + , HasRIO Network env + , HasLogFunc env + ) => + RIO env BootstrapEnv bootstrap = do - welcomeMessage - initGlobalConfigIfNeeded - globalConfig@GlobalConfig {..} <- loadGlobalConfig - catch (checkUpdates gcUpdates) onError >>= \case - Nothing -> pure () - Just newVersion -> displayUpdate newVersion - pure BootstrapEnv { beGlobalConfig = globalConfig } - where - onError err = do - logWarn . display . T.pack $ displayException (err :: UpdaterError) - pure Nothing - + welcomeMessage + initGlobalConfigIfNeeded + globalConfig@GlobalConfig{..} <- loadGlobalConfig + catch (checkUpdates gcUpdates) onError >>= \case + Nothing -> pure () + Just newVersion -> displayUpdate newVersion + pure BootstrapEnv{beGlobalConfig = globalConfig} + where + onError err = do + logWarn . display . T.pack $ displayException (err :: UpdaterError) + pure Nothing -- | Shared /SQLite/-based 'KVStore'. globalKVStore :: (HasRIO FileSystem env) => RIO env (KVStore (RIO env)) globalKVStore = do - FileSystem {..} <- viewL - userDir <- fsGetUserDirectory - pure - . sqliteKVStore - . StorePath - . T.pack - $ userDir - globalConfigDirName - cacheFileName - + FileSystem{..} <- viewL + userDir <- fsGetUserDirectory + pure + . sqliteKVStore + . StorePath + . T.pack + $ userDir + globalConfigDirName + cacheFileName ------------------------------ PRIVATE FUNCTIONS ----------------------------- welcomeMessage :: HasLogFunc env => RIO env () welcomeMessage = logInfo . display $ productInfo - -displayUpdate :: (HasRIO FileSystem env, HasLogFunc env) - => Version - -> RIO env () +displayUpdate :: + (HasRIO FileSystem env, HasLogFunc env) => + Version -> + RIO env () displayUpdate version = do - configPath <- globalConfigPath - logInfo . display . messageInfo $ message configPath - where - message configPath = [iii| + configPath <- globalConfigPath + logInfo . display . messageInfo $ message configPath + where + message configPath = + [iii| New version #{printVersionP version} is available for download, you can get it from #{webRepo}.\n\t Tired of seeing this message? You can change the behaviour in global diff --git a/src/Headroom/Command/Gen.hs b/src/Headroom/Command/Gen.hs index dd6ca24..2441f82 100644 --- a/src/Headroom/Command/Gen.hs +++ b/src/Headroom/Command/Gen.hs @@ -1,125 +1,120 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Headroom.Command.Gen -Description : Handler for the @gen@ command. -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -The @gen@ command is responsible for generating various files requied by -/Headroom/, such as /YAML/ configuration stubs or /Mustache/ license templates. -Run /Headroom/ using the @headroom gen --help@ to see available options. --} - -module Headroom.Command.Gen - ( commandGen - , parseGenMode - ) -where - - -import Data.String.Interpolate ( iii ) -import Headroom.Command.Types ( Command(..) - , CommandGenOptions(..) - ) -import Headroom.Command.Utils ( bootstrap ) -import Headroom.Config.Enrich ( Enrich(..) - , replaceEmptyValue - , withText - ) -import Headroom.Config.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 - - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Command.Gen +-- Description : Handler for the @gen@ command. +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- The @gen@ command is responsible for generating various files requied by +-- /Headroom/, such as /YAML/ configuration stubs or /Mustache/ license templates. +-- Run /Headroom/ using the @headroom gen help@ to see available options. +module Headroom.Command.Gen ( + commandGen + , parseGenMode +) where + +import Data.String.Interpolate (iii) +import Headroom.Command.Types ( + Command (..) + , CommandGenOptions (..) + ) +import Headroom.Command.Utils (bootstrap) +import Headroom.Config.Enrich ( + Enrich (..) + , replaceEmptyValue + , withText + ) +import Headroom.Config.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 RIO +import qualified RIO.Text as T +import Prelude (putStrLn) --------------------------------- DATA TYPES --------------------------------- data Env = Env - { envLogFunc :: !LogFunc - -- ^ logging function - , envGenOptions :: !CommandGenOptions - -- ^ options - } + { envLogFunc :: !LogFunc + -- ^ logging function + , envGenOptions :: !CommandGenOptions + -- ^ options + } suffixLensesFor ["envLogFunc"] ''Env - instance HasLogFunc Env where - logFuncL = envLogFuncL - + logFuncL = envLogFuncL env' :: CommandGenOptions -> LogFunc -> IO Env -env' opts logFunc = pure $ Env { envLogFunc = logFunc, envGenOptions = opts } - +env' opts logFunc = pure $ Env{envLogFunc = logFunc, envGenOptions = opts} ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Parses 'GenMode' from combination of options from given 'Command'. -parseGenMode :: MonadThrow m - => Command - -- ^ command from which to parse the 'GenMode' - -> m GenMode - -- ^ parsed 'GenMode' +parseGenMode :: + MonadThrow m => + -- | command from which to parse the 'GenMode' + Command -> + -- | parsed 'GenMode' + m GenMode parseGenMode = \case - Gen True Nothing -> pure GenConfigFile - Gen False (Just license) -> pure $ GenLicense license - _ -> throwM NoGenModeSelected - + Gen True Nothing -> pure GenConfigFile + Gen False (Just license) -> pure $ GenLicense license + _ -> throwM NoGenModeSelected -- | Handler for /Generator/ command. -commandGen :: CommandGenOptions - -- ^ /Generator/ command options - -> IO () - -- ^ execution result +commandGen :: + -- | /Generator/ command options + CommandGenOptions -> + -- | execution result + IO () commandGen opts = bootstrap (env' opts) False $ case cgoGenMode opts of - GenConfigFile -> liftIO printConfigFile - GenLicense (lType, fType) -> liftIO . putStrLn $ licenseTemplate lType fType - + GenConfigFile -> liftIO printConfigFile + GenLicense (lType, fType) -> liftIO . putStrLn $ licenseTemplate lType fType ------------------------------ PRIVATE FUNCTIONS ----------------------------- printConfigFile :: IO () printConfigFile = putStrLn . T.unpack $ enrich modify configFileStub - where - modify = replaceEmptyValue "version" $ withText ver - ver = printVersion buildVersion - + where + modify = replaceEmptyValue "version" $ withText ver + ver = printVersion buildVersion --------------------------------- ERROR TYPES -------------------------------- -- | Exception specific to the @gen@ command. -data CommandGenError = NoGenModeSelected - -- ^ no mode of /Gen/ command selected - deriving (Eq, Show) +data CommandGenError + = -- | no mode of /Gen/ command selected + NoGenModeSelected + deriving (Eq, Show) instance Exception CommandGenError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: CommandGenError -> String displayException' = \case - NoGenModeSelected -> [iii| + 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 index 5005ae6..e4e5d87 100644 --- a/src/Headroom/Command/Init.hs +++ b/src/Headroom/Command/Init.hs @@ -1,261 +1,275 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.Command.Init -Description : Handler for the @init@ command -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module representing the @init@ command, responsible for generating all the -required files (configuration, templates) for the given project, which are then -required by the @run@ or @gen@ commands. --} - -module Headroom.Command.Init - ( Env(..) - , Paths(..) - , commandInit - , doesAppConfigExist - , findSupportedFileTypes - ) -where - -import Data.String.Interpolate ( iii ) -import Headroom.Command.Types ( CommandInitOptions(..) ) -import Headroom.Command.Utils ( bootstrap ) -import Headroom.Config ( makeHeadersConfig - , parseAppConfig - ) -import Headroom.Config.Enrich ( Enrich(..) - , replaceEmptyValue - , withArray - , withText - ) -import Headroom.Config.Types ( AppConfig(..) - , LicenseType(..) - ) -import Headroom.Data.Has ( Has(..) - , HasRIO - ) -import Headroom.Data.Lens ( suffixLenses ) -import Headroom.Embedded ( configFileStub - , defaultConfig - , licenseTemplate - ) -import Headroom.FileType ( fileTypeByExt ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.IO.FileSystem ( FileSystem(..) - , fileExtension - , findFiles - , mkFileSystem - ) -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.NonEmpty as NE -import qualified RIO.Text as T - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Command.Init +-- Description : Handler for the @init@ command +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module representing the @init@ command, responsible for generating all the +-- required files (configuration, templates) for the given project, which are then +-- required by the @run@ or @gen@ commands. +module Headroom.Command.Init ( + Env (..) + , Paths (..) + , commandInit + , doesAppConfigExist + , findSupportedFileTypes +) where + +import Data.String.Interpolate (iii) +import Headroom.Command.Types (CommandInitOptions (..)) +import Headroom.Command.Utils (bootstrap) +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Enrich ( + Enrich (..) + , replaceEmptyValue + , withArray + , withText + ) +import Headroom.Config.Types ( + AppConfig (..) + , LicenseType (..) + ) +import Headroom.Data.Has ( + Has (..) + , HasRIO + ) +import Headroom.Data.Lens (suffixLenses) +import Headroom.Embedded ( + configFileStub + , defaultConfig + , licenseTemplate + ) +import Headroom.FileType (fileTypeByExt) +import Headroom.FileType.Types (FileType (..)) +import Headroom.IO.FileSystem ( + FileSystem (..) + , fileExtension + , findFiles + , mkFileSystem + ) +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.NonEmpty as NE +import qualified RIO.Text as T --------------------------------- DATA TYPES --------------------------------- -- | /RIO/ Environment for the @init@ command. data Env = Env - { envLogFunc :: LogFunc - , envFileSystem :: FileSystem (RIO Env) - , envInitOptions :: CommandInitOptions - , envPaths :: Paths - } - + { envLogFunc :: LogFunc + , envFileSystem :: FileSystem (RIO Env) + , envInitOptions :: CommandInitOptions + , envPaths :: Paths + } -- | Paths to various locations of file system. data Paths = Paths - { pConfigFile :: FilePath - , pTemplatesDir :: FilePath - } + { pConfigFile :: FilePath + , pTemplatesDir :: FilePath + } suffixLenses ''Env - instance HasLogFunc Env where - logFuncL = envLogFuncL - + logFuncL = envLogFuncL instance Has CommandInitOptions Env where - hasLens = envInitOptionsL - + hasLens = envInitOptionsL instance Has (FileSystem (RIO Env)) Env where - hasLens = envFileSystemL - + hasLens = envFileSystemL instance Has Paths Env where - hasLens = envPathsL - + hasLens = envPathsL env' :: CommandInitOptions -> LogFunc -> IO Env env' opts logFunc = do - let paths = Paths { pConfigFile = configFileName - , pTemplatesDir = "headroom-templates" - } - pure $ Env { envLogFunc = logFunc - , envFileSystem = mkFileSystem - , envInitOptions = opts - , envPaths = paths - } - + let paths = + Paths + { pConfigFile = configFileName + , pTemplatesDir = "headroom-templates" + } + pure $ + Env + { envLogFunc = logFunc + , envFileSystem = mkFileSystem + , envInitOptions = opts + , envPaths = paths + } ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Handler for @init@ command. -commandInit :: CommandInitOptions -- ^ @init@ command options - -> IO () -- ^ execution result -commandInit opts = bootstrap (env' opts) False $ doesAppConfigExist >>= \case - False -> do - fileTypes <- findSupportedFileTypes - makeTemplatesDir - createTemplates fileTypes - createConfigFile - True -> do - paths <- viewL - throwM . AppConfigAlreadyExists $ pConfigFile paths - +commandInit :: + -- | @init@ command options + CommandInitOptions -> + -- | execution result + IO () +commandInit opts = + bootstrap (env' opts) False $ + doesAppConfigExist >>= \case + False -> do + fileTypes <- findSupportedFileTypes + makeTemplatesDir + createTemplates fileTypes + createConfigFile + True -> do + 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) - => RIO env [FileType] +findSupportedFileTypes :: + (Has CommandInitOptions env, HasLogFunc env) => + RIO env [FileType] findSupportedFileTypes = do - opts <- viewL - pHeadersConfig <- acLicenseHeaders <$> parseAppConfig defaultConfig - headersConfig <- makeHeadersConfig pHeadersConfig - fileTypes <- do - allFiles <- mapM (\path -> findFiles path (const True)) - (cioSourcePaths opts) - let allFileTypes = fmap (fileExtension >=> fileTypeByExt headersConfig) - (concat allFiles) - pure . L.nub . catMaybes $ allFileTypes - case fileTypes of - [] -> throwM NoProvidedSourcePaths - _ -> do - logInfo $ "Found supported file types: " <> displayShow fileTypes - pure fileTypes - + opts <- viewL + pHeadersConfig <- acLicenseHeaders <$> parseAppConfig defaultConfig + headersConfig <- makeHeadersConfig pHeadersConfig + fileTypes <- do + allFiles <- + mapM + (\path -> findFiles path (const True)) + (cioSourcePaths opts) + let allFileTypes = + fmap + (fileExtension >=> fileTypeByExt headersConfig) + (concat allFiles) + pure . L.nub . catMaybes $ allFileTypes + case fileTypes of + [] -> throwM NoProvidedSourcePaths + _ -> do + logInfo $ "Found supported file types: " <> displayShow fileTypes + pure fileTypes -- | Checks whether application config file already exists. -doesAppConfigExist :: (HasLogFunc env, HasRIO FileSystem env, Has Paths env) - => RIO env Bool +doesAppConfigExist :: + (HasLogFunc env, HasRIO FileSystem env, Has Paths env) => + RIO env Bool doesAppConfigExist = do - FileSystem {..} <- viewL - Paths {..} <- viewL - logInfo "Verifying that there's no existing Headroom configuration..." - fsDoesFileExist pConfigFile - + 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 () +createTemplates :: + (Has CommandInitOptions env, HasLogFunc env, Has Paths env) => + [FileType] -> + RIO env () createTemplates fileTypes = do - opts <- viewL - Paths {..} <- viewL - mapM_ (\(p, lf) -> createTemplate pTemplatesDir lf p) - (zipWithProgress $ fmap (cioLicenseType opts, ) fileTypes) - - -createTemplate :: (HasLogFunc env) - => FilePath - -> (LicenseType, FileType) - -> Progress - -> RIO env () + opts <- viewL + Paths{..} <- viewL + mapM_ + (\(p, lf) -> createTemplate pTemplatesDir lf p) + (zipWithProgress $ fmap (cioLicenseType opts,) fileTypes) + +createTemplate :: + (HasLogFunc env) => + FilePath -> + (LicenseType, FileType) -> + Progress -> + RIO env () createTemplate templatesDir (licenseType, fileType) progress = do - let extension = NE.head $ templateExtensions @TemplateType - file = (fmap C.toLower . show $ fileType) <> "." <> T.unpack extension - filePath = templatesDir file - template = licenseTemplate licenseType fileType - logInfo $ mconcat - [display progress, " Creating template file in ", fromString filePath] - writeFileUtf8 filePath template - - -createConfigFile :: (Has CommandInitOptions env, HasLogFunc env, Has Paths env) - => RIO env () + let extension = NE.head $ templateExtensions @TemplateType + file = (fmap C.toLower . show $ fileType) <> "." <> T.unpack extension + filePath = templatesDir file + template = licenseTemplate licenseType fileType + logInfo $ + mconcat + [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 $ enrich (modify opts p) configFileStub - where - modify opts paths = mconcat - [ replaceEmptyValue "version" $ withText (printVersion buildVersion) - , replaceEmptyValue "source-paths" $ withArray (cioSourcePaths opts) - , replaceEmptyValue "template-paths" $ withArray [pTemplatesDir paths] - ] - - -makeTemplatesDir :: (HasLogFunc env, HasRIO FileSystem env, Has Paths env) - => RIO env () + opts <- viewL + p@Paths{..} <- viewL + logInfo $ "Creating YAML config file in " <> fromString pConfigFile + writeFileUtf8 pConfigFile $ enrich (modify opts p) configFileStub + where + modify opts paths = + mconcat + [ replaceEmptyValue "version" $ withText (printVersion buildVersion) + , replaceEmptyValue "source-paths" $ withArray (cioSourcePaths opts) + , replaceEmptyValue "template-paths" $ withArray [pTemplatesDir paths] + ] + +makeTemplatesDir :: + (HasLogFunc env, HasRIO FileSystem env, Has Paths env) => + RIO env () makeTemplatesDir = do - FileSystem {..} <- viewL - Paths {..} <- viewL - logInfo $ "Creating directory for templates in " <> fromString pTemplatesDir - fsCreateDirectory pTemplatesDir - + FileSystem{..} <- viewL + Paths{..} <- viewL + logInfo $ "Creating directory for templates in " <> fromString pTemplatesDir + fsCreateDirectory pTemplatesDir --------------------------------- ERROR TYPES -------------------------------- -- | Exception specific to the "Headroom.Command.Init" module data CommandInitError - = AppConfigAlreadyExists FilePath - -- ^ application configuration file already exists - | NoProvidedSourcePaths - -- ^ no paths to source code files provided - | NoSupportedFileType - -- ^ no supported file types found on source paths - deriving (Eq, Show) - + = -- | application configuration file already exists + AppConfigAlreadyExists FilePath + | -- | no paths to source code files provided + NoProvidedSourcePaths + | -- | no supported file types found on source paths + NoSupportedFileType + deriving (Eq, Show) instance Exception CommandInitError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: CommandInitError -> String displayException' = \case - AppConfigAlreadyExists path -> [iii| + AppConfigAlreadyExists path -> + [iii| Configuration file '#{path}' already exists |] - NoProvidedSourcePaths -> [iii| + NoProvidedSourcePaths -> + [iii| No source code paths (files or directories) defined |] - NoSupportedFileType -> [iii| + 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 index d09d0ce..7a782cf 100644 --- a/src/Headroom/Command/Readers.hs +++ b/src/Headroom/Command/Readers.hs @@ -1,84 +1,82 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.Command.Readers -Description : Custom readers for /optparse-applicative/ library -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains custom readers required by the /optparse-applicative/ -library to parse data types such as 'LicenseType' or 'FileType'. --} - -module Headroom.Command.Readers - ( licenseReader - , licenseTypeReader - , regexReader - , templateRefReader - , parseLicense - ) -where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Data.Either.Combinators ( maybeToRight ) -import Headroom.Config.Types ( LicenseType ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Data.Regex ( Regex(..) - , compile - ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Template.TemplateRef ( TemplateRef(..) - , mkTemplateRef - ) -import Options.Applicative -import RIO -import qualified RIO.Text as T -import qualified RIO.Text.Partial as TP +-- | +-- Module : Headroom.Command.Readers +-- Description : Custom readers for /optparse-applicative/ library +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains custom readers required by the /optparse-applicative/ +-- library to parse data types such as 'LicenseType' or 'FileType'. +module Headroom.Command.Readers ( + licenseReader + , licenseTypeReader + , regexReader + , templateRefReader + , parseLicense +) where +import Data.Either.Combinators (maybeToRight) +import Headroom.Config.Types (LicenseType) +import Headroom.Data.EnumExtra (EnumExtra (..)) +import Headroom.Data.Regex ( + Regex (..) + , compile + ) +import Headroom.FileType.Types (FileType (..)) +import Headroom.Template.TemplateRef ( + TemplateRef (..) + , mkTemplateRef + ) +import Options.Applicative +import RIO +import qualified RIO.Text as T +import qualified RIO.Text.Partial as TP -- | Reader for tuple of 'LicenseType' and 'FileType'. licenseReader :: ReadM (LicenseType, FileType) licenseReader = eitherReader parseLicense' - where - 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)" - , "\nAvailable license types: " - , T.toLower (allValuesToText @LicenseType) - , "\nAvailable file types: " - , T.toLower (allValuesToText @FileType) - ] - + where + 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)" + , "\nAvailable license types: " + , T.toLower (allValuesToText @LicenseType) + , "\nAvailable file types: " + , T.toLower (allValuesToText @FileType) + ] -- | Reader for 'LicenseType'. licenseTypeReader :: ReadM LicenseType licenseTypeReader = eitherReader parseLicenseType - where - parseLicenseType raw = maybeToRight errMsg (textToEnum $ T.pack raw) - errMsg = T.unpack $ mconcat - [ "invalid license type, available options: " - , T.toLower (allValuesToText @LicenseType) - ] - + where + parseLicenseType raw = maybeToRight errMsg (textToEnum $ T.pack raw) + errMsg = + T.unpack $ + mconcat + [ "invalid license type, available options: " + , T.toLower (allValuesToText @LicenseType) + ] -- | Reader for 'Regex'. regexReader :: ReadM Regex regexReader = - let parse input = mapLeft displayException (compile . T.pack $ input) - in eitherReader parse - + let parse input = mapLeft displayException (compile . T.pack $ input) + in eitherReader parse -- | Reader for 'TemplateRef'. templateRefReader :: ReadM TemplateRef templateRefReader = - let parse input = mapLeft displayException (mkTemplateRef . T.pack $ input) - in eitherReader parse - + let parse input = mapLeft displayException (mkTemplateRef . T.pack $ input) + in eitherReader parse -- | Parses 'LicenseType' and 'FileType' from the input string, -- formatted as @licenseType:fileType@. @@ -87,5 +85,5 @@ templateRefReader = -- Just (BSD3,Haskell) parseLicense :: Text -> Maybe (LicenseType, FileType) parseLicense raw - | [lt, ft] <- TP.splitOn ":" raw = (,) <$> textToEnum lt <*> textToEnum ft - | otherwise = Nothing + | [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 index f2df0fc..6ff28b1 100644 --- a/src/Headroom/Command/Run.hs +++ b/src/Headroom/Command/Run.hs @@ -1,524 +1,576 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -Module : Headroom.Command.Run -Description : Handler for the @run@ command. -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module representing the @run@ command, the core command of /Headroom/, which is -responsible for license header management. --} - -module Headroom.Command.Run - ( commandRun - , loadTemplateRefs - , typeOfTemplate - -- * License Header Post-processing - , postProcessHeader' - ) -where - -import Control.Monad.Extra ( ifM ) -import Data.String.Interpolate ( i - , iii - ) -import Data.Time.Calendar ( toGregorian ) -import Data.Time.Clock ( getCurrentTime ) -import Data.Time.Clock.POSIX ( getPOSIXTime ) -import Data.Time.LocalTime ( getCurrentTimeZone - , localDay - , utcToLocalTime - ) -import Data.VCS.Ignore ( Git - , Repo(..) - , findRepo - ) -import Headroom.Command.Bootstrap ( bootstrap - , globalKVStore - , runRIO' - ) -import Headroom.Command.Types ( CommandRunOptions(..) ) -import Headroom.Config ( loadAppConfig - , makeAppConfig - , parseAppConfig - ) -import Headroom.Config.Types ( AppConfig(..) - , CtAppConfig - , CtPostProcessConfigs - , HeaderConfig(..) - , HeaderSyntax(..) - , PtAppConfig - , RunMode(..) - ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Data.Has ( Has(..) - , HasRIO - ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.Embedded ( defaultConfig - , licenseTemplate - ) -import Headroom.FileSupport ( analyzeSourceCode - , fileSupport - ) -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.IO.FileSystem ( FileSystem(..) - , excludePaths - , fileExtension - , mkFileSystem - ) -import Headroom.IO.KVStore ( KVStore ) -import Headroom.IO.Network ( Network(..) - , mkNetwork - ) -import Headroom.Meta ( TemplateType - , configFileName - ) -import Headroom.PostProcess ( mkConfiguredEnv - , postProcessHeader - ) -import Headroom.SourceCode ( SourceCode - , toText - ) -import Headroom.Template ( Template(..) ) -import Headroom.Template.TemplateRef ( TemplateRef(..) - , renderRef - ) -import Headroom.Types ( CurrentYear(..) ) -import Headroom.UI ( Progress(..) - , zipWithProgress - ) -import Headroom.UI.Table ( Table2(..) ) -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 - +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Command.Run +-- Description : Handler for the @run@ command. +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module representing the @run@ command, the core command of /Headroom/, which is +-- responsible for license header management. +module Headroom.Command.Run ( + commandRun + , loadTemplateRefs + , typeOfTemplate + + -- * License Header Post-processing + , postProcessHeader' +) where + +import Control.Monad.Extra (ifM) +import Data.String.Interpolate ( + i + , iii + ) +import Data.Time.Calendar (toGregorian) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Time.LocalTime ( + getCurrentTimeZone + , localDay + , utcToLocalTime + ) +import Data.VCS.Ignore ( + Git + , Repo (..) + , findRepo + ) +import Headroom.Command.Bootstrap ( + bootstrap + , globalKVStore + , runRIO' + ) +import Headroom.Command.Types (CommandRunOptions (..)) +import Headroom.Config ( + loadAppConfig + , makeAppConfig + , parseAppConfig + ) +import Headroom.Config.Types ( + AppConfig (..) + , CtAppConfig + , CtPostProcessConfigs + , HeaderConfig (..) + , HeaderSyntax (..) + , PtAppConfig + , RunMode (..) + ) +import Headroom.Data.EnumExtra (EnumExtra (..)) +import Headroom.Data.Has ( + Has (..) + , HasRIO + ) +import Headroom.Data.Lens ( + suffixLenses + , suffixLensesFor + ) +import Headroom.Embedded ( + defaultConfig + , licenseTemplate + ) +import Headroom.FileSupport ( + analyzeSourceCode + , fileSupport + ) +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.IO.FileSystem ( + FileSystem (..) + , excludePaths + , fileExtension + , mkFileSystem + ) +import Headroom.IO.KVStore (KVStore) +import Headroom.IO.Network ( + Network (..) + , mkNetwork + ) +import Headroom.Meta ( + TemplateType + , configFileName + ) +import Headroom.PostProcess ( + mkConfiguredEnv + , postProcessHeader + ) +import Headroom.SourceCode ( + SourceCode + , toText + ) +import Headroom.Template (Template (..)) +import Headroom.Template.TemplateRef ( + TemplateRef (..) + , renderRef + ) +import Headroom.Types (CurrentYear (..)) +import Headroom.UI ( + Progress (..) + , zipWithProgress + ) +import Headroom.UI.Table (Table2 (..)) +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 suffixLensesFor ["acPostProcessConfigs"] ''AppConfig - -- | Action to be performed based on the selected 'RunMode'. data RunAction = RunAction - { raProcessed :: Bool -- ^ whether the given file was processed - , raFunc :: SourceCode -> SourceCode -- ^ function to process the file - , raProcessedMsg :: Text -- ^ message to show when file was processed - , raSkippedMsg :: Text -- ^ message to show when file was skipped - } - + { raProcessed :: Bool + -- ^ whether the given file was processed + , raFunc :: SourceCode -> SourceCode + -- ^ function to process the file + , raProcessedMsg :: Text + -- ^ message to show when file was processed + , raSkippedMsg :: Text + -- ^ message to show when file was skipped + } -- | Full /RIO/ environment for the /Run/ command. data Env = Env - { envLogFunc :: LogFunc -- ^ logging function - , envRunOptions :: CommandRunOptions -- ^ options - , envConfiguration :: ~CtAppConfig -- ^ application configuration - , envCurrentYear :: CurrentYear -- ^ current year - , envKVStore :: ~(KVStore (RIO Env)) -- ^ key-value store - , envNetwork :: Network (RIO Env) -- ^ network operations - , envFileSystem :: FileSystem (RIO Env) -- ^ file system operations - } + { envLogFunc :: LogFunc + -- ^ logging function + , envRunOptions :: CommandRunOptions + -- ^ options + , envConfiguration :: ~CtAppConfig + -- ^ application configuration + , envCurrentYear :: CurrentYear + -- ^ current year + , envKVStore :: ~(KVStore (RIO Env)) + -- ^ key-value store + , envNetwork :: Network (RIO Env) + -- ^ network operations + , envFileSystem :: FileSystem (RIO Env) + -- ^ file system operations + } suffixLenses ''Env instance Has CtAppConfig Env where - hasLens = envConfigurationL + hasLens = envConfigurationL instance Has CtPostProcessConfigs Env where - hasLens = envConfigurationL . acPostProcessConfigsL + hasLens = envConfigurationL . acPostProcessConfigsL instance HasLogFunc Env where - logFuncL = envLogFuncL + logFuncL = envLogFuncL instance Has CommandRunOptions Env where - hasLens = envRunOptionsL + hasLens = envRunOptionsL instance Has CurrentYear Env where - hasLens = envCurrentYearL + hasLens = envCurrentYearL instance Has (Network (RIO Env)) Env where - hasLens = envNetworkL + hasLens = envNetworkL instance Has (FileSystem (RIO Env)) Env where - hasLens = envFileSystemL + hasLens = envFileSystemL instance Has (KVStore (RIO Env)) Env where - hasLens = envKVStoreL - + hasLens = envKVStoreL getEnv :: CommandRunOptions -> LogFunc -> IO Env getEnv opts logFunc = do - currentYear' <- currentYear - let env0 = Env { envLogFunc = logFunc - , envRunOptions = opts - , envConfiguration = undefined - , envCurrentYear = currentYear' - , envKVStore = undefined - , envNetwork = mkNetwork - , envFileSystem = mkFileSystem - } - config <- runRIO env0 finalConfiguration - kvStore <- runRIO env0 globalKVStore - pure env0 { envConfiguration = config, envKVStore = kvStore } - + currentYear' <- currentYear + let env0 = + Env + { envLogFunc = logFunc + , envRunOptions = opts + , envConfiguration = undefined + , envCurrentYear = currentYear' + , envKVStore = undefined + , envNetwork = mkNetwork + , envFileSystem = mkFileSystem + } + config <- runRIO env0 finalConfiguration + kvStore <- runRIO env0 globalKVStore + pure env0{envConfiguration = config, envKVStore = kvStore} -- | Handler for /Run/ command. -commandRun :: CommandRunOptions -- ^ /Run/ command options - -> IO () -- ^ execution result +commandRun :: + -- | /Run/ command options + CommandRunOptions -> + -- | execution result + IO () commandRun opts = runRIO' (getEnv opts) (croDebug opts) $ do - _ <- bootstrap - CommandRunOptions {..} <- viewL - AppConfig {..} <- viewL @CtAppConfig - let isCheck = acRunMode == Check - warnOnDryRun - startTS <- liftIO getPOSIXTime - templates <- loadTemplates - sourceFiles <- findSourceFiles (M.keys templates) - _ <- logInfo "-----" - (total, processed) <- processSourceFiles @TemplateType templates sourceFiles - endTS <- liftIO getPOSIXTime - when (processed > 0) $ logStickyDone "-----" - logStickyDone $ mconcat - [ "Done: " - , if isCheck then "outdated " else "modified " - , display processed - , if isCheck then ", up-to-date " else ", skipped " - , display (total - processed) - , " files in " - , displayShow (endTS - startTS) - , " seconds." - ] - warnOnDryRun - when (not croDryRun && isCheck && processed > 0) (exitWith $ ExitFailure 1) - + _ <- bootstrap + CommandRunOptions{..} <- viewL + AppConfig{..} <- viewL @CtAppConfig + let isCheck = acRunMode == Check + warnOnDryRun + startTS <- liftIO getPOSIXTime + templates <- loadTemplates + sourceFiles <- findSourceFiles (M.keys templates) + _ <- logInfo "-----" + (total, processed) <- processSourceFiles @TemplateType templates sourceFiles + endTS <- liftIO getPOSIXTime + when (processed > 0) $ logStickyDone "-----" + logStickyDone $ + mconcat + [ "Done: " + , if isCheck then "outdated " else "modified " + , display processed + , if isCheck then ", up-to-date " else ", skipped " + , display (total - processed) + , " files in " + , displayShow (endTS - startTS) + , " seconds." + ] + warnOnDryRun + when (not croDryRun && isCheck && processed > 0) (exitWith $ ExitFailure 1) warnOnDryRun :: (HasLogFunc env, Has CommandRunOptions env) => RIO env () warnOnDryRun = do - CommandRunOptions {..} <- viewL - when croDryRun $ logWarn "[!] Running with '--dry-run', no files are changed!" + CommandRunOptions{..} <- viewL + when croDryRun $ logWarn "[!] Running with '--dry-run', no files are changed!" - -findSourceFiles :: (Has CtAppConfig env, HasRIO FileSystem env, HasLogFunc env) - => [FileType] - -> RIO env [FilePath] +findSourceFiles :: + (Has CtAppConfig env, HasRIO FileSystem env, HasLogFunc env) => + [FileType] -> + RIO env [FilePath] findSourceFiles fileTypes = do - AppConfig {..} <- viewL - FileSystem {..} <- viewL - logDebug $ "Using source paths: " <> displayShow acSourcePaths - files <- - mconcat - <$> mapM (fsFindFilesByTypes acLicenseHeaders fileTypes) acSourcePaths - notIgnored <- excludePaths acExcludedPaths <$> excludeIgnored files - logInfo [iii| + AppConfig{..} <- viewL + FileSystem{..} <- viewL + logDebug $ "Using source paths: " <> displayShow acSourcePaths + files <- + mconcat + <$> mapM (fsFindFilesByTypes acLicenseHeaders fileTypes) acSourcePaths + notIgnored <- excludePaths acExcludedPaths <$> excludeIgnored files + logInfo + [iii| Found #{length notIgnored} files to process (excluded #{length files - length notIgnored}) |] - pure notIgnored - + pure notIgnored -excludeIgnored :: (Has CtAppConfig env, HasRIO FileSystem env, HasLogFunc env) - => [FilePath] - -> RIO env [FilePath] +excludeIgnored :: + (Has CtAppConfig env, HasRIO FileSystem env, HasLogFunc env) => + [FilePath] -> + RIO env [FilePath] excludeIgnored paths = do - AppConfig {..} <- viewL @CtAppConfig - FileSystem {..} <- viewL - currentDir <- fsGetCurrentDirectory - maybeRepo <- ifM (pure acExcludeIgnoredPaths) - (findRepo' currentDir) - (pure Nothing) - case maybeRepo of - Just repo -> filterM (fmap not . isIgnored repo) paths - Nothing -> pure paths - where - findRepo' dir = do - logInfo "Searching for VCS repository to extract exclude patterns from..." - maybeRepo <- findRepo @_ @Git dir + AppConfig{..} <- viewL @CtAppConfig + FileSystem{..} <- viewL + currentDir <- fsGetCurrentDirectory + maybeRepo <- + ifM + (pure acExcludeIgnoredPaths) + (findRepo' currentDir) + (pure Nothing) case maybeRepo of - Just r -> logInfo [i|Found #{repoName r} repository in: #{dir}|] - _ -> logInfo [i|No VCS repository found in: #{dir}|] - pure maybeRepo - - -processSourceFiles :: forall a env - . ( Template a - , Has CtAppConfig env - , Has CtPostProcessConfigs env - , Has CommandRunOptions env - , Has CurrentYear env - , HasLogFunc env - ) - => Map FileType HeaderTemplate - -> [FilePath] - -> RIO env (Int, Int) + Just repo -> filterM (fmap not . isIgnored repo) paths + Nothing -> pure paths + where + findRepo' dir = do + logInfo "Searching for VCS repository to extract exclude patterns from..." + maybeRepo <- findRepo @_ @Git dir + case maybeRepo of + Just r -> logInfo [i|Found #{repoName r} repository in: #{dir}|] + _ -> logInfo [i|No VCS repository found in: #{dir}|] + pure maybeRepo + +processSourceFiles :: + forall a env. + ( Template a + , Has CtAppConfig env + , Has CtPostProcessConfigs env + , Has CommandRunOptions env + , Has CurrentYear env + , HasLogFunc env + ) => + Map FileType HeaderTemplate -> + [FilePath] -> + RIO env (Int, Int) processSourceFiles templates paths = do - AppConfig {..} <- viewL - year <- viewL - let dVars = dynamicVariables year - withTemplate = mapMaybe (template acLicenseHeaders) paths - cVars <- compileVariables @a (dVars <> acVariables) - processed <- mapM (process cVars dVars) (zipWithProgress withTemplate) - pure (length withTemplate, length . filter (== True) $ processed) - where - 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 @a cVars dVars pr ht p - - -processSourceFile :: forall a env - . ( Template a - , Has CommandRunOptions env - , Has CtAppConfig env - , Has CtPostProcessConfigs env - , Has CurrentYear env - , HasLogFunc env - ) - => Variables - -> Variables - -> Progress - -> HeaderTemplate - -> FilePath - -> RIO env Bool -processSourceFile cVars dVars progress ht@HeaderTemplate {..} path = do - AppConfig {..} <- viewL @CtAppConfig - CommandRunOptions {..} <- viewL - fileContent <- readFileUtf8 path - 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' @a syntax variables header' - RunAction {..} <- chooseAction headerInfo header - let result = raFunc source - changed = raProcessed && (source /= result) - message = if changed then raProcessedMsg else raSkippedMsg - logFn = if changed then logInfo else logSticky - isCheck = acRunMode == Check - logDebug $ "Header info: " <> displayShow headerInfo - logFn $ mconcat [display progress, " ", display message, fromString path] - when (not croDryRun && not isCheck && changed) - (writeFileUtf8 path $ toText result) - pure changed - + AppConfig{..} <- viewL + year <- viewL + let dVars = dynamicVariables year + withTemplate = mapMaybe (template acLicenseHeaders) paths + cVars <- compileVariables @a (dVars <> acVariables) + processed <- mapM (process cVars dVars) (zipWithProgress withTemplate) + pure (length withTemplate, length . filter (== True) $ processed) + where + 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 @a cVars dVars pr ht p + +processSourceFile :: + forall a env. + ( Template a + , Has CommandRunOptions env + , Has CtAppConfig env + , Has CtPostProcessConfigs env + , Has CurrentYear env + , HasLogFunc env + ) => + Variables -> + Variables -> + Progress -> + HeaderTemplate -> + FilePath -> + RIO env Bool +processSourceFile cVars dVars progress ht@HeaderTemplate{..} path = do + AppConfig{..} <- viewL @CtAppConfig + CommandRunOptions{..} <- viewL + fileContent <- readFileUtf8 path + 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' @a syntax variables header' + RunAction{..} <- chooseAction headerInfo header + let result = raFunc source + changed = raProcessed && (source /= result) + message = if changed then raProcessedMsg else raSkippedMsg + logFn = if changed then logInfo else logSticky + isCheck = acRunMode == Check + logDebug $ "Header info: " <> displayShow headerInfo + logFn $ mconcat [display progress, " ", display message, fromString path] + when + (not croDryRun && not isCheck && changed) + (writeFileUtf8 path $ toText result) + pure changed chooseAction :: (Has CtAppConfig env) => HeaderInfo -> Text -> RIO env RunAction chooseAction info header = do - AppConfig {..} <- viewL @CtAppConfig - let hasHeader = isJust $ hiHeaderPos info - pure $ go acRunMode hasHeader - where - go runMode hasHeader = case runMode of - Add -> aAction hasHeader - Check -> cAction hasHeader - Drop -> dAction hasHeader - Replace -> rAction hasHeader - aAction hasHeader = RunAction (not hasHeader) - (addHeader info header) - (justify "Adding header to:") - (justify "Header already exists in:") - cAction hasHeader = (rAction hasHeader) - { raProcessedMsg = justify "Outdated header found in:" - , raSkippedMsg = justify "Header up-to-date in:" - } - dAction hasHeader = RunAction hasHeader - (dropHeader info) - (justify "Dropping header from:") - (justify "No header exists in:") - rAction hasHeader = if hasHeader then rAction' else go Add hasHeader - rAction' = RunAction True - (replaceHeader info header) - (justify "Replacing header in:") - (justify "Header up-to-date in:") - justify = T.justifyLeft 30 ' ' - + AppConfig{..} <- viewL @CtAppConfig + let hasHeader = isJust $ hiHeaderPos info + pure $ go acRunMode hasHeader + where + go runMode hasHeader = case runMode of + Add -> aAction hasHeader + Check -> cAction hasHeader + Drop -> dAction hasHeader + Replace -> rAction hasHeader + aAction hasHeader = + RunAction + (not hasHeader) + (addHeader info header) + (justify "Adding header to:") + (justify "Header already exists in:") + cAction hasHeader = + (rAction hasHeader) + { raProcessedMsg = justify "Outdated header found in:" + , raSkippedMsg = justify "Header up-to-date in:" + } + dAction hasHeader = + RunAction + hasHeader + (dropHeader info) + (justify "Dropping header from:") + (justify "No header exists in:") + rAction hasHeader = if hasHeader then rAction' else go Add hasHeader + rAction' = + RunAction + True + (replaceHeader info header) + (justify "Replacing header in:") + (justify "Header up-to-date in:") + justify = T.justifyLeft 30 ' ' -- | Loads templates using given template references. If multiple sources define -- template for the same 'FileType', then the preferred one (based on ordering -- of 'TemplateRef' is selected). -loadTemplateRefs :: forall a env - . ( Template a - , HasRIO Network env - , HasRIO FileSystem env - , HasLogFunc env - ) - => [TemplateRef] -- ^ template references - -> RIO env (Map FileType a) -- ^ map of templates +loadTemplateRefs :: + forall a env. + ( Template a + , HasRIO Network env + , HasRIO FileSystem env + , HasLogFunc env + ) => + -- | template references + [TemplateRef] -> + -- | map of templates + RIO env (Map FileType a) loadTemplateRefs refs = do - fileSystem <- viewL - network <- viewL - allRefs <- concat <$> mapM (getAllRefs fileSystem) refs - refsWTp <- (\rs -> [ (ft, ref) | (Just ft, ref) <- rs ]) <$> zipRs allRefs - refsWCtn <- mapM (loadContent fileSystem network) (filterPreferred refsWTp) - M.fromList <$> mapM loadTemplate refsWCtn - where - zipRs rs = fmap (`zip` rs) . mapM getFileType $ rs - exts = toList $ templateExtensions @a - getAllRefs fs ref = case ref of - LocalTemplateRef p -> fmap LocalTemplateRef <$> fsFindFilesByExts fs p exts - _ -> pure [ref] - loadContent fs n (ft, ref) = (ft, ref, ) <$> case ref of - InlineRef content -> pure content - LocalTemplateRef path -> fsLoadFile fs path - UriTemplateRef uri -> decodeUtf8Lenient <$> nDownloadContent n uri - BuiltInRef lt ft' -> pure $ licenseTemplate lt ft' - loadTemplate (ft, ref, T.strip -> c) = (ft, ) <$> parseTemplate @a ref c - getFileType = \case - InlineRef _ -> pure Nothing - BuiltInRef _ ft -> pure . Just $ ft - other -> typeOfTemplate . T.unpack . renderRef $ other - filterPreferred = - mapMaybe (L.headMaybe . L.sort) . L.groupBy (\x y -> fst x == fst y) - - -loadTemplates :: ( Has CtAppConfig env - , HasRIO Network env - , HasRIO FileSystem env - , HasLogFunc env - ) - => RIO env (Map FileType HeaderTemplate) + fileSystem <- viewL + network <- viewL + allRefs <- concat <$> mapM (getAllRefs fileSystem) refs + refsWTp <- (\rs -> [(ft, ref) | (Just ft, ref) <- rs]) <$> zipRs allRefs + refsWCtn <- mapM (loadContent fileSystem network) (filterPreferred refsWTp) + M.fromList <$> mapM loadTemplate refsWCtn + where + zipRs rs = fmap (`zip` rs) . mapM getFileType $ rs + exts = toList $ templateExtensions @a + getAllRefs fs ref = case ref of + LocalTemplateRef p -> fmap LocalTemplateRef <$> fsFindFilesByExts fs p exts + _ -> pure [ref] + loadContent fs n (ft, ref) = + (ft,ref,) <$> case ref of + InlineRef content -> pure content + LocalTemplateRef path -> fsLoadFile fs path + UriTemplateRef uri -> decodeUtf8Lenient <$> nDownloadContent n uri + BuiltInRef lt ft' -> pure $ licenseTemplate lt ft' + loadTemplate (ft, ref, T.strip -> c) = (ft,) <$> parseTemplate @a ref c + getFileType = \case + InlineRef _ -> pure Nothing + BuiltInRef _ ft -> pure . Just $ ft + other -> typeOfTemplate . T.unpack . renderRef $ other + filterPreferred = + mapMaybe (L.headMaybe . L.sort) . L.groupBy (\x y -> fst x == fst y) + +loadTemplates :: + ( Has CtAppConfig env + , HasRIO Network env + , HasRIO FileSystem env + , HasLogFunc env + ) => + RIO env (Map FileType HeaderTemplate) loadTemplates = do - AppConfig {..} <- viewL @CtAppConfig - let allRefs = builtInRefs acBuiltInTemplates <> acTemplateRefs - templates <- loadTemplateRefs @TemplateType allRefs - logInfo . display . stats . M.toList $ templates - pure $ M.mapWithKey (extractHeaderTemplate acLicenseHeaders) templates - where - stats = Table2 . fmap - (\(ft, t) -> ([i|Using #{ft} template:|], renderRef . templateRef $ t)) - builtInRefs = \case - Just lt -> fmap (BuiltInRef lt) $ allValues @FileType - _ -> [] - + AppConfig{..} <- viewL @CtAppConfig + let allRefs = builtInRefs acBuiltInTemplates <> acTemplateRefs + templates <- loadTemplateRefs @TemplateType allRefs + logInfo . display . stats . M.toList $ templates + pure $ M.mapWithKey (extractHeaderTemplate acLicenseHeaders) templates + where + stats = + Table2 + . fmap + (\(ft, t) -> ([i|Using #{ft} template:|], renderRef . templateRef $ t)) + builtInRefs = \case + Just lt -> fmap (BuiltInRef lt) $ allValues @FileType + _ -> [] -- | Takes path to the template file and returns detected type of the template. -typeOfTemplate :: HasLogFunc env - => FilePath -- ^ path to the template file - -> RIO env (Maybe FileType) -- ^ detected template type +typeOfTemplate :: + HasLogFunc env => + -- | path to the template file + FilePath -> + -- | detected template type + RIO env (Maybe FileType) typeOfTemplate path = do - let fileType = textToEnum . T.pack . takeBaseName $ path - when (isNothing fileType) - (logWarn $ "Skipping unrecognized template type: " <> fromString path) - pure fileType - - -loadConfigurationSafe :: (HasLogFunc env) - => FilePath - -> RIO env (Maybe PtAppConfig) + let fileType = textToEnum . T.pack . takeBaseName $ path + when + (isNothing fileType) + (logWarn $ "Skipping unrecognized template type: " <> fromString path) + pure fileType + +loadConfigurationSafe :: + (HasLogFunc env) => + FilePath -> + RIO env (Maybe PtAppConfig) loadConfigurationSafe path = catch (Just <$> loadAppConfig path) onError - where - onError err = do - logDebug $ displayShow (err :: IOException) - logInfo $ mconcat - [ "Configuration file '" - , fromString path - , "' not found. You can either specify all required parameter by " - , "command line arguments, or generate one using " - , "'headroom gen -c >" - , configFileName - , "'. See official documentation " - , "for more details." - ] - pure Nothing - - -finalConfiguration :: (HasLogFunc env, Has CommandRunOptions env) - => RIO env CtAppConfig + where + onError err = do + logDebug $ displayShow (err :: IOException) + logInfo $ + mconcat + [ "Configuration file '" + , fromString path + , "' not found. You can either specify all required parameter by " + , "command line arguments, or generate one using " + , "'headroom gen -c >" + , configFileName + , "'. See official documentation " + , "for more details." + ] + pure Nothing + +finalConfiguration :: + (HasLogFunc env, Has CommandRunOptions env) => + RIO env CtAppConfig finalConfiguration = do - defaultConfig' <- Just <$> parseAppConfig defaultConfig - cmdLineConfig <- Just <$> optionsToConfiguration - yamlConfig <- loadConfigurationSafe configFileName - let mergedConfig = - mconcat . catMaybes $ [defaultConfig', yamlConfig, cmdLineConfig] - config <- makeAppConfig mergedConfig - logDebug $ "Default config: " <> displayShow defaultConfig' - logDebug $ "YAML config: " <> displayShow yamlConfig - logDebug $ "CmdLine config: " <> displayShow cmdLineConfig - logDebug $ "Merged config: " <> displayShow mergedConfig - logDebug $ "Final config: " <> displayShow config - pure config - + defaultConfig' <- Just <$> parseAppConfig defaultConfig + cmdLineConfig <- Just <$> optionsToConfiguration + yamlConfig <- loadConfigurationSafe configFileName + let mergedConfig = + mconcat . catMaybes $ [defaultConfig', yamlConfig, cmdLineConfig] + config <- makeAppConfig mergedConfig + logDebug $ "Default config: " <> displayShow defaultConfig' + logDebug $ "YAML config: " <> displayShow yamlConfig + logDebug $ "CmdLine config: " <> displayShow cmdLineConfig + logDebug $ "Merged config: " <> displayShow mergedConfig + logDebug $ "Final config: " <> displayShow config + pure config optionsToConfiguration :: (Has CommandRunOptions env) => RIO env PtAppConfig optionsToConfiguration = do - CommandRunOptions {..} <- viewL - variables <- parseVariables croVariables - pure AppConfig - { acRunMode = maybe mempty pure croRunMode - , acSourcePaths = ifNot null croSourcePaths - , acExcludedPaths = ifNot null croExcludedPaths - , acExcludeIgnoredPaths = ifNot (== False) croExcludeIgnoredPaths - , acBuiltInTemplates = pure croBuiltInTemplates - , acTemplateRefs = croTemplateRefs - , acVariables = variables - , acLicenseHeaders = mempty - , acPostProcessConfigs = mempty - } - where ifNot cond value = if cond value then mempty else pure value - + CommandRunOptions{..} <- viewL + variables <- parseVariables croVariables + pure + AppConfig + { acRunMode = maybe mempty pure croRunMode + , acSourcePaths = ifNot null croSourcePaths + , acExcludedPaths = ifNot null croExcludedPaths + , acExcludeIgnoredPaths = ifNot (== False) croExcludeIgnoredPaths + , acBuiltInTemplates = pure croBuiltInTemplates + , acTemplateRefs = croTemplateRefs + , acVariables = variables + , acLicenseHeaders = mempty + , acPostProcessConfigs = mempty + } + where + ifNot cond value = if cond value then mempty else pure value currentYear :: (MonadIO m) => m CurrentYear currentYear = do - now <- liftIO getCurrentTime - timezone <- liftIO getCurrentTimeZone - let zoneNow = utcToLocalTime timezone now - (year, _, _) = toGregorian $ localDay zoneNow - pure $ CurrentYear year - + now <- liftIO getCurrentTime + timezone <- liftIO getCurrentTimeZone + let zoneNow = utcToLocalTime timezone now + (year, _, _) = toGregorian $ localDay zoneNow + pure $ CurrentYear year -- | Performs post-processing on rendered /license header/, based on given -- configuration. Currently the main points are to: -- -- 1. sanitize possibly corrupted comment syntax ('sanitizeSyntax') -- 2. apply /post-processors/ ('postProcessHeader') -postProcessHeader' :: forall a env - . ( Template a - , Has CtPostProcessConfigs env - , Has CurrentYear env - ) - => HeaderSyntax -- ^ syntax of the license header comments - -> Variables -- ^ template variables - -> Text -- ^ /license header/ to post-process - -> RIO env Text -- ^ post-processed /license header/ +postProcessHeader' :: + forall a env. + ( Template a + , Has CtPostProcessConfigs env + , Has CurrentYear env + ) => + -- | syntax of the license header comments + HeaderSyntax -> + -- | template variables + Variables -> + -- | /license header/ to post-process + Text -> + -- | post-processed /license header/ + RIO env Text postProcessHeader' syntax vars rawHeader = do - configs <- viewL @CtPostProcessConfigs - year <- viewL - cEnv <- mkConfiguredEnv @a year vars configs - pure . sanitizeSyntax syntax . postProcessHeader cEnv $ rawHeader + configs <- viewL @CtPostProcessConfigs + year <- viewL + cEnv <- mkConfiguredEnv @a year vars configs + pure . sanitizeSyntax syntax . postProcessHeader cEnv $ rawHeader diff --git a/src/Headroom/Command/Types.hs b/src/Headroom/Command/Types.hs index e60fc11..fc3e66a 100644 --- a/src/Headroom/Command/Types.hs +++ b/src/Headroom/Command/Types.hs @@ -1,67 +1,78 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StrictData #-} -{-| -Module : Headroom.Command.Types -Description : Data types for "Headroom.Command" -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types for "Headroom.Command" module. --} - -module Headroom.Command.Types - ( Command(..) - , CommandGenOptions(..) - , CommandInitOptions(..) - , CommandRunOptions(..) - ) -where - -import Headroom.Config.Types ( GenMode - , LicenseType - , RunMode - ) -import Headroom.Data.Regex ( Regex ) -import Headroom.FileType.Types ( FileType ) -import Headroom.Template.TemplateRef ( TemplateRef ) -import RIO +-- | +-- Module : Headroom.Command.Types +-- Description : Data types for "Headroom.Command" +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains data types for "Headroom.Command" module. +module Headroom.Command.Types ( + Command (..) + , CommandGenOptions (..) + , CommandInitOptions (..) + , CommandRunOptions (..) +) where +import Headroom.Config.Types ( + GenMode + , LicenseType + , RunMode + ) +import Headroom.Data.Regex (Regex) +import Headroom.FileType.Types (FileType) +import Headroom.Template.TemplateRef (TemplateRef) +import RIO -- | Application command. data Command - = Run [FilePath] [Regex] Bool (Maybe LicenseType) [TemplateRef] [Text] (Maybe RunMode) Bool Bool -- ^ @run@ command - | Gen Bool (Maybe (LicenseType, FileType)) -- ^ @gen@ command - | Init LicenseType [FilePath] -- ^ @init@ command - deriving (Show) - + = -- | @run@ command + Run [FilePath] [Regex] Bool (Maybe LicenseType) [TemplateRef] [Text] (Maybe RunMode) Bool Bool + | -- | @gen@ command + Gen Bool (Maybe (LicenseType, FileType)) + | -- | @init@ command + Init LicenseType [FilePath] + deriving (Show) -- | Options for the @gen@ command. newtype CommandGenOptions = CommandGenOptions - { cgoGenMode :: GenMode -- ^ selected mode - } - deriving (Show) + { cgoGenMode :: GenMode + -- ^ selected mode + } + deriving (Show) -- | Options for the @init@ command. data CommandInitOptions = CommandInitOptions - { cioSourcePaths :: [FilePath] -- ^ paths to source code files - , cioLicenseType :: LicenseType -- ^ license type - } - deriving Show + { cioSourcePaths :: [FilePath] + -- ^ paths to source code files + , cioLicenseType :: LicenseType + -- ^ license type + } + deriving (Show) -- | Options for the @run@ command. data CommandRunOptions = CommandRunOptions - { croRunMode :: Maybe RunMode -- ^ used /Run/ command mode - , croSourcePaths :: [FilePath] -- ^ source code file paths - , croExcludedPaths :: [Regex] -- ^ source paths to exclude - , croExcludeIgnoredPaths :: Bool -- ^ whether to exclude ignored paths - , croBuiltInTemplates :: Maybe LicenseType -- ^ whether to use built-in templates - , croTemplateRefs :: [TemplateRef] -- ^ template references - , croVariables :: [Text] -- ^ raw variables - , croDebug :: Bool -- ^ whether to run in debug mode - , croDryRun :: Bool -- ^ whether to perform dry run - } - deriving (Eq, Show) + { croRunMode :: Maybe RunMode + -- ^ used /Run/ command mode + , croSourcePaths :: [FilePath] + -- ^ source code file paths + , croExcludedPaths :: [Regex] + -- ^ source paths to exclude + , croExcludeIgnoredPaths :: Bool + -- ^ whether to exclude ignored paths + , croBuiltInTemplates :: Maybe LicenseType + -- ^ whether to use built-in templates + , croTemplateRefs :: [TemplateRef] + -- ^ template references + , croVariables :: [Text] + -- ^ raw variables + , croDebug :: Bool + -- ^ whether to run in debug mode + , croDryRun :: Bool + -- ^ whether to perform dry run + } + deriving (Eq, Show) diff --git a/src/Headroom/Command/Utils.hs b/src/Headroom/Command/Utils.hs index 5902fdf..b861074 100644 --- a/src/Headroom/Command/Utils.hs +++ b/src/Headroom/Command/Utils.hs @@ -1,38 +1,34 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Command.Utils -Description : Shared code for individual command handlers -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Contains shared code common to all command handlers. --} - -module Headroom.Command.Utils - ( bootstrap - ) -where - -import RIO +-- | +-- Module : Headroom.Command.Utils +-- Description : Shared code for individual command handlers +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Contains shared code common to all command handlers. +module Headroom.Command.Utils ( + bootstrap +) where +import RIO -- | Bootstraps /RIO/ application using provided environment data and flag -- whether to run in debug mode. -bootstrap :: (LogFunc -> IO env) - -- ^ function returning environment data - -> Bool - -- ^ whether to run in debug mode - -> RIO env a - -- ^ /RIO/ application to execute - -> IO a - -- ^ execution result +bootstrap :: + -- | function returning environment data + (LogFunc -> IO env) -> + -- | whether to run in debug mode + Bool -> + -- | /RIO/ application to execute + RIO env a -> + -- | execution result + IO a bootstrap enfFn isDebug logic = do - defLogOptions <- logOptionsHandle stderr isDebug - withLogFunc (setLogUseLoc False defLogOptions) $ \logFunc -> do - env <- liftIO $ enfFn logFunc - runRIO env logic - + defLogOptions <- logOptionsHandle stderr isDebug + withLogFunc (setLogUseLoc False defLogOptions) $ \logFunc -> do + env <- liftIO $ enfFn logFunc + runRIO env logic diff --git a/src/Headroom/Config.hs b/src/Headroom/Config.hs index 3b52ec9..4129dc8 100644 --- a/src/Headroom/Config.hs +++ b/src/Headroom/Config.hs @@ -1,185 +1,200 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Headroom.Config -Description : Configuration handling (loading, parsing, validating) -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides logic for working with the cofiguration data types. -Headroom uses the - -pattern for the configuration. --} - -module Headroom.Config - ( -- * Loading & Parsing Configuration - loadAppConfig - , parseAppConfig - -- * Processing Partial Configuration - , makeAppConfig - , makeHeadersConfig - , makeHeaderConfig - ) -where - -import Data.Monoid ( Last(..) ) -import qualified Data.Yaml as Y -import Headroom.Config.Compat ( checkCompatibility ) -import Headroom.Config.Types ( AppConfig(..) - , ConfigurationError(..) - , ConfigurationKey(..) - , CtAppConfig - , CtHeaderConfig - , CtHeadersConfig - , CtPostProcessConfig - , CtPostProcessConfigs - , CtUpdateCopyrightConfig - , HeaderConfig(..) - , HeadersConfig(..) - , Phase(..) - , PostProcessConfig(..) - , PostProcessConfigs(..) - , PtAppConfig - , PtHeaderConfig - , PtHeadersConfig - , PtPostProcessConfig - , PtPostProcessConfigs - , 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 +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.Config +-- Description : Configuration handling (loading, parsing, validating) +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides logic for working with the cofiguration data types. +-- Headroom uses the +-- +-- pattern for the configuration. +module Headroom.Config ( + -- * Loading & Parsing Configuration + loadAppConfig + , parseAppConfig + + -- * Processing Partial Configuration + , makeAppConfig + , makeHeadersConfig + , makeHeaderConfig +) where + +import Data.Monoid (Last (..)) +import qualified Data.Yaml as Y +import Headroom.Config.Compat (checkCompatibility) +import Headroom.Config.Types ( + AppConfig (..) + , ConfigurationError (..) + , ConfigurationKey (..) + , CtAppConfig + , CtHeaderConfig + , CtHeadersConfig + , CtPostProcessConfig + , CtPostProcessConfigs + , CtUpdateCopyrightConfig + , HeaderConfig (..) + , HeadersConfig (..) + , Phase (..) + , PostProcessConfig (..) + , PostProcessConfigs (..) + , PtAppConfig + , PtHeaderConfig + , PtHeadersConfig + , PtPostProcessConfig + , PtPostProcessConfigs + , 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 suffixLenses ''PostProcessConfig suffixLenses ''PostProcessConfigs suffixLenses ''UpdateCopyrightConfig - ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Loads and parses application configuration from given /YAML/ file. loadAppConfig :: (MonadIO m, MonadThrow m) => FilePath -> m PtAppConfig loadAppConfig path = do - content <- liftIO $ B.readFile path - _ <- checkCompatibility configBreakingChanges buildVersion content - parseAppConfig content - + content <- liftIO $ B.readFile path + _ <- checkCompatibility configBreakingChanges buildVersion content + parseAppConfig content -- | Parses application configuration from given raw input in /YAML/ format. -parseAppConfig :: MonadThrow m - => ByteString -- ^ raw input to parse - -> m PtAppConfig -- ^ parsed application configuration +parseAppConfig :: + MonadThrow m => + -- | raw input to parse + ByteString -> + -- | parsed application configuration + m PtAppConfig parseAppConfig = Y.decodeThrow - -- | Makes full 'CtAppConfig' from provided 'PtAppConfig' (if valid). -makeAppConfig :: MonadThrow m - => PtAppConfig -- ^ source 'PtAppConfig' - -> m CtAppConfig -- ^ full 'CtAppConfig' +makeAppConfig :: + MonadThrow m => + -- | source 'PtAppConfig' + PtAppConfig -> + -- | full 'CtAppConfig' + m CtAppConfig makeAppConfig pt = do - acRunMode <- lastOrError CkRunMode (acRunMode pt) - acSourcePaths <- lastOrError CkSourcePaths (acSourcePaths pt) - acExcludedPaths <- lastOrError CkExcludedPaths (acExcludedPaths pt) - acExcludeIgnoredPaths <- lastOrError CkExcludeIgnoredPaths - (acExcludeIgnoredPaths pt) - acBuiltInTemplates <- lastOrError CkBuiltInTemplates (acBuiltInTemplates pt) - acTemplateRefs <- pure $ acTemplateRefs pt - acLicenseHeaders <- makeHeadersConfig (acLicenseHeaders pt) - acPostProcessConfigs <- makePostProcessConfigs (acPostProcessConfigs pt) - acVariables <- pure $ acVariables pt - pure AppConfig { .. } - + acRunMode <- lastOrError CkRunMode (acRunMode pt) + acSourcePaths <- lastOrError CkSourcePaths (acSourcePaths pt) + acExcludedPaths <- lastOrError CkExcludedPaths (acExcludedPaths pt) + acExcludeIgnoredPaths <- + lastOrError + CkExcludeIgnoredPaths + (acExcludeIgnoredPaths pt) + acBuiltInTemplates <- lastOrError CkBuiltInTemplates (acBuiltInTemplates pt) + acTemplateRefs <- pure $ acTemplateRefs pt + acLicenseHeaders <- makeHeadersConfig (acLicenseHeaders pt) + acPostProcessConfigs <- makePostProcessConfigs (acPostProcessConfigs pt) + acVariables <- pure $ acVariables pt + pure AppConfig{..} -- | Makes full 'CtHeadersConfig' from provided 'PtHeadersConfig' (if valid). -makeHeadersConfig :: MonadThrow m - => PtHeadersConfig -- ^ source 'PtHeadersConfig' - -> m CtHeadersConfig -- ^ full 'CtHeadersConfig' +makeHeadersConfig :: + MonadThrow m => + -- | source 'PtHeadersConfig' + PtHeadersConfig -> + -- | full 'CtHeadersConfig' + m CtHeadersConfig makeHeadersConfig pt = do - hscC <- makeHeaderConfig C (hscC pt) - hscCpp <- makeHeaderConfig CPP (hscCpp pt) - hscCss <- makeHeaderConfig CSS (hscCss pt) - hscDart <- makeHeaderConfig Dart (hscDart pt) - hscGo <- makeHeaderConfig Go (hscGo pt) - hscHaskell <- makeHeaderConfig Haskell (hscHaskell pt) - hscHtml <- makeHeaderConfig HTML (hscHtml pt) - hscJava <- makeHeaderConfig Java (hscJava pt) - hscJs <- makeHeaderConfig JS (hscJs pt) - hscKotlin <- makeHeaderConfig Kotlin (hscKotlin pt) - hscPhp <- makeHeaderConfig PHP (hscPhp pt) - hscPureScript <- makeHeaderConfig PureScript (hscPureScript pt) - hscPython <- makeHeaderConfig Python (hscPython pt) - hscRust <- makeHeaderConfig Rust (hscRust pt) - hscScala <- makeHeaderConfig Scala (hscScala pt) - hscShell <- makeHeaderConfig Shell (hscShell pt) - pure HeadersConfig { .. } - + hscC <- makeHeaderConfig C (hscC pt) + hscCpp <- makeHeaderConfig CPP (hscCpp pt) + hscCss <- makeHeaderConfig CSS (hscCss pt) + hscDart <- makeHeaderConfig Dart (hscDart pt) + hscGo <- makeHeaderConfig Go (hscGo pt) + hscHaskell <- makeHeaderConfig Haskell (hscHaskell pt) + hscHtml <- makeHeaderConfig HTML (hscHtml pt) + hscJava <- makeHeaderConfig Java (hscJava pt) + hscJs <- makeHeaderConfig JS (hscJs pt) + hscKotlin <- makeHeaderConfig Kotlin (hscKotlin pt) + hscPhp <- makeHeaderConfig PHP (hscPhp pt) + hscPureScript <- makeHeaderConfig PureScript (hscPureScript pt) + hscPython <- makeHeaderConfig Python (hscPython pt) + hscRust <- makeHeaderConfig Rust (hscRust pt) + hscScala <- makeHeaderConfig Scala (hscScala pt) + hscShell <- makeHeaderConfig Shell (hscShell pt) + pure HeadersConfig{..} -- | Makes full 'CtHeaderConfig' from provided 'PtHeaderConfig' (if valid). -makeHeaderConfig :: MonadThrow m - => FileType -- ^ determines file type of configuration - -> PtHeaderConfig -- ^ source 'PtHeaderConfig' - -> m CtHeaderConfig -- ^ full 'CtHeaderConfig' +makeHeaderConfig :: + MonadThrow m => + -- | determines file type of configuration + FileType -> + -- | source 'PtHeaderConfig' + PtHeaderConfig -> + -- | full 'CtHeaderConfig' + m CtHeaderConfig makeHeaderConfig fileType pt = do - hcFileExtensions <- lastOrError (CkFileExtensions fileType) - (hcFileExtensions 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 { .. } - + hcFileExtensions <- + lastOrError + (CkFileExtensions fileType) + (hcFileExtensions 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 ----------------------------- -makePostProcessConfigs :: MonadThrow m - => PtPostProcessConfigs - -> m CtPostProcessConfigs +makePostProcessConfigs :: + MonadThrow m => + PtPostProcessConfigs -> + m CtPostProcessConfigs makePostProcessConfigs pt = do - ppcsUpdateCopyright <- makePostProcessConfig (pt ^. ppcsUpdateCopyrightL) - makeUpdateCopyrightConfig - pure PostProcessConfigs { .. } - - -makePostProcessConfig :: MonadThrow m - => PtPostProcessConfig c - -> (c 'Partial -> m (c 'Complete)) - -> m (CtPostProcessConfig c) + ppcsUpdateCopyright <- + makePostProcessConfig + (pt ^. ppcsUpdateCopyrightL) + makeUpdateCopyrightConfig + pure PostProcessConfigs{..} + +makePostProcessConfig :: + MonadThrow m => + PtPostProcessConfig c -> + (c 'Partial -> m (c 'Complete)) -> + m (CtPostProcessConfig c) makePostProcessConfig pt fn = do - ppcEnabled <- lastOrError CkEnabled (pt ^. ppcEnabledL) - ppcConfig <- fn $ pt ^. ppcConfigL - pure PostProcessConfig { .. } - - -makeUpdateCopyrightConfig :: MonadThrow m - => PtUpdateCopyrightConfig - -> m CtUpdateCopyrightConfig + ppcEnabled <- lastOrError CkEnabled (pt ^. ppcEnabledL) + ppcConfig <- fn $ pt ^. ppcConfigL + pure PostProcessConfig{..} + +makeUpdateCopyrightConfig :: + MonadThrow m => + PtUpdateCopyrightConfig -> + m CtUpdateCopyrightConfig makeUpdateCopyrightConfig pt = do - let uccSelectedAuthors = lastOrNothing $ pt ^. uccSelectedAuthorsL - pure UpdateCopyrightConfig { .. } - + let uccSelectedAuthors = lastOrNothing $ pt ^. uccSelectedAuthorsL + pure UpdateCopyrightConfig{..} lastOrError :: MonadThrow m => ConfigurationKey -> Last a -> m a lastOrError key (Last a) = maybe (throwM $ MissingConfiguration key) pure a - lastOrNothing :: Last (Maybe a) -> Maybe a lastOrNothing (Last a) = fromMaybe Nothing a diff --git a/src/Headroom/Config/Compat.hs b/src/Headroom/Config/Compat.hs index 988072d..170ce9b 100644 --- a/src/Headroom/Config/Compat.hs +++ b/src/Headroom/Config/Compat.hs @@ -1,120 +1,120 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Config.Compat -Description : Compatibility checks for YAML configuration -Copyright : (c) 2019-2022 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.Config.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 +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.Config.Compat +-- Description : Compatibility checks for YAML configuration +-- Copyright : (c) 2019-2022 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.Config.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 - + 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 YAML - | CannotParseYaml Y.ParseException -- ^ error parsing YAML file - | NewerVersionDetected Version -- ^ configuration has too new version - | UnsupportedVersion [Version] Version -- ^ given YAML configuration is not compatible - deriving (Show) - + = -- | cannot parse version info from YAML + CannotParseVersion + | -- | error parsing YAML file + CannotParseYaml Y.ParseException + | -- | configuration has too new version + NewerVersionDetected Version + | -- | given YAML configuration is not compatible + UnsupportedVersion [Version] Version + deriving (Show) instance Exception VersionError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + 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 :: + MonadThrow m => + -- | list of versions with breaking changes in configuration + [Version] -> + -- | current Headroom version + Version -> + -- | raw, not yet parsed YAML configuration + ByteString -> + -- | detected compatible version or error + m Version checkCompatibility breakingVersions current raw = do - VersionObj version <- parseObj - _ <- checkBreakingChanges breakingVersions version - _ <- checkNewerVersion current version - pure version - where - parseObj = either (throwM . handleEx) pure decoded - decoded = Y.decodeEither' raw - handleEx = \case - err@(Y.InvalidYaml _) -> CannotParseYaml err - _ -> CannotParseVersion - + VersionObj version <- parseObj + _ <- checkBreakingChanges breakingVersions version + _ <- checkNewerVersion current version + pure version + where + parseObj = either (throwM . handleEx) pure decoded + decoded = Y.decodeEither' raw + handleEx = \case + err@(Y.InvalidYaml _) -> CannotParseYaml err + _ -> CannotParseVersion ------------------------------ 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 - + [] -> pure () + newer -> throwM $ UnsupportedVersion newer v checkNewerVersion :: MonadThrow m => Version -> Version -> m () checkNewerVersion current checked = - if current < checked then throwM $ NewerVersionDetected checked else pure () - + if current < checked then throwM $ NewerVersionDetected checked else pure () displayException' :: VersionError -> String displayException' = \case - CannotParseVersion -> [iii| + 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 @@ -122,23 +122,26 @@ displayException' = \case for more details on how to proceed: #{"\n\t" <> webDocMigration v0400} |] - CannotParseYaml ex -> [iii| + CannotParseYaml ex -> + [iii| Cannot parse #{configFileName :: String} configuration file: #{"\n" <> Y.prettyPrintParseException ex} |] - NewerVersionDetected version -> [iii| + 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| + 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) + where + v0400 = [pvp|0.4.0.0|] + migrationGuides = mconcat . fmap (\v -> "\n\t- " <> webDocMigration v) diff --git a/src/Headroom/Config/Enrich.hs b/src/Headroom/Config/Enrich.hs index 2a40700..c6629fe 100644 --- a/src/Headroom/Config/Enrich.hs +++ b/src/Headroom/Config/Enrich.hs @@ -1,111 +1,104 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Config.Enrich -Description : Simple enrichment of YAML configuration stubs -Copyright : (c) 2019-2022 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.Config.Enrich - ( -- * Data Types - Enrich(..) - , ValueType(..) - -- * Field Generators - , withArray - , withText - -- * Field Manipulation - , replaceEmptyValue - ) -where - -import Data.Aeson ( ToJSON(..) ) -import Headroom.Data.Serialization ( prettyPrintYAML ) -import RIO -import qualified RIO.Map as M -import qualified RIO.Text as T -import qualified RIO.Text.Partial as TP +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.Config.Enrich +-- Description : Simple enrichment of YAML configuration stubs +-- Copyright : (c) 2019-2022 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.Config.Enrich ( + -- * Data Types + Enrich (..) + , ValueType (..) + + -- * Field Generators + , withArray + , withText + + -- * Field Manipulation + , replaceEmptyValue +) where + +import Data.Aeson (ToJSON (..)) +import Headroom.Data.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 - } - + { enrich :: Text -> Text + -- ^ takes input text and does enrichment + } instance Semigroup Enrich where - Enrich fnA <> Enrich fnB = Enrich $ fnA . fnB - + Enrich fnA <> Enrich fnB = Enrich $ fnA . fnB instance Monoid Enrich where - mempty = Enrich id - + mempty = Enrich id -- | Represents type of the field value. data ValueType - = Array - -- ^ type of /YAML/ array - | String - -- ^ type of /YAML/ string - deriving (Eq, Show) - + = -- | type of /YAML/ array + Array + | -- | type of /YAML/ string + 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 :: + ToJSON a => + -- | input list used as value + [a] -> + -- | field name + Text -> + -- | generated fields as @(valueType, generatedField)@ + (ValueType, Text) 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 :: + -- | input text value + Text -> + -- | field name + Text -> + -- | generated fields as @(valueType, generatedField)@ + (ValueType, Text) 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 name + Text -> + -- | field value generator function + (Text -> (ValueType, Text)) -> + -- | resulting enrichment step + Enrich replaceEmptyValue field replaceFn = Enrich $ \doc -> do - TP.replace old new doc - where - (tpe, new) = replaceFn field - old = field <> ": " <> emptyValue tpe - + 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 Array = "[]" emptyValue String = "\"\"" diff --git a/src/Headroom/Config/Global.hs b/src/Headroom/Config/Global.hs index 00056e0..99b6773 100644 --- a/src/Headroom/Config/Global.hs +++ b/src/Headroom/Config/Global.hs @@ -1,71 +1,72 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Config.Global -Description : Global configutation -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -/Global configuration/ is configuration shared between all /Headroom/ instances -and it's located in user's home directory. --} - -module Headroom.Config.Global - ( GlobalConfig(..) - , UpdaterConfig(..) - , initGlobalConfigIfNeeded - , loadGlobalConfig - , parseGlobalConfig - , globalConfigPath - ) -where - -import Data.Aeson ( FromJSON(..) - , genericParseJSON - ) -import qualified Data.Yaml as Y -import Headroom.Data.Has ( Has(..) - , HasRIO - ) -import Headroom.Data.Serialization ( aesonOptions ) -import Headroom.Embedded ( defaultGlobalConfig ) -import Headroom.IO.FileSystem ( FileSystem(..) ) -import Headroom.Meta ( globalConfigDirName - , globalConfigFileName - ) -import RIO -import qualified RIO.ByteString as B -import RIO.FilePath ( () ) +-- | +-- Module : Headroom.Config.Global +-- Description : Global configutation +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- /Global configuration/ is configuration shared between all /Headroom/ instances +-- and it's located in user's home directory. +module Headroom.Config.Global ( + GlobalConfig (..) + , UpdaterConfig (..) + , initGlobalConfigIfNeeded + , loadGlobalConfig + , parseGlobalConfig + , globalConfigPath +) where + +import Data.Aeson ( + FromJSON (..) + , genericParseJSON + ) +import qualified Data.Yaml as Y +import Headroom.Data.Has ( + Has (..) + , HasRIO + ) +import Headroom.Data.Serialization (aesonOptions) +import Headroom.Embedded (defaultGlobalConfig) +import Headroom.IO.FileSystem (FileSystem (..)) +import Headroom.Meta ( + globalConfigDirName + , globalConfigFileName + ) +import RIO +import qualified RIO.ByteString as B +import RIO.FilePath (()) --------------------------------- DATA TYPES --------------------------------- -- | Data type representing updater configuration. data UpdaterConfig = UpdaterConfig - { ucCheckForUpdates :: Bool -- ^ whether to check for updates - , ucUpdateIntervalDays :: Integer -- ^ how ofter check for updates - } - deriving (Eq, Generic, Show) + { ucCheckForUpdates :: Bool + -- ^ whether to check for updates + , ucUpdateIntervalDays :: Integer + -- ^ how ofter check for updates + } + deriving (Eq, Generic, Show) instance FromJSON UpdaterConfig where - parseJSON = genericParseJSON aesonOptions + parseJSON = genericParseJSON aesonOptions -- | Data type representing global configuration options. data GlobalConfig = GlobalConfig - { gcUpdates :: UpdaterConfig -- ^ config for updater - } - deriving (Eq, Generic, Show) + { gcUpdates :: UpdaterConfig + -- ^ config for updater + } + deriving (Eq, Generic, Show) instance FromJSON GlobalConfig where - parseJSON = genericParseJSON aesonOptions - + parseJSON = genericParseJSON aesonOptions ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -73,30 +74,27 @@ instance FromJSON GlobalConfig where -- it creates one with default values. initGlobalConfigIfNeeded :: (HasRIO FileSystem env) => RIO env () initGlobalConfigIfNeeded = do - FileSystem {..} <- viewL - userDir <- fsGetUserDirectory - configPath <- globalConfigPath - whenM (not <$> fsDoesFileExist configPath) $ do - fsCreateDirectory $ userDir globalConfigDirName - fsWriteFile configPath defaultGlobalConfig - + FileSystem{..} <- viewL + userDir <- fsGetUserDirectory + configPath <- globalConfigPath + whenM (not <$> fsDoesFileExist configPath) $ do + fsCreateDirectory $ userDir globalConfigDirName + fsWriteFile configPath defaultGlobalConfig -- | Loads global configuration from /YAML/ file. loadGlobalConfig :: (HasRIO FileSystem env) => RIO env GlobalConfig loadGlobalConfig = do - configPath <- globalConfigPath - content <- liftIO . B.readFile $ configPath - Y.decodeThrow content - + configPath <- globalConfigPath + content <- liftIO . B.readFile $ configPath + Y.decodeThrow content -- | Parses global configuration /YAML/ file. parseGlobalConfig :: (MonadThrow m) => ByteString -> m GlobalConfig parseGlobalConfig = Y.decodeThrow - -- | Path to global configuration /YAML/ file in user's directory. globalConfigPath :: HasRIO FileSystem env => RIO env FilePath globalConfigPath = do - FileSystem {..} <- viewL - userDir <- fsGetUserDirectory - pure $ userDir globalConfigDirName globalConfigFileName + FileSystem{..} <- viewL + userDir <- fsGetUserDirectory + pure $ userDir globalConfigDirName globalConfigFileName diff --git a/src/Headroom/Config/Types.hs b/src/Headroom/Config/Types.hs index f15e221..e455988 100644 --- a/src/Headroom/Config/Types.hs +++ b/src/Headroom/Config/Types.hs @@ -1,198 +1,197 @@ -{-# 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 #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - -{-| -Module : Headroom.Config.Types -Description : Data types for /Headroom/ configuration -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types representing /Headroom/ configuration options. -Related logic is available in "Headroom.Configuration" module. - -Data types related to /Headroom/ configuration uses the - -pattern, but instead of defining separate data type for each /phase/ -(/partial/ or /complete/ configuration), the /phase/ is expressed by the 'Phase' -data type and related /closed type family/. --} - -module Headroom.Config.Types - ( -- * Error Types - ConfigurationError(..) - , ConfigurationKey(..) - -- * Type Families - , Phase(..) - , (:::) - -- * Data Types - -- ** Top Level Configuration - , AppConfig(..) - , CtAppConfig - , PtAppConfig - , HeadersConfig(..) - , CtHeadersConfig - , PtHeadersConfig - , HeaderConfig(..) - , CtHeaderConfig - , PtHeaderConfig - -- ** Header Functions - , CtUpdateCopyrightConfig - , PtUpdateCopyrightConfig - , UpdateCopyrightConfig(..) - , CtPostProcessConfig - , PtPostProcessConfig - , PostProcessConfig(..) - , CtPostProcessConfigs - , PtPostProcessConfigs - , PostProcessConfigs(..) - -- ** Additional Data Types - , HeaderSyntax(..) - , GenMode(..) - , LicenseType(..) - , RunMode(..) - ) -where - -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.Regex ( Regex(..) ) -import Headroom.Data.Serialization ( aesonOptions ) -import Headroom.FileType.Types ( FileType ) -import Headroom.Meta ( webDocConfigCurr ) -import Headroom.Template.TemplateRef ( TemplateRef ) -import Headroom.Types ( LicenseType(..) - , fromHeadroomError - , toHeadroomError - ) -import Headroom.Variables.Types ( Variables(..) ) -import RIO -import qualified RIO.Text as T - +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Config.Types +-- Description : Data types for /Headroom/ configuration +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains data types representing /Headroom/ configuration options. +-- Related logic is available in "Headroom.Configuration" module. +-- +-- Data types related to /Headroom/ configuration uses the +-- +-- pattern, but instead of defining separate data type for each /phase/ +-- (/partial/ or /complete/ configuration), the /phase/ is expressed by the 'Phase' +-- data type and related /closed type family/. +module Headroom.Config.Types ( + -- * Error Types + ConfigurationError (..) + , ConfigurationKey (..) + + -- * Type Families + , Phase (..) + , (:::) + + -- * Data Types + + -- ** Top Level Configuration + , AppConfig (..) + , CtAppConfig + , PtAppConfig + , HeadersConfig (..) + , CtHeadersConfig + , PtHeadersConfig + , HeaderConfig (..) + , CtHeaderConfig + , PtHeaderConfig + + -- ** Header Functions + , CtUpdateCopyrightConfig + , PtUpdateCopyrightConfig + , UpdateCopyrightConfig (..) + , CtPostProcessConfig + , PtPostProcessConfig + , PostProcessConfig (..) + , CtPostProcessConfigs + , PtPostProcessConfigs + , PostProcessConfigs (..) + + -- ** Additional Data Types + , HeaderSyntax (..) + , GenMode (..) + , LicenseType (..) + , RunMode (..) +) where + +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.Regex (Regex (..)) +import Headroom.Data.Serialization (aesonOptions) +import Headroom.FileType.Types (FileType) +import Headroom.Meta (webDocConfigCurr) +import Headroom.Template.TemplateRef (TemplateRef) +import Headroom.Types ( + LicenseType (..) + , fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types (Variables (..)) +import RIO +import qualified RIO.Text as T ------------------------------------ Phase ----------------------------------- -- | Data type representing state of given configuration data type. data Phase - = Partial - -- ^ partial configuration, could be combined with another or validated to - -- produce the complete configuration - | Complete - -- ^ complete configuration, result of combining and validation of partial - -- configuration - + = -- | partial configuration, could be combined with another or validated to + -- produce the complete configuration + Partial + | -- | complete configuration, result of combining and validation of partial + -- configuration + Complete -- | /Closed type family/ used to express the phase of given data type. type family (p :: Phase) ::: a where - 'Partial ::: a = Last a - 'Complete ::: a = a - + 'Partial ::: a = Last a + 'Complete ::: a = a -------------------------------- HeaderSyntax -------------------------------- -- | Syntax of the license header comment. data HeaderSyntax - = BlockComment Regex Regex (Maybe Text) - -- ^ block (multi-line) comment syntax (e.g. @/* */@) - | LineComment Regex (Maybe Text) - -- ^ single line comment syntax (e.g. @//@) - deriving (Eq, Show) + = -- | block (multi-line) comment syntax (e.g. @/* */@) + BlockComment Regex Regex (Maybe Text) + | -- | single line comment syntax (e.g. @//@) + LineComment Regex (Maybe Text) + deriving (Eq, Show) -- | Internal representation of the block style of 'HeaderSyntax'. data BlockComment' = BlockComment' - { bcStartsWith :: Regex - -- ^ starting pattern (e.g. @/*@) - , bcEndsWith :: Regex - -- ^ ending pattern (e.g. @*/@) - } - deriving (Eq, Generic, Show) + { bcStartsWith :: Regex + -- ^ starting pattern (e.g. @/*@) + , bcEndsWith :: Regex + -- ^ ending pattern (e.g. @*/@) + } + deriving (Eq, Generic, Show) instance FromJSON BlockComment' where - parseJSON = genericParseJSON aesonOptions + parseJSON = genericParseJSON aesonOptions -- | Internal representation of the line style of 'HeaderSyntax'. newtype LineComment' = LineComment' - { lcPrefixedBy :: Regex - -- ^ prefix of the comment line (e.g. @//@) - } - deriving (Eq, Generic, Show) + { lcPrefixedBy :: Regex + -- ^ prefix of the comment line (e.g. @//@) + } + deriving (Eq, Generic, Show) instance FromJSON LineComment' where - parseJSON = genericParseJSON aesonOptions - + parseJSON = genericParseJSON aesonOptions ----------------------------------- RunMode ---------------------------------- -- | Represents what action should the @run@ command perform. data RunMode - = Add - -- ^ /add mode/ for @run@ command - | Check - -- ^ /check mode/ for @run@ command - | Drop - -- ^ /drop mode/ for @run@ command - | Replace - -- ^ /replace mode/ for @run@ command - deriving (Eq, Show) + = -- | /add mode/ for @run@ command + Add + | -- | /check mode/ for @run@ command + Check + | -- | /drop mode/ for @run@ command + Drop + | -- | /replace mode/ for @run@ command + Replace + deriving (Eq, Show) instance FromJSON RunMode where - parseJSON = \case - String s -> case T.toLower s of - "add" -> pure Add - "check" -> pure Check - "drop" -> pure Drop - "replace" -> pure Replace - _ -> error $ "Unknown run mode: " <> T.unpack s - other -> error $ "Invalid value for run mode: " <> show other - + parseJSON = \case + String s -> case T.toLower s of + "add" -> pure Add + "check" -> pure Check + "drop" -> pure Drop + "replace" -> pure Replace + _ -> error $ "Unknown run mode: " <> T.unpack s + other -> error $ "Invalid value for run mode: " <> show other ----------------------------------- GenMode ---------------------------------- -- | Represents what action should the @gen@ command perform. data GenMode - = GenConfigFile - -- ^ generate /YAML/ config file stub - | GenLicense (LicenseType, FileType) - -- ^ generate license header template - deriving (Eq, Show) - + = -- | generate /YAML/ config file stub + GenConfigFile + | -- | generate license header template + GenLicense (LicenseType, FileType) + deriving (Eq, Show) ---------------------------- UpdateCopyrightConfig --------------------------- -- | Main configuration for the "Headroom.PostProcess.UpdateCopyright" -- /post-processor/. data UpdateCopyrightConfig (p :: Phase) = UpdateCopyrightConfig - { uccSelectedAuthors :: p ::: Maybe (NonEmpty Text) - -- ^ if specified, years will be updated only in copyright statements of - -- given authors - } + { uccSelectedAuthors :: p ::: Maybe (NonEmpty Text) + -- ^ if specified, years will be updated only in copyright statements of + -- given authors + } -- | Alias for complete variant of 'UpdateCopyrightConfig'. type CtUpdateCopyrightConfig = UpdateCopyrightConfig 'Complete @@ -206,23 +205,29 @@ 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 +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 { .. } + parseJSON = withObject "PtUpdateCopyrightConfig" $ \obj -> do + uccSelectedAuthors <- Last <$> obj .:? "selected-authors-only" + pure UpdateCopyrightConfig{..} ------------------------------- PostProcessConfig ------------------------------- -- | Configuration for selected /post-processor/. data PostProcessConfig (p :: Phase) c = PostProcessConfig - { ppcEnabled :: p ::: Bool -- ^ whether this function is enabled or not - , ppcConfig :: c p -- ^ custom configuration of the /post-processor/ - } + { ppcEnabled :: p ::: Bool + -- ^ whether this function is enabled or not + , ppcConfig :: c p + -- ^ custom configuration of the /post-processor/ + } -- | Alias for complete variant of 'PostProcessConfig'. type CtPostProcessConfig c = PostProcessConfig 'Complete c @@ -230,32 +235,34 @@ type CtPostProcessConfig c = PostProcessConfig 'Complete c -- | Alias for partial variant of 'PostProcessConfig'. type PtPostProcessConfig c = PostProcessConfig 'Partial c - deriving instance (Eq (c 'Complete)) => Eq (CtPostProcessConfig c) deriving instance (Eq (c 'Partial)) => Eq (PtPostProcessConfig c) deriving instance (Show (c 'Complete)) => Show (CtPostProcessConfig c) deriving instance (Show (c 'Partial)) => Show (PtPostProcessConfig c) deriving instance Generic (PtPostProcessConfig c) -deriving via (Generically (PtPostProcessConfig c)) - instance Semigroup (c 'Partial) => Semigroup (PtPostProcessConfig c) -deriving via (Generically (PtPostProcessConfig c)) - instance Monoid (c 'Partial) => Monoid (PtPostProcessConfig c) +deriving via + (Generically (PtPostProcessConfig c)) + instance + Semigroup (c 'Partial) => Semigroup (PtPostProcessConfig c) +deriving via + (Generically (PtPostProcessConfig c)) + instance + Monoid (c 'Partial) => Monoid (PtPostProcessConfig c) instance (FromJSON (c 'Partial), Monoid (c 'Partial)) => FromJSON (PtPostProcessConfig c) where - parseJSON = withObject "PtPostProcessConfig" $ \obj -> do - ppcEnabled <- Last <$> obj .:? "enabled" - ppcConfig <- obj .:? "config" .!= mempty - pure PostProcessConfig { .. } - + parseJSON = withObject "PtPostProcessConfig" $ \obj -> do + ppcEnabled <- Last <$> obj .:? "enabled" + ppcConfig <- obj .:? "config" .!= mempty + pure PostProcessConfig{..} ------------------------------- PostProcessConfigs ------------------------------ -- | Configuration of all known /post-processors/. data PostProcessConfigs (p :: Phase) = PostProcessConfigs - { ppcsUpdateCopyright :: PostProcessConfig p UpdateCopyrightConfig - -- ^ configuration for the "Headroom.PostProcess.UpdateCopyright" - } + { ppcsUpdateCopyright :: PostProcessConfig p UpdateCopyrightConfig + -- ^ configuration for the "Headroom.PostProcess.UpdateCopyright" + } -- | Alias for complete variant of 'PostProcessConfigs'. type CtPostProcessConfigs = PostProcessConfigs 'Complete @@ -269,40 +276,43 @@ deriving instance Show CtPostProcessConfigs deriving instance Show PtPostProcessConfigs deriving instance Generic PtPostProcessConfigs -deriving via (Generically PtPostProcessConfigs) - instance Semigroup PtPostProcessConfigs -deriving via (Generically PtPostProcessConfigs) - instance Monoid PtPostProcessConfigs +deriving via + (Generically PtPostProcessConfigs) + instance + Semigroup PtPostProcessConfigs +deriving via + (Generically PtPostProcessConfigs) + instance + Monoid PtPostProcessConfigs instance FromJSON PtPostProcessConfigs where - parseJSON = withObject "PtPostProcessConfigs" $ \obj -> do - ppcsUpdateCopyright <- obj .:? "update-copyright" .!= mempty - pure PostProcessConfigs { .. } - + parseJSON = withObject "PtPostProcessConfigs" $ \obj -> do + ppcsUpdateCopyright <- obj .:? "update-copyright" .!= mempty + pure PostProcessConfigs{..} -------------------------------- Configuration ------------------------------- -- | Application configuration. data AppConfig (p :: Phase) = AppConfig - { acRunMode :: p ::: RunMode - -- ^ mode of the @run@ command - , acSourcePaths :: p ::: [FilePath] - -- ^ paths to source code files - , acExcludedPaths :: p ::: [Regex] - -- ^ excluded source paths - , acExcludeIgnoredPaths :: p ::: Bool - -- ^ whether to exclude paths ignored by VCS - , acBuiltInTemplates :: p ::: Maybe LicenseType - -- ^ used built-in templates - , acTemplateRefs :: [TemplateRef] - -- ^ template references - , acVariables :: Variables - -- ^ variable values for templates - , acLicenseHeaders :: HeadersConfig p - -- ^ configuration of license headers - , acPostProcessConfigs :: PostProcessConfigs p - -- ^ configuration of post-processors - } + { acRunMode :: p ::: RunMode + -- ^ mode of the @run@ command + , acSourcePaths :: p ::: [FilePath] + -- ^ paths to source code files + , acExcludedPaths :: p ::: [Regex] + -- ^ excluded source paths + , acExcludeIgnoredPaths :: p ::: Bool + -- ^ whether to exclude paths ignored by VCS + , acBuiltInTemplates :: p ::: Maybe LicenseType + -- ^ used built-in templates + , acTemplateRefs :: [TemplateRef] + -- ^ template references + , acVariables :: Variables + -- ^ variable values for templates + , acLicenseHeaders :: HeadersConfig p + -- ^ configuration of license headers + , acPostProcessConfigs :: PostProcessConfigs p + -- ^ configuration of post-processors + } -- | Alias for complete variant of 'AppConfig'. type CtAppConfig = AppConfig 'Complete @@ -316,47 +326,49 @@ deriving instance Show CtAppConfig deriving instance Show PtAppConfig deriving instance Generic PtAppConfig -deriving via (Generically PtAppConfig) - instance Semigroup PtAppConfig -deriving via (Generically PtAppConfig) - instance Monoid PtAppConfig - +deriving via + (Generically PtAppConfig) + instance + Semigroup PtAppConfig +deriving via + (Generically PtAppConfig) + instance + Monoid PtAppConfig instance FromJSON PtAppConfig where - parseJSON = withObject "PtAppConfig" $ \obj -> do - acRunMode <- Last <$> obj .:? "run-mode" - acSourcePaths <- Last <$> obj .:? "source-paths" - acExcludedPaths <- Last <$> obj .:? "excluded-paths" - acExcludeIgnoredPaths <- Last <$> obj .:? "exclude-ignored-paths" - acBuiltInTemplates <- Last <$> obj .:? "builtin-templates" - acTemplateRefs <- obj .:? "template-paths" .!= mempty - acVariables <- Variables <$> obj .:? "variables" .!= mempty - acLicenseHeaders <- obj .:? "license-headers" .!= mempty - acPostProcessConfigs <- obj .:? "post-process" .!= mempty - pure AppConfig { .. } - + parseJSON = withObject "PtAppConfig" $ \obj -> do + acRunMode <- Last <$> obj .:? "run-mode" + acSourcePaths <- Last <$> obj .:? "source-paths" + acExcludedPaths <- Last <$> obj .:? "excluded-paths" + acExcludeIgnoredPaths <- Last <$> obj .:? "exclude-ignored-paths" + acBuiltInTemplates <- Last <$> obj .:? "builtin-templates" + acTemplateRefs <- obj .:? "template-paths" .!= mempty + acVariables <- Variables <$> obj .:? "variables" .!= mempty + acLicenseHeaders <- obj .:? "license-headers" .!= mempty + acPostProcessConfigs <- obj .:? "post-process" .!= mempty + pure AppConfig{..} -------------------------------- HeaderConfig -------------------------------- -- | Configuration for specific license header. data HeaderConfig (p :: Phase) = HeaderConfig - { hcFileExtensions :: p ::: [Text] - -- ^ list of file extensions (without dot) - , 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] - -- ^ /regexp/ patterns before which to put the header - , hcHeaderSyntax :: p ::: HeaderSyntax - -- ^ syntax of the license header comment - } + { hcFileExtensions :: p ::: [Text] + -- ^ list of file extensions (without dot) + , 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] + -- ^ /regexp/ patterns before which to put the header + , hcHeaderSyntax :: p ::: HeaderSyntax + -- ^ syntax of the license header comment + } -- | Alias for complete variant of 'HeaderConfig'. type CtHeaderConfig = HeaderConfig 'Complete @@ -370,51 +382,71 @@ 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 +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" - 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 - 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 + parseJSON = withObject "PartialHeaderConfig" $ \obj -> do + 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 + 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 ------------------------------- -- | Group of 'HeaderConfig' configurations for supported file types. data HeadersConfig (p :: Phase) = HeadersConfig - { hscC :: HeaderConfig p -- ^ configuration for /C/ - , hscCpp :: HeaderConfig p -- ^ configuration for /C++/ - , hscCss :: HeaderConfig p -- ^ configuration for /CSS/ - , hscDart :: HeaderConfig p -- ^ configuration for /Dart/ - , hscGo :: HeaderConfig p -- ^ configuration for /Go/ - , hscHaskell :: HeaderConfig p -- ^ configuration for /Haskell/ - , hscHtml :: HeaderConfig p -- ^ configuration for /HTML/ - , hscJava :: HeaderConfig p -- ^ configuration for /Java/ - , hscJs :: HeaderConfig p -- ^ configuration for /JavaScript/ - , hscKotlin :: HeaderConfig p -- ^ configuration for /Kotlin/ - , hscPhp :: HeaderConfig p -- ^ configuration for /PHP/ - , hscPureScript :: HeaderConfig p -- ^ configuration for /PureScript/ - , hscPython :: HeaderConfig p -- ^ configuration for /Python/ - , hscRust :: HeaderConfig p -- ^ configuration for /Rust/ - , hscScala :: HeaderConfig p -- ^ configuration for /Scala/ - , hscShell :: HeaderConfig p -- ^ configuration for /Shell/ - } + { hscC :: HeaderConfig p + -- ^ configuration for /C/ + , hscCpp :: HeaderConfig p + -- ^ configuration for /C++/ + , hscCss :: HeaderConfig p + -- ^ configuration for /CSS/ + , hscDart :: HeaderConfig p + -- ^ configuration for /Dart/ + , hscGo :: HeaderConfig p + -- ^ configuration for /Go/ + , hscHaskell :: HeaderConfig p + -- ^ configuration for /Haskell/ + , hscHtml :: HeaderConfig p + -- ^ configuration for /HTML/ + , hscJava :: HeaderConfig p + -- ^ configuration for /Java/ + , hscJs :: HeaderConfig p + -- ^ configuration for /JavaScript/ + , hscKotlin :: HeaderConfig p + -- ^ configuration for /Kotlin/ + , hscPhp :: HeaderConfig p + -- ^ configuration for /PHP/ + , hscPureScript :: HeaderConfig p + -- ^ configuration for /PureScript/ + , hscPython :: HeaderConfig p + -- ^ configuration for /Python/ + , hscRust :: HeaderConfig p + -- ^ configuration for /Rust/ + , hscScala :: HeaderConfig p + -- ^ configuration for /Scala/ + , hscShell :: HeaderConfig p + -- ^ configuration for /Shell/ + } -- | Alias for complete variant of 'HeadersConfig'. type CtHeadersConfig = HeadersConfig 'Complete @@ -428,154 +460,173 @@ 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 +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 - hscCpp <- obj .:? "cpp" .!= mempty - hscCss <- obj .:? "css" .!= mempty - hscDart <- obj .:? "dart" .!= mempty - hscGo <- obj .:? "go" .!= mempty - hscHaskell <- obj .:? "haskell" .!= mempty - hscHtml <- obj .:? "html" .!= mempty - hscJava <- obj .:? "java" .!= mempty - hscJs <- obj .:? "js" .!= mempty - hscKotlin <- obj .:? "kotlin" .!= mempty - hscPhp <- obj .:? "php" .!= mempty - hscPureScript <- obj .:? "purescript" .!= mempty - hscPython <- obj .:? "python" .!= mempty - hscRust <- obj .:? "rust" .!= mempty - hscScala <- obj .:? "scala" .!= mempty - hscShell <- obj .:? "shell" .!= mempty - pure HeadersConfig { .. } - + parseJSON = withObject "PartialHeadersConfig" $ \obj -> do + hscC <- obj .:? "c" .!= mempty + hscCpp <- obj .:? "cpp" .!= mempty + hscCss <- obj .:? "css" .!= mempty + hscDart <- obj .:? "dart" .!= mempty + hscGo <- obj .:? "go" .!= mempty + hscHaskell <- obj .:? "haskell" .!= mempty + hscHtml <- obj .:? "html" .!= mempty + hscJava <- obj .:? "java" .!= mempty + hscJs <- obj .:? "js" .!= mempty + hscKotlin <- obj .:? "kotlin" .!= mempty + hscPhp <- obj .:? "php" .!= mempty + hscPureScript <- obj .:? "purescript" .!= mempty + hscPython <- obj .:? "python" .!= mempty + hscRust <- obj .:? "rust" .!= mempty + hscScala <- obj .:? "scala" .!= mempty + hscShell <- obj .:? "shell" .!= mempty + pure HeadersConfig{..} --------------------------------- Error Types -------------------------------- -- | Represents single key in the configuration. data ConfigurationKey - = CkFileExtensions FileType - -- ^ no configuration for @file-extensions@ - | CkHeaderSyntax FileType - -- ^ no configuration for header syntax - | 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 - -- ^ no configuration for @put-before@ - | CkRunMode - -- ^ no configuration for @run-mode@ - | CkSourcePaths - -- ^ no configuration for @source-paths@ - | CkExcludedPaths - -- ^ no configuration for @excluded-paths@ - | CkExcludeIgnoredPaths - -- ^ no configuration for @exclude-ignored-paths@ - | CkBuiltInTemplates - -- ^ no configuration for built in templates - | CkVariables - -- ^ no configuration for @variables@ - | CkEnabled - -- ^ no configuration for @enabled@ - deriving (Eq, Show) - + = -- | no configuration for @file-extensions@ + CkFileExtensions FileType + | -- | no configuration for header syntax + CkHeaderSyntax FileType + | -- | no configuration for margin between header top and preceding code + CkMarginTopCode FileType + | -- | no configuration for margin between header top and start of file + CkMarginTopFile FileType + | -- | no configuration for margin between header bottom and following code + CkMarginBottomCode FileType + | -- | no configuration for margin between header bottom and end of file + CkMarginBottomFile FileType + | -- | no configuration for @put-after@ + CkPutAfter FileType + | -- | no configuration for @put-before@ + CkPutBefore FileType + | -- | no configuration for @run-mode@ + CkRunMode + | -- | no configuration for @source-paths@ + CkSourcePaths + | -- | no configuration for @excluded-paths@ + CkExcludedPaths + | -- | no configuration for @exclude-ignored-paths@ + CkExcludeIgnoredPaths + | -- | no configuration for built in templates + CkBuiltInTemplates + | -- | no configuration for @variables@ + CkVariables + | -- | no configuration for @enabled@ + CkEnabled + deriving (Eq, Show) -- | Exception specific to the "Headroom.Configuration" module. data ConfigurationError - = MissingConfiguration ConfigurationKey - -- ^ some of the required configuration keys has not been specified - | MixedHeaderSyntax - -- ^ illegal configuration for 'HeaderSyntax' - deriving (Eq, Show, Typeable) + = -- | some of the required configuration keys has not been specified + MissingConfiguration ConfigurationKey + | -- | illegal configuration for 'HeaderSyntax' + MixedHeaderSyntax + deriving (Eq, Show, Typeable) instance Exception ConfigurationError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: ConfigurationError -> String -displayException' = T.unpack . \case - MissingConfiguration key -> case key of - CkFileExtensions fileType -> missingConfig - (withFT "file-extensions" fileType) - (Just "file-extensions") - Nothing - CkHeaderSyntax fileType -> missingConfig - (withFT "comment-syntax" fileType) - (Just "block-comment|line-comment") - Nothing - 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 -> - missingConfig (withFT "put-before" fileType) (Just "put-before") Nothing - CkRunMode -> missingConfig - "mode of the run command" - (Just "run-mode") - (Just - "(-a|--add-headers)|(-c|--check-header)|(-d|--drop-header)|(-r|--replace-headers)" - ) - CkSourcePaths -> missingConfig "paths to source code files" - (Just "source-paths") - (Just "-s|--source-path") - CkExcludedPaths -> missingConfig "excluded paths" - (Just "excluded-paths") - (Just "-e|--excluded-path") - CkExcludeIgnoredPaths -> missingConfig "whether to exclude ignored paths" - (Just "exclude-ignored-paths") - (Just "--exclude-ignored-paths") - CkBuiltInTemplates -> missingConfig - "use of built-in templates" - (Just "builtin-templates") - (Just "(-t|--template-path)|--builtin-templates") - CkVariables -> missingConfig "template variables" - (Just "variables") - (Just "-v|--variable") - CkEnabled -> missingConfig "enabled" (Just "enabled") Nothing - MixedHeaderSyntax -> mixedHeaderSyntax - where - withFT msg fileType = [i|#{msg :: Text} (#{fileType})|] - mixedHeaderSyntax = [iii| +displayException' = + T.unpack . \case + MissingConfiguration key -> case key of + CkFileExtensions fileType -> + missingConfig + (withFT "file-extensions" fileType) + (Just "file-extensions") + Nothing + CkHeaderSyntax fileType -> + missingConfig + (withFT "comment-syntax" fileType) + (Just "block-comment|line-comment") + Nothing + 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 -> + missingConfig (withFT "put-before" fileType) (Just "put-before") Nothing + CkRunMode -> + missingConfig + "mode of the run command" + (Just "run-mode") + ( Just + "(-a|--add-headers)|(-c|--check-header)|(-d|--drop-header)|(-r|--replace-headers)" + ) + CkSourcePaths -> + missingConfig + "paths to source code files" + (Just "source-paths") + (Just "-s|--source-path") + CkExcludedPaths -> + missingConfig + "excluded paths" + (Just "excluded-paths") + (Just "-e|--excluded-path") + CkExcludeIgnoredPaths -> + missingConfig + "whether to exclude ignored paths" + (Just "exclude-ignored-paths") + (Just "--exclude-ignored-paths") + CkBuiltInTemplates -> + missingConfig + "use of built-in templates" + (Just "builtin-templates") + (Just "(-t|--template-path)|--builtin-templates") + CkVariables -> + missingConfig + "template variables" + (Just "variables") + (Just "-v|--variable") + CkEnabled -> missingConfig "enabled" (Just "enabled") Nothing + MixedHeaderSyntax -> mixedHeaderSyntax + where + withFT msg fileType = [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 = [iii| +missingConfig desc yaml cli = + [iii| Missing configuration for '#{desc}' (#{options}). See following page for more details: #{webDocConfigCurr} |] - where - cliText = fmap (\c -> [i|command line option '#{c}'|]) cli - yamlText = fmap (\c -> [i|YAML option '#{c}'|]) yaml - options = T.intercalate " or " . catMaybes $ [cliText, yamlText] + where + 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 index 5590370..d81d7b9 100644 --- a/src/Headroom/Data/Coerce.hs +++ b/src/Headroom/Data/Coerce.hs @@ -1,29 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Data.Coerce -Description : Extra functionality for coercion -Copyright : (c) 2019-2022 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 +-- | +-- Module : Headroom.Data.Coerce +-- Description : Extra functionality for coercion +-- Copyright : (c) 2019-2022 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 @@ -33,11 +30,12 @@ import RIO -- >>> 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 :: + (Coercible a b) => + -- | function to modify coerced value + (b -> b) -> + -- | value to modify + a -> + -- | modified value + a inner f = coerce . f . coerce diff --git a/src/Headroom/Data/EnumExtra.hs b/src/Headroom/Data/EnumExtra.hs index 71293ba..1eb2277 100644 --- a/src/Headroom/Data/EnumExtra.hs +++ b/src/Headroom/Data/EnumExtra.hs @@ -1,72 +1,63 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} - -{-| -Module : Headroom.Data.EnumExtra -Description : Extra functionality for enum types -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Provides extra functionality for enum-like types, e.g. reading/writing -from/to textual representation, etc. --} - -module Headroom.Data.EnumExtra - ( EnumExtra(..) - ) -where - -import RIO -import qualified RIO.List as L -import qualified RIO.Text as T - +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Data.EnumExtra +-- Description : Extra functionality for enum types +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Provides extra functionality for enum-like types, e.g. reading/writing +-- from/to textual representation, etc. +module Headroom.Data.EnumExtra ( + EnumExtra (..) +) where + +import RIO +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 -- @DeriveAnyClass@ extension. class (Bounded a, Enum a, Eq a, Ord a, Show a) => EnumExtra a where - - - -- | Returns list of all enum values. - -- - -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - -- >>> allValues @Test - -- [Foo,Bar] - allValues :: [a] - allValues = [minBound ..] - - - -- | Returns all values of enum as single string, individual values separated - -- with comma. - -- - -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - -- >>> allValuesToText @Test - -- "Foo, Bar" - allValuesToText :: Text - allValuesToText = T.intercalate ", " (fmap enumToText (allValues :: [a])) - - - -- | Returns textual representation of enum value. Opposite to 'textToEnum'. - -- - -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - -- >>> enumToText Bar - -- "Bar" - enumToText :: a -> Text - enumToText = tshow - - - -- | Returns enum value from its textual representation. - -- Opposite to 'enumToText'. - -- - -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - -- >>> (textToEnum "Foo") :: (Maybe Test) - -- Just Foo - textToEnum :: Text -> Maybe a - textToEnum text = - let enumValue v = (T.toLower . enumToText $ v) == T.toLower text - in L.find enumValue allValues + -- | Returns list of all enum values. + -- + -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + -- >>> allValues @Test + -- [Foo,Bar] + allValues :: [a] + allValues = [minBound ..] + + -- | Returns all values of enum as single string, individual values separated + -- with comma. + -- + -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + -- >>> allValuesToText @Test + -- "Foo, Bar" + allValuesToText :: Text + allValuesToText = T.intercalate ", " (fmap enumToText (allValues :: [a])) + + -- | Returns textual representation of enum value. Opposite to 'textToEnum'. + -- + -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + -- >>> enumToText Bar + -- "Bar" + enumToText :: a -> Text + enumToText = tshow + + -- | Returns enum value from its textual representation. + -- Opposite to 'enumToText'. + -- + -- >>> data Test = Foo | Bar deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + -- >>> (textToEnum "Foo") :: (Maybe Test) + -- Just Foo + textToEnum :: Text -> Maybe a + textToEnum text = + let enumValue v = (T.toLower . enumToText $ v) == T.toLower text + in L.find enumValue allValues diff --git a/src/Headroom/Data/Has.hs b/src/Headroom/Data/Has.hs index d55de18..2726ba4 100644 --- a/src/Headroom/Data/Has.hs +++ b/src/Headroom/Data/Has.hs @@ -1,50 +1,40 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} - -{-| -Module : Headroom.Data.Has -Description : Simplified variant of @Data.Has@ -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides 'Has' /type class/, adapted to the needs of this -application. --} - -module Headroom.Data.Has - ( Has(..) - , HasRIO - ) -where - -import RIO +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Data.Has +-- Description : Simplified variant of @Data.Has@ +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides 'Has' /type class/, adapted to the needs of this +-- application. +module Headroom.Data.Has ( + Has (..) + , HasRIO +) where +import RIO -- | Implementation of the /Has type class/ pattern. class Has a t where + {-# MINIMAL getter, modifier | hasLens #-} - {-# MINIMAL getter, modifier | hasLens #-} - + getter :: t -> a + getter = getConst . hasLens Const - 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) - 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 - + viewL :: MonadReader t m => m a + viewL = view hasLens -- | Handy type alias that allows to avoid ugly type singatures. Allows to -- transform this: @@ -58,5 +48,4 @@ class Has a t where -- @ -- foo :: (HasRIO Network env) => RIO env () -- @ --- type HasRIO a env = Has (a (RIO env)) env diff --git a/src/Headroom/Data/Lens.hs b/src/Headroom/Data/Lens.hs index 2e1dd3f..febc3a9 100644 --- a/src/Headroom/Data/Lens.hs +++ b/src/Headroom/Data/Lens.hs @@ -1,33 +1,30 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Data.Lens -Description : Custom functionality related to /lens/ -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Provides customized versions of /lens/ functions. --} - -module Headroom.Data.Lens - ( suffixLenses - , suffixLensesFor - ) -where - -import qualified Language.Haskell.TH.Lib as TH -import qualified Language.Haskell.TH.Syntax as TH -import Lens.Micro.TH ( DefName(..) - , lensField - , lensRules - , lensRulesFor - , makeLensesWith - ) -import RIO - +-- | +-- Module : Headroom.Data.Lens +-- Description : Custom functionality related to /lens/ +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Provides customized versions of /lens/ functions. +module Headroom.Data.Lens ( + suffixLenses + , suffixLensesFor +) where + +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH +import Lens.Micro.TH ( + DefName (..) + , lensField + , lensRules + , lensRulesFor + , makeLensesWith + ) +import RIO -- | A template haskell function to build lenses for a record type. This -- function differs from the 'Control.Lens.makeLenses' function in that @@ -36,10 +33,11 @@ import RIO -- are lenses. suffixLenses :: TH.Name -> TH.DecsQ suffixLenses = makeLensesWith $ lensRules & lensField .~ withSuffix - where withSuffix _ _ name = [TopName . TH.mkName $ (TH.nameBase name <> "L")] - + where + withSuffix _ _ name = [TopName . TH.mkName $ (TH.nameBase name <> "L")] -- | Same as 'suffixLensesFor', but build lenses only for selected fields. suffixLensesFor :: [String] -> TH.Name -> TH.DecsQ suffixLensesFor fields = makeLensesWith $ lensRulesFor fields' - where fields' = fmap (\f -> (f, f <> "L")) fields + where + fields' = fmap (\f -> (f, f <> "L")) fields diff --git a/src/Headroom/Data/Regex.hs b/src/Headroom/Data/Regex.hs index 910618b..d8bf8d3 100644 --- a/src/Headroom/Data/Regex.hs +++ b/src/Headroom/Data/Regex.hs @@ -1,185 +1,186 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskellQuotes #-} - -{-| -Module : Headroom.Data.Regex -Description : Helper functions for regular expressions -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Extends functionalify provided by "Text.Regex.PCRE.Light" -and "Text.Regex.PCRE.Heavy" that more suits the needs of this application. --} - -module Headroom.Data.Regex - ( -- * Data Types - Regex(..) - , RegexError(..) - -- * Regex Functions - , compile - , match - , isMatch - , re - , replace - , replaceFirst - , scan - -- * Unsafe Functions - , compileUnsafe - ) -where - -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.Base as PL - ( Regex(..) ) -import qualified Text.Regex.PCRE.Light.Char8 as PLC - +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Data.Regex +-- Description : Helper functions for regular expressions +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Extends functionalify provided by "Text.Regex.PCRE.Light" +-- and "Text.Regex.PCRE.Heavy" that more suits the needs of this application. +module Headroom.Data.Regex ( + -- * Data Types + Regex (..) + , RegexError (..) + + -- * Regex Functions + , compile + , match + , isMatch + , re + , replace + , replaceFirst + , scan + + -- * Unsafe Functions + , compileUnsafe +) where + +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.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 - instance Eq Regex where - Regex (PL.Regex _ r1) == Regex (PL.Regex _ r2) = r1 == r2 - + Regex (PL.Regex _ r1) == Regex (PL.Regex _ r2) = r1 == r2 instance Show Regex where - show (Regex (PL.Regex _ r)) = show r - + 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 - + parseJSON (String s) = pure . compileUnsafe $ s + parseJSON val = error $ "Invalid value: expected regex, found: " <> show val ------------------------------ PUBLIC FUNCTIONS ------------------------------ - -- | Compiles given /regex/ in /runtime/. If possible, prefer the 're' -- /quasi quotation/ version that does the same at /compile time/. -compile :: MonadThrow m - => Text - -- ^ /regex/ to compile - -> m Regex - -- ^ compiled regex +compile :: + MonadThrow m => + -- | /regex/ to compile + Text -> + -- | compiled regex + m Regex compile raw = either (throwM . CompilationFailed raw . T.pack) pure compile' - where compile' = Regex <$> PH.compileM (encodeUtf8 raw) [PLC.utf8] - + where + compile' = Regex <$> PH.compileM (encodeUtf8 raw) [PLC.utf8] -- | Same as 'PLC.match', but works with 'Text' and uses no additional options. -match :: Regex - -- ^ a PCRE regular expression value produced by compile - -> Text - -- ^ the subject text to match against - -> Maybe [Text] - -- ^ the result value +match :: + -- | a PCRE regular expression value produced by compile + Regex -> + -- | the subject text to match against + Text -> + -- | the result value + Maybe [Text] 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 :: + -- | a PCRE regular expression value produced by compile + Regex -> + -- | the subject text to match against + Text -> + -- | the result value + Bool isMatch regex subject = isJust $ match regex subject - -- | A QuasiQuoter for regular expressions that does a compile time check. re :: QuasiQuoter -re = QuasiQuoter { quoteExp = quoteExpRegex - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - } - where - quoteExpRegex txt = [|compileUnsafe . T.pack $ txt|] - where !_ = compileUnsafe . T.pack $ txt -- check at compile time - +re = + QuasiQuoter + { quoteExp = quoteExpRegex + , quotePat = undefined + , 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 - -- ^ pattern to replace - -> (Text -> [Text] -> Text) - -- ^ replacement function (as @fullMatch -> [groups] -> result@) - -> Text - -- ^ text to replace in - -> Text - -- ^ resulting text +replace :: + -- | pattern to replace + Regex -> + -- | replacement function (as @fullMatch -> [groups] -> result@) + (Text -> [Text] -> Text) -> + -- | text to replace in + Text -> + -- | resulting text + Text 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 :: + -- | pattern to replace + Regex -> + -- | replacement function (as @fullMatch -> [groups] -> result@) + (Text -> [Text] -> Text) -> + -- | text to replace in + Text -> + -- | resulting text + Text replaceFirst = PH.sub . coerce - -- | Searches the text for all occurences of given /regex/. -scan :: Regex - -- ^ /regex/ to search for - -> Text - -- ^ input text - -> [(Text, [Text])] - -- ^ found occurences (as @[(fullMatch, [groups])]@) +scan :: + -- | /regex/ to search for + Regex -> + -- | input text + Text -> + -- | found occurences (as @[(fullMatch, [groups])]@) + [(Text, [Text])] scan = PH.scan . coerce - -- | Compiles the given text into /regex/ in runtime. Note that if the /regex/ -- cannot be compiled, it will throw runtime error. Do not use this function -- unless you know what you're doing. -compileUnsafe :: Text - -- ^ /regex/ to compile - -> Regex - -- ^ compiled /regex/ or runtime exception +compileUnsafe :: + -- | /regex/ to compile + Text -> + -- | compiled /regex/ or runtime exception + Regex compileUnsafe raw = case compile raw of - Left err -> error . displayException $ err - Right res -> res - + Left err -> error . displayException $ err + Right res -> res --------------------------------- ERROR TYPES -------------------------------- -- | Exception specific to the "Headroom.Data.Regex" module. -data RegexError = CompilationFailed Text Text - -- ^ given input cannot be compiled as /regex/ - deriving (Show, Typeable) +data RegexError + = -- | given input cannot be compiled as /regex/ + CompilationFailed Text Text + deriving (Show, Typeable) instance Exception RegexError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: RegexError -> String displayException' = \case - CompilationFailed raw reason -> [iii| + CompilationFailed raw reason -> + [iii| Cannot compile regex from input '#{raw}', reason: #{reason} |] diff --git a/src/Headroom/Data/Serialization.hs b/src/Headroom/Data/Serialization.hs index 2746448..f15a46f 100644 --- a/src/Headroom/Data/Serialization.hs +++ b/src/Headroom/Data/Serialization.hs @@ -1,39 +1,36 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Data.Serialization -Description : Various functions for data (de)serialization -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing support for data (de)serialization, mainly from/to /JSON/ -and /YAML/. --} - -module Headroom.Data.Serialization - ( -- * JSON/YAML Serialization - aesonOptions - , dropFieldPrefix - , symbolCase - -- * Pretty Printing - , prettyPrintYAML - ) -where - -import Data.Aeson ( Options - , ToJSON(..) - , defaultOptions - , fieldLabelModifier - ) -import qualified Data.Yaml.Pretty as YP -import RIO -import qualified RIO.Char as C +-- | +-- Module : Headroom.Data.Serialization +-- Description : Various functions for data (de)serialization +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing support for data (de)serialization, mainly from/to /JSON/ +-- and /YAML/. +module Headroom.Data.Serialization ( + -- * JSON/YAML Serialization + aesonOptions + , dropFieldPrefix + , symbolCase + -- * Pretty Printing + , prettyPrintYAML +) where +import Data.Aeson ( + Options + , ToJSON (..) + , defaultOptions + , fieldLabelModifier + ) +import qualified Data.Yaml.Pretty as YP +import RIO +import qualified RIO.Char as C -- | Custom /Aeson/ encoding options used for generic mapping between data -- records and /JSON/ or /YAML/ values. Expects the fields in input to be @@ -41,8 +38,7 @@ import qualified RIO.Char as C -- (example: record field @uUserName@, /JSON/ field @user-name@). aesonOptions :: Options aesonOptions = - defaultOptions { fieldLabelModifier = symbolCase '-' . dropFieldPrefix } - + defaultOptions{fieldLabelModifier = symbolCase '-' . dropFieldPrefix} -- | Drops prefix from camel-case text. -- @@ -50,33 +46,35 @@ aesonOptions = -- "helloWorld" dropFieldPrefix :: String -> String dropFieldPrefix = \case - (x : n : xs) | C.isUpper x && C.isUpper n -> x : n : xs - (x : n : xs) | C.isUpper x -> C.toLower x : n : xs - (_ : xs) -> dropFieldPrefix xs - [] -> [] - + (x : n : xs) | C.isUpper x && C.isUpper n -> x : n : xs + (x : n : xs) | C.isUpper x -> C.toLower x : n : xs + (_ : xs) -> dropFieldPrefix xs + [] -> [] -- | Transforms camel-case text into text cased with given symbol. -- -- >>> symbolCase '-' "fooBar" -- "foo-bar" -symbolCase :: Char - -- ^ word separator symbol - -> String - -- ^ input text - -> String - -- ^ processed text +symbolCase :: + -- | word separator symbol + Char -> + -- | input text + String -> + -- | processed text + String symbolCase sym = \case - [] -> [] - (x : xs) | C.isUpper x -> sym : C.toLower x : symbolCase sym xs - | otherwise -> x : symbolCase sym xs - + [] -> [] + (x : xs) + | C.isUpper x -> sym : C.toLower x : symbolCase sym xs + | otherwise -> x : symbolCase sym xs -- | Pretty prints given data as /YAML/. -prettyPrintYAML :: ToJSON a - => a - -- ^ data to pretty print - -> Text - -- ^ pretty printed /YAML/ output +prettyPrintYAML :: + ToJSON a => + -- | data to pretty print + a -> + -- | pretty printed /YAML/ output + Text prettyPrintYAML = decodeUtf8Lenient . YP.encodePretty prettyConfig - where prettyConfig = YP.setConfCompare compare YP.defConfig + where + prettyConfig = YP.setConfCompare compare YP.defConfig diff --git a/src/Headroom/Data/Text.hs b/src/Headroom/Data/Text.hs index 1fdbe97..27b20c3 100644 --- a/src/Headroom/Data/Text.hs +++ b/src/Headroom/Data/Text.hs @@ -1,34 +1,31 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Data.Text -Description : Additional utilities for text manipulation -Copyright : (c) 2019-2022 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 - +-- | +-- Module : Headroom.Data.Text +-- Description : Additional utilities for text manipulation +-- Copyright : (c) 2019-2022 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 ------------------------------ @@ -37,44 +34,44 @@ import qualified RIO.Text.Partial as TP -- -- >>> commonLinesPrefix "-- first\n-- second\n-- third" -- Just "-- " -commonLinesPrefix :: Text - -- ^ lines of text to find prefix for - -> Maybe Text - -- ^ found longest common prefixs +commonLinesPrefix :: + -- | lines of text to find prefix for + Text -> + -- | found longest common prefixs + Maybe Text 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 - + 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] - +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 :: + -- | function to map over individual lines + (Text -> Text) -> + -- | input text + Text -> + -- | resulting text + 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 @@ -82,31 +79,31 @@ mapLines fn = mapLinesF (Just <$> fn) -- -- >>> 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 :: + Foldable t => + -- | function to map over inividual lines + (Text -> t Text) -> + -- | input text + Text -> + -- | resulting text + Text mapLinesF f = fromLines . concatMap toList . go . toLines - where - go [] = [] - go (x : xs) = f x : go xs - + 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 :: + Read a => + -- | input text to parse + Text -> + -- | parsed value + Maybe a 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: @@ -130,13 +127,13 @@ read = readMaybe . T.unpack -- -- >>> fromLines ["first", "second", ""] -- "first\nsecond\n" -fromLines :: [Text] - -- ^ lines to join - -> Text - -- ^ text joined from individual lines +fromLines :: + -- | lines to join + [Text] -> + -- | text joined from individual lines + Text 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: @@ -157,9 +154,11 @@ fromLines = T.intercalate "\n" -- -- >>> 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 +toLines :: + -- | text to break into lines + Text -> + -- | lines of input text + [Text] +toLines input + | T.null input = [] + | otherwise = T.split (== '\n') input diff --git a/src/Headroom/Embedded.hs b/src/Headroom/Embedded.hs index 6a40619..4e8d42f 100644 --- a/src/Headroom/Embedded.hs +++ b/src/Headroom/Embedded.hs @@ -1,157 +1,155 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-| -Module : Headroom.Embedded -Description : Embedded files -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Contains contents of files embedded using the "Data.FileEmbed" module. --} - -module Headroom.Embedded - ( configFileStub - , defaultConfig - , defaultGlobalConfig - , licenseTemplate - ) -where - -import Headroom.Config.Types ( LicenseType(..) ) -import Headroom.Embedded.TH ( embedConfigFile - , embedDefaultConfig - , embedDefaultGlobalConfig - , embedTemplate - ) -import Headroom.FileType.Types ( FileType(..) ) -import RIO +-- | +-- Module : Headroom.Embedded +-- Description : Embedded files +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Contains contents of files embedded using the "Data.FileEmbed" module. +module Headroom.Embedded ( + configFileStub + , defaultConfig + , defaultGlobalConfig + , licenseTemplate +) where +import Headroom.Config.Types (LicenseType (..)) +import Headroom.Embedded.TH ( + embedConfigFile + , embedDefaultConfig + , embedDefaultGlobalConfig + , embedTemplate + ) +import Headroom.FileType.Types (FileType (..)) +import RIO -- | Content of dummy /YAML/ configuration file for the application. configFileStub :: IsString a => a configFileStub = $(embedConfigFile) - -- | Default /YAML/ configuration. defaultConfig :: IsString a => a defaultConfig = $(embedDefaultConfig) - -- | Default /YAML/ configuration for the global configuration file. defaultGlobalConfig :: IsString a => a defaultGlobalConfig = $(embedDefaultGlobalConfig) - -- | License template for given license. -licenseTemplate :: IsString a - => LicenseType -- ^ license for which to return the template - -> FileType -- ^ license for which to return the template - -> a -- ^ template text +licenseTemplate :: + IsString a => + -- | license for which to return the template + LicenseType -> + -- | license for which to return the template + FileType -> + -- | template text + a licenseTemplate licenseType fileType = case licenseType of - Apache2 -> case fileType of - C -> $(embedTemplate Apache2 C) - CPP -> $(embedTemplate Apache2 CPP) - CSS -> $(embedTemplate Apache2 CSS) - Dart -> $(embedTemplate Apache2 Dart) - Go -> $(embedTemplate Apache2 Go) - Haskell -> $(embedTemplate Apache2 Haskell) - HTML -> $(embedTemplate Apache2 HTML) - Java -> $(embedTemplate Apache2 Java) - JS -> $(embedTemplate Apache2 JS) - Kotlin -> $(embedTemplate Apache2 Kotlin) - PHP -> $(embedTemplate Apache2 PHP) - PureScript -> $(embedTemplate Apache2 PureScript) - Python -> $(embedTemplate Apache2 Python) - Rust -> $(embedTemplate Apache2 Rust) - Scala -> $(embedTemplate Apache2 Scala) - Shell -> $(embedTemplate Apache2 Shell) - BSD3 -> case fileType of - C -> $(embedTemplate BSD3 C) - CPP -> $(embedTemplate BSD3 CPP) - CSS -> $(embedTemplate BSD3 CSS) - Dart -> $(embedTemplate BSD3 Dart) - Go -> $(embedTemplate BSD3 Go) - Haskell -> $(embedTemplate BSD3 Haskell) - HTML -> $(embedTemplate BSD3 HTML) - Java -> $(embedTemplate BSD3 Java) - JS -> $(embedTemplate BSD3 JS) - Kotlin -> $(embedTemplate BSD3 Kotlin) - PHP -> $(embedTemplate BSD3 PHP) - PureScript -> $(embedTemplate BSD3 PureScript) - Python -> $(embedTemplate BSD3 Python) - Rust -> $(embedTemplate BSD3 Rust) - Scala -> $(embedTemplate BSD3 Scala) - Shell -> $(embedTemplate BSD3 Shell) - GPL2 -> case fileType of - C -> $(embedTemplate GPL2 C) - CPP -> $(embedTemplate GPL2 CPP) - CSS -> $(embedTemplate GPL2 CSS) - Dart -> $(embedTemplate GPL2 Dart) - Go -> $(embedTemplate GPL2 Go) - Haskell -> $(embedTemplate GPL2 Haskell) - HTML -> $(embedTemplate GPL2 HTML) - Java -> $(embedTemplate GPL2 Java) - JS -> $(embedTemplate GPL2 JS) - Kotlin -> $(embedTemplate GPL2 Kotlin) - PHP -> $(embedTemplate GPL2 PHP) - PureScript -> $(embedTemplate GPL2 PureScript) - Python -> $(embedTemplate GPL2 Python) - Rust -> $(embedTemplate GPL2 Rust) - Scala -> $(embedTemplate GPL2 Scala) - Shell -> $(embedTemplate GPL2 Shell) - GPL3 -> case fileType of - C -> $(embedTemplate GPL3 C) - CPP -> $(embedTemplate GPL3 CPP) - CSS -> $(embedTemplate GPL3 CSS) - Dart -> $(embedTemplate GPL3 Dart) - Go -> $(embedTemplate GPL3 Go) - Haskell -> $(embedTemplate GPL3 Haskell) - HTML -> $(embedTemplate GPL3 HTML) - Java -> $(embedTemplate GPL3 Java) - JS -> $(embedTemplate GPL3 JS) - Kotlin -> $(embedTemplate GPL3 Kotlin) - PHP -> $(embedTemplate GPL3 PHP) - PureScript -> $(embedTemplate GPL3 PureScript) - Python -> $(embedTemplate GPL3 Python) - Rust -> $(embedTemplate GPL3 Rust) - Scala -> $(embedTemplate GPL3 Scala) - Shell -> $(embedTemplate GPL3 Shell) - MIT -> case fileType of - C -> $(embedTemplate MIT C) - CPP -> $(embedTemplate MIT CPP) - CSS -> $(embedTemplate MIT CSS) - Dart -> $(embedTemplate MIT Dart) - Go -> $(embedTemplate MIT Go) - Haskell -> $(embedTemplate MIT Haskell) - HTML -> $(embedTemplate MIT HTML) - Java -> $(embedTemplate MIT Java) - JS -> $(embedTemplate MIT JS) - Kotlin -> $(embedTemplate MIT Kotlin) - PHP -> $(embedTemplate MIT PHP) - PureScript -> $(embedTemplate MIT PureScript) - Python -> $(embedTemplate MIT Python) - Rust -> $(embedTemplate MIT Rust) - Scala -> $(embedTemplate MIT Scala) - Shell -> $(embedTemplate MIT Shell) - MPL2 -> case fileType of - C -> $(embedTemplate MPL2 C) - CPP -> $(embedTemplate MPL2 CPP) - CSS -> $(embedTemplate MPL2 CSS) - Dart -> $(embedTemplate MPL2 Dart) - Go -> $(embedTemplate MPL2 Go) - Haskell -> $(embedTemplate MPL2 Haskell) - HTML -> $(embedTemplate MPL2 HTML) - Java -> $(embedTemplate MPL2 Java) - JS -> $(embedTemplate MPL2 JS) - Kotlin -> $(embedTemplate MPL2 Kotlin) - PHP -> $(embedTemplate MPL2 PHP) - PureScript -> $(embedTemplate MPL2 PureScript) - Python -> $(embedTemplate MPL2 Python) - Rust -> $(embedTemplate MPL2 Rust) - Scala -> $(embedTemplate MPL2 Scala) - Shell -> $(embedTemplate MPL2 Shell) + Apache2 -> case fileType of + C -> $(embedTemplate Apache2 C) + CPP -> $(embedTemplate Apache2 CPP) + CSS -> $(embedTemplate Apache2 CSS) + Dart -> $(embedTemplate Apache2 Dart) + Go -> $(embedTemplate Apache2 Go) + Haskell -> $(embedTemplate Apache2 Haskell) + HTML -> $(embedTemplate Apache2 HTML) + Java -> $(embedTemplate Apache2 Java) + JS -> $(embedTemplate Apache2 JS) + Kotlin -> $(embedTemplate Apache2 Kotlin) + PHP -> $(embedTemplate Apache2 PHP) + PureScript -> $(embedTemplate Apache2 PureScript) + Python -> $(embedTemplate Apache2 Python) + Rust -> $(embedTemplate Apache2 Rust) + Scala -> $(embedTemplate Apache2 Scala) + Shell -> $(embedTemplate Apache2 Shell) + BSD3 -> case fileType of + C -> $(embedTemplate BSD3 C) + CPP -> $(embedTemplate BSD3 CPP) + CSS -> $(embedTemplate BSD3 CSS) + Dart -> $(embedTemplate BSD3 Dart) + Go -> $(embedTemplate BSD3 Go) + Haskell -> $(embedTemplate BSD3 Haskell) + HTML -> $(embedTemplate BSD3 HTML) + Java -> $(embedTemplate BSD3 Java) + JS -> $(embedTemplate BSD3 JS) + Kotlin -> $(embedTemplate BSD3 Kotlin) + PHP -> $(embedTemplate BSD3 PHP) + PureScript -> $(embedTemplate BSD3 PureScript) + Python -> $(embedTemplate BSD3 Python) + Rust -> $(embedTemplate BSD3 Rust) + Scala -> $(embedTemplate BSD3 Scala) + Shell -> $(embedTemplate BSD3 Shell) + GPL2 -> case fileType of + C -> $(embedTemplate GPL2 C) + CPP -> $(embedTemplate GPL2 CPP) + CSS -> $(embedTemplate GPL2 CSS) + Dart -> $(embedTemplate GPL2 Dart) + Go -> $(embedTemplate GPL2 Go) + Haskell -> $(embedTemplate GPL2 Haskell) + HTML -> $(embedTemplate GPL2 HTML) + Java -> $(embedTemplate GPL2 Java) + JS -> $(embedTemplate GPL2 JS) + Kotlin -> $(embedTemplate GPL2 Kotlin) + PHP -> $(embedTemplate GPL2 PHP) + PureScript -> $(embedTemplate GPL2 PureScript) + Python -> $(embedTemplate GPL2 Python) + Rust -> $(embedTemplate GPL2 Rust) + Scala -> $(embedTemplate GPL2 Scala) + Shell -> $(embedTemplate GPL2 Shell) + GPL3 -> case fileType of + C -> $(embedTemplate GPL3 C) + CPP -> $(embedTemplate GPL3 CPP) + CSS -> $(embedTemplate GPL3 CSS) + Dart -> $(embedTemplate GPL3 Dart) + Go -> $(embedTemplate GPL3 Go) + Haskell -> $(embedTemplate GPL3 Haskell) + HTML -> $(embedTemplate GPL3 HTML) + Java -> $(embedTemplate GPL3 Java) + JS -> $(embedTemplate GPL3 JS) + Kotlin -> $(embedTemplate GPL3 Kotlin) + PHP -> $(embedTemplate GPL3 PHP) + PureScript -> $(embedTemplate GPL3 PureScript) + Python -> $(embedTemplate GPL3 Python) + Rust -> $(embedTemplate GPL3 Rust) + Scala -> $(embedTemplate GPL3 Scala) + Shell -> $(embedTemplate GPL3 Shell) + MIT -> case fileType of + C -> $(embedTemplate MIT C) + CPP -> $(embedTemplate MIT CPP) + CSS -> $(embedTemplate MIT CSS) + Dart -> $(embedTemplate MIT Dart) + Go -> $(embedTemplate MIT Go) + Haskell -> $(embedTemplate MIT Haskell) + HTML -> $(embedTemplate MIT HTML) + Java -> $(embedTemplate MIT Java) + JS -> $(embedTemplate MIT JS) + Kotlin -> $(embedTemplate MIT Kotlin) + PHP -> $(embedTemplate MIT PHP) + PureScript -> $(embedTemplate MIT PureScript) + Python -> $(embedTemplate MIT Python) + Rust -> $(embedTemplate MIT Rust) + Scala -> $(embedTemplate MIT Scala) + Shell -> $(embedTemplate MIT Shell) + MPL2 -> case fileType of + C -> $(embedTemplate MPL2 C) + CPP -> $(embedTemplate MPL2 CPP) + CSS -> $(embedTemplate MPL2 CSS) + Dart -> $(embedTemplate MPL2 Dart) + Go -> $(embedTemplate MPL2 Go) + Haskell -> $(embedTemplate MPL2 Haskell) + HTML -> $(embedTemplate MPL2 HTML) + Java -> $(embedTemplate MPL2 Java) + JS -> $(embedTemplate MPL2 JS) + Kotlin -> $(embedTemplate MPL2 Kotlin) + PHP -> $(embedTemplate MPL2 PHP) + PureScript -> $(embedTemplate MPL2 PureScript) + Python -> $(embedTemplate MPL2 Python) + Rust -> $(embedTemplate MPL2 Rust) + Scala -> $(embedTemplate MPL2 Scala) + Shell -> $(embedTemplate MPL2 Shell) diff --git a/src/Headroom/Embedded/TH.hs b/src/Headroom/Embedded/TH.hs index a61da9a..8207fce 100644 --- a/src/Headroom/Embedded/TH.hs +++ b/src/Headroom/Embedded/TH.hs @@ -1,69 +1,65 @@ +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeApplications #-} -{-| -Module : Headroom.Embedded.TH -Description : /Template Haskell/ functions for "Headroom.Embedded" -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains some /Template Haskell/ powered functions, used by -"Headroom.Embedded" module, that needs to be placed in separated module, due to -/GHC/ stage restriction. --} - -module Headroom.Embedded.TH - ( embedConfigFile - , embedDefaultConfig - , embedDefaultGlobalConfig - , embedTemplate - ) -where - -import Data.FileEmbed ( embedStringFile ) -import Headroom.Config.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 +-- | +-- Module : Headroom.Embedded.TH +-- Description : /Template Haskell/ functions for "Headroom.Embedded" +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains some /Template Haskell/ powered functions, used by +-- "Headroom.Embedded" module, that needs to be placed in separated module, due to +-- /GHC/ stage restriction. +module Headroom.Embedded.TH ( + embedConfigFile + , embedDefaultConfig + , embedDefaultGlobalConfig + , embedTemplate +) where +import Data.FileEmbed (embedStringFile) +import Headroom.Config.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 -- | Embeds stub configuration file to source code. embedConfigFile :: Q Exp embedConfigFile = embedStringFile "embedded/config-file.yaml" - -- | Embeds default configuration file to source code. embedDefaultConfig :: Q Exp embedDefaultConfig = embedStringFile "embedded/default-config.yaml" - -- | Embeds default global configuration file to source code. embedDefaultGlobalConfig :: Q Exp embedDefaultGlobalConfig = - embedStringFile "embedded/default-global-config.yaml" - + embedStringFile "embedded/default-global-config.yaml" -- | Embeds /template file/ to the source code. -embedTemplate :: LicenseType - -- ^ type of the /license/ - -> FileType - -- ^ type of the source code file - -> Q Exp - -- ^ content of the appropriate /template/ file -embedTemplate lt ft = (embedStringFile . mconcat) - ["embedded/license/", toStringLC lt, "/", toStringLC ft, ".", ext] - where ext = T.unpack . NE.head $ templateExtensions @TemplateType - +embedTemplate :: + -- | type of the /license/ + LicenseType -> + -- | type of the source code file + FileType -> + -- | content of the appropriate /template/ file + Q Exp +embedTemplate lt ft = + (embedStringFile . mconcat) + ["embedded/license/", toStringLC lt, "/", toStringLC ft, ".", ext] + where + ext = T.unpack . NE.head $ templateExtensions @TemplateType ------------------------------ PRIVATE FUNCTIONS ----------------------------- diff --git a/src/Headroom/FileSupport.hs b/src/Headroom/FileSupport.hs index e10015e..29516f4 100644 --- a/src/Headroom/FileSupport.hs +++ b/src/Headroom/FileSupport.hs @@ -1,103 +1,103 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-| -Module : Headroom.FileSupport -Description : Support for handling various source code file types -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -/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 - ( fileSupport - , analyzeSourceCode - ) -where - -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.Dart as Dart -import qualified Headroom.FileSupport.Go as Go -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.Kotlin as Kotlin -import qualified Headroom.FileSupport.PHP as PHP -import qualified Headroom.FileSupport.PureScript as PureScript -import qualified Headroom.FileSupport.Python as Python -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.Text as T +-- | +-- Module : Headroom.FileSupport +-- Description : Support for handling various source code file types +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- /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 ( + fileSupport + , analyzeSourceCode +) where +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.Dart as Dart +import qualified Headroom.FileSupport.Go as Go +import qualified Headroom.FileSupport.HTML as HTML +import qualified Headroom.FileSupport.Haskell as Haskell +import qualified Headroom.FileSupport.JS as JS +import qualified Headroom.FileSupport.Java as Java +import qualified Headroom.FileSupport.Kotlin as Kotlin +import qualified Headroom.FileSupport.PHP as PHP +import qualified Headroom.FileSupport.PureScript as PureScript +import qualified Headroom.FileSupport.Python as Python +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.Text as T ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Returns 'FileSupport' for corresponding 'FileType'. fileSupport :: FileType -> FileSupport -fileSupport C = C.fileSupport -fileSupport CPP = CPP.fileSupport -fileSupport CSS = CSS.fileSupport -fileSupport Dart = Dart.fileSupport -fileSupport Go = Go.fileSupport -fileSupport Haskell = Haskell.fileSupport -fileSupport HTML = HTML.fileSupport -fileSupport Java = Java.fileSupport -fileSupport JS = JS.fileSupport -fileSupport Kotlin = Kotlin.fileSupport -fileSupport PHP = PHP.fileSupport +fileSupport C = C.fileSupport +fileSupport CPP = CPP.fileSupport +fileSupport CSS = CSS.fileSupport +fileSupport Dart = Dart.fileSupport +fileSupport Go = Go.fileSupport +fileSupport Haskell = Haskell.fileSupport +fileSupport HTML = HTML.fileSupport +fileSupport Java = Java.fileSupport +fileSupport JS = JS.fileSupport +fileSupport Kotlin = Kotlin.fileSupport +fileSupport PHP = PHP.fileSupport fileSupport PureScript = PureScript.fileSupport -fileSupport Python = Python.fileSupport -fileSupport Rust = Rust.fileSupport -fileSupport Scala = Scala.fileSupport -fileSupport Shell = Shell.fileSupport - +fileSupport Python = Python.fileSupport +fileSupport Rust = Rust.fileSupport +fileSupport Scala = Scala.fileSupport +fileSupport Shell = Shell.fileSupport -- | 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 :: + -- | 'FileSupport' implementation used for analysis + FileSupport -> + -- | raw source code to analyze + Text -> + -- | analyzed source code + SourceCode analyzeSourceCode fs = fromText state0 process - where - 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 + where + 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 diff --git a/src/Headroom/FileSupport/C.hs b/src/Headroom/FileSupport/C.hs index d51c55f..fbe65a1 100644 --- a/src/Headroom/FileSupport/C.hs +++ b/src/Headroom/FileSupport/C.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.C -Description : Support for /C/ source code files -Copyright : (c) 2019-2022 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(C) ) +-- | +-- Module : Headroom.FileSupport.C +-- Description : Support for /C/ source code files +-- Copyright : (c) 2019-2022 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 (C)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(C) ) fileSupport :: FileSupport fileSupport = defaultFileSupport C syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/CPP.hs b/src/Headroom/FileSupport/CPP.hs index cc8866a..a568d89 100644 --- a/src/Headroom/FileSupport/CPP.hs +++ b/src/Headroom/FileSupport/CPP.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.CPP -Description : Support for /C++/ source code files -Copyright : (c) 2019-2022 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(CPP) ) +-- | +-- Module : Headroom.FileSupport.CPP +-- Description : Support for /C++/ source code files +-- Copyright : (c) 2019-2022 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 (CPP)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(CPP) ) fileSupport :: FileSupport fileSupport = defaultFileSupport CPP syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/CSS.hs b/src/Headroom/FileSupport/CSS.hs index 2d34060..6be1df6 100644 --- a/src/Headroom/FileSupport/CSS.hs +++ b/src/Headroom/FileSupport/CSS.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.CSS -Description : Support for /CSS/ source code files -Copyright : (c) 2019-2022 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(CSS) ) +-- | +-- Module : Headroom.FileSupport.CSS +-- Description : Support for /CSS/ source code files +-- Copyright : (c) 2019-2022 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 (CSS)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(CSS) ) fileSupport :: FileSupport fileSupport = defaultFileSupport CSS syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|] - , saIsCommentEnd = isMatch [re|\*\/$|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|] + , saIsCommentEnd = isMatch [re|\*\/$|] + } diff --git a/src/Headroom/FileSupport/Dart.hs b/src/Headroom/FileSupport/Dart.hs index 8ef5293..696a4cc 100644 --- a/src/Headroom/FileSupport/Dart.hs +++ b/src/Headroom/FileSupport/Dart.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.Dart -Description : Support for /Dart/ source code files -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Basic support for /Dart language/ source code files. This implementation doesn't -extract any variables or template data. --} - -module Headroom.FileSupport.Dart - ( fileSupport - ) -where - -import Headroom.Data.Regex ( isMatch - , re - ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - , defaultFileSupport - ) -import Headroom.FileType.Types ( FileType(Dart) ) +-- | +-- Module : Headroom.FileSupport.Dart +-- Description : Support for /Dart/ source code files +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Basic support for /Dart language/ source code files. This implementation doesn't +-- extract any variables or template data. +module Headroom.FileSupport.Dart ( + fileSupport +) where + +import Headroom.Data.Regex ( + isMatch + , re + ) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + , defaultFileSupport + ) +import Headroom.FileType.Types (FileType (Dart)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(Dart) ) fileSupport :: FileSupport fileSupport = defaultFileSupport Dart syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Go.hs b/src/Headroom/FileSupport/Go.hs index 487b3ef..151ac8c 100644 --- a/src/Headroom/FileSupport/Go.hs +++ b/src/Headroom/FileSupport/Go.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.Go -Description : Support for /Go/ source code files -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Basic support for /Go language/ source code files. This implementation doesn't -extract any variables or template data. --} - -module Headroom.FileSupport.Go - ( fileSupport - ) -where - -import Headroom.Data.Regex ( isMatch - , re - ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - , defaultFileSupport - ) -import Headroom.FileType.Types ( FileType(Go) ) +-- | +-- Module : Headroom.FileSupport.Go +-- Description : Support for /Go/ source code files +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Basic support for /Go language/ source code files. This implementation doesn't +-- extract any variables or template data. +module Headroom.FileSupport.Go ( + fileSupport +) where + +import Headroom.Data.Regex ( + isMatch + , re + ) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + , defaultFileSupport + ) +import Headroom.FileType.Types (FileType (Go)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(Go) ) fileSupport :: FileSupport fileSupport = defaultFileSupport Go syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/HTML.hs b/src/Headroom/FileSupport/HTML.hs index 65fd3f8..28c21ea 100644 --- a/src/Headroom/FileSupport/HTML.hs +++ b/src/Headroom/FileSupport/HTML.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.HTML -Description : Support for /HTML/ source code files -Copyright : (c) 2019-2022 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(HTML) ) +-- | +-- Module : Headroom.FileSupport.HTML +-- Description : Support for /HTML/ source code files +-- Copyright : (c) 2019-2022 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 (HTML)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(HTML) ) fileSupport :: FileSupport fileSupport = defaultFileSupport HTML syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^$|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^$|] + } diff --git a/src/Headroom/FileSupport/Haskell.hs b/src/Headroom/FileSupport/Haskell.hs index 1f0e18f..77cce13 100644 --- a/src/Headroom/FileSupport/Haskell.hs +++ b/src/Headroom/FileSupport/Haskell.hs @@ -1,134 +1,134 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.FileSupport.Haskell -Description : Support for /Haskell/ source code files -Copyright : (c) 2019-2022 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.Config.Types ( HeaderConfig(..) - , HeaderSyntax(..) - ) -import Headroom.FileType.Types ( FileType(Haskell) ) -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 ) - +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.FileSupport.Haskell +-- Description : Support for /Haskell/ source code files +-- Copyright : (c) 2019-2022 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.Config.Types ( + HeaderConfig (..) + , HeaderSyntax (..) + ) +import Headroom.FileType.Types (FileType (Haskell)) +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 - } - +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*-}|^--|] - } - +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 - headerPos' = case syntax of - LineComment{} -> fmap (\(s, e) -> (s + 1, e + 1)) headerPos - BlockComment{} -> headerPos - + 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 + headerPos' = case syntax of + LineComment{} -> fmap (\(s, e) -> (s + 1, e + 1)) headerPos + BlockComment{} -> headerPos 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 - + 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 index 3ec2469..497c426 100644 --- a/src/Headroom/FileSupport/Haskell/Haddock.hs +++ b/src/Headroom/FileSupport/Haskell/Haddock.hs @@ -1,128 +1,126 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.FileSupport.Haskell.Haddock -Description : Extraction of /Haddock module header/ fields -Copyright : (c) 2019-2022 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.Config.Types ( HeaderSyntax(..) ) -import Headroom.Data.Regex ( re - , scan - ) -import Headroom.Data.Text ( fromLines - , toLines - ) -import qualified Headroom.Data.Text as T -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 +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.FileSupport.Haskell.Haddock +-- Description : Extraction of /Haddock module header/ fields +-- Copyright : (c) 2019-2022 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.Config.Types (HeaderSyntax (..)) +import Headroom.Data.Regex ( + re + , scan + ) +import Headroom.Data.Text ( + fromLines + , toLines + ) +import qualified Headroom.Data.Text as T +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) - - + { 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 a => + -- | parsed /template/ + a -> + -- | copyright header syntax + HeaderSyntax -> + -- | extracted offsets + HaddockOffsets extractOffsets template syntax = - let hoCopyright = extractCopyrightOffset templateText - in HaddockOffsets { .. } - where templateText = stripCommentSyntax syntax . rawTemplate $ template - + 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 - + [(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 code containing /Haddock/ module header + SourceCode -> + -- | extracted metadata from corresponding /template/ + TemplateData -> + -- | copyright header syntax + HeaderSyntax -> + -- | extracted metadata + HaddockModuleHeader 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' . toText $ source - stripCommentSyntax' = stripCommentSyntax syntax . T.replaceFirst "-- |" "" - 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 - + 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' . toText $ source + stripCommentSyntax' = stripCommentSyntax syntax . T.replaceFirst "-- |" "" + 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: @@ -138,20 +136,20 @@ extractModuleHeader source templateData syntax = -- -- >>> 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 :: + -- | offset (in number of black chars) for 2nd and subsequent lines + Maybe Int -> + -- | input text to indent + Text -> + -- | processed text + 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 " " - + 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: @@ -190,28 +188,28 @@ indentField (Just offset) text = fromLines . go . toLines $ text -- data C = C {-# UNPACK #-} !Int Char -newtype P a = P { unP :: [C] -> Maybe ([C], a) } - deriving Functor +newtype P a = P {unP :: [C] -> Maybe ([C], a)} + deriving (Functor) instance Applicative P where - pure x = P $ \s -> Just (s, x) - (<*>) = ap + 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 + 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 + 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 ] + where + input' = + concat [zipWith C [0 ..] l <> [C (length l) '\n'] | l <- lines input] ------------------------------------------------------------------------------- -- @@ -219,45 +217,49 @@ runP p input = fmap snd (unP p input') curInd :: P Int curInd = P $ \s -> Just . (,) s $ case s of - [] -> 0 - C i _ : _ -> i + [] -> 0 + C i _ : _ -> i rest :: P String -rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) +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 + 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 + [] -> 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 + [] -> 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) +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 @@ -265,17 +267,17 @@ takeWhileMaybe f = go where 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) + 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) + 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 index 2c4a0f1..d49a556 100644 --- a/src/Headroom/FileSupport/JS.hs +++ b/src/Headroom/FileSupport/JS.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.JS -Description : Support for /Javascript/ source code files -Copyright : (c) 2019-2022 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(JS) ) +-- | +-- Module : Headroom.FileSupport.JS +-- Description : Support for /Javascript/ source code files +-- Copyright : (c) 2019-2022 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 (JS)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(JS) ) fileSupport :: FileSupport fileSupport = defaultFileSupport JS syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Java.hs b/src/Headroom/FileSupport/Java.hs index 84eb43b..6048140 100644 --- a/src/Headroom/FileSupport/Java.hs +++ b/src/Headroom/FileSupport/Java.hs @@ -1,85 +1,87 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.FileSupport.Java -Description : Support for /Java/ source code files -Copyright : (c) 2019-2022 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(Java) ) -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 ) +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.FileSupport.Java +-- Description : Support for /Java/ source code files +-- Copyright : (c) 2019-2022 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 (Java)) +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 - } - +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] - +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 + where + f (lt, l) + | lt == Code = match [re|^package (.*);$|] l >>= (^? ix 1) + | otherwise = Nothing diff --git a/src/Headroom/FileSupport/Kotlin.hs b/src/Headroom/FileSupport/Kotlin.hs index 63ef0f8..278b28a 100644 --- a/src/Headroom/FileSupport/Kotlin.hs +++ b/src/Headroom/FileSupport/Kotlin.hs @@ -1,85 +1,87 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.FileSupport.Kotlin -Description : Support for /Kotlin/ source code files -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Support for /Kotlin/ source code files. This implementation extracts /Kotlin/ -package name as variable. - -= Extracted Variables for Templates -This implementation extracts following variables from source code file: - -* @___kotlin_package_name__@ - name of the /Kotlin/ package - -= Extracted Custom Data -This implementation does not extract any custom data from template file. --} - -module Headroom.FileSupport.Kotlin - ( 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(Kotlin) ) -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 ) +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.FileSupport.Kotlin +-- Description : Support for /Kotlin/ source code files +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Support for /Kotlin/ source code files. This implementation extracts /Kotlin/ +-- package name as variable. +-- +-- = Extracted Variables for Templates +-- This implementation extracts following variables from source code file: +-- +-- * @___kotlin_package_name__@ - name of the /Kotlin/ package +-- +-- = Extracted Custom Data +-- This implementation does not extract any custom data from template file. +module Headroom.FileSupport.Kotlin ( + 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 (Kotlin)) +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 /Kotlin/. fileSupport :: FileSupport -fileSupport = FileSupport - { fsSyntaxAnalysis = syntaxAnalysis - , fsExtractTemplateData = const . const $ NoTemplateData - , fsExtractVariables = extractVariables - , fsFileType = Kotlin - } - +fileSupport = + FileSupport + { fsSyntaxAnalysis = syntaxAnalysis + , fsExtractTemplateData = const . const $ NoTemplateData + , fsExtractVariables = extractVariables + , fsFileType = Kotlin + } ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } - - -extractVariables :: HeaderTemplate - -> Maybe (Int, Int) - -> SourceCode - -> Variables -extractVariables _ _ source = (mkVariables . catMaybes) - [("_kotlin_package_name", ) <$> extractPackageName source] - +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } + +extractVariables :: + HeaderTemplate -> + Maybe (Int, Int) -> + SourceCode -> + Variables +extractVariables _ _ source = + (mkVariables . catMaybes) + [("_kotlin_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 + where + f (lt, l) + | lt == Code = match [re|^package (.*)$|] l >>= (^? ix 1) + | otherwise = Nothing diff --git a/src/Headroom/FileSupport/PHP.hs b/src/Headroom/FileSupport/PHP.hs index 9e6baf5..5a03a26 100644 --- a/src/Headroom/FileSupport/PHP.hs +++ b/src/Headroom/FileSupport/PHP.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.PHP -Description : Support for /PHP/ source code files -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Basic support for /PHP/ source code files. This implementation doesn't -extract any variables or template data. --} - -module Headroom.FileSupport.PHP - ( fileSupport - ) -where - -import Headroom.Data.Regex ( isMatch - , re - ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - , defaultFileSupport - ) -import Headroom.FileType.Types ( FileType(PHP) ) +-- | +-- Module : Headroom.FileSupport.PHP +-- Description : Support for /PHP/ source code files +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Basic support for /PHP/ source code files. This implementation doesn't +-- extract any variables or template data. +module Headroom.FileSupport.PHP ( + fileSupport +) where + +import Headroom.Data.Regex ( + isMatch + , re + ) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + , defaultFileSupport + ) +import Headroom.FileType.Types (FileType (PHP)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(PHP) ) fileSupport :: FileSupport fileSupport = defaultFileSupport PHP syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/PureScript.hs b/src/Headroom/FileSupport/PureScript.hs index 310cb93..93c007d 100644 --- a/src/Headroom/FileSupport/PureScript.hs +++ b/src/Headroom/FileSupport/PureScript.hs @@ -1,88 +1,89 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.FileSupport.PureScript -Description : Support for /PureScript/ source code files -Copyright : (c) 2019-2022 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(PureScript) ) -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 ) +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.FileSupport.PureScript +-- Description : Support for /PureScript/ source code files +-- Copyright : (c) 2019-2022 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 (PureScript)) +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 - } - +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] - +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 + where + f (lt, l) + | lt == Code = match [re|^module\s+(\S+)|] l >>= (^? ix 1) + | otherwise = Nothing diff --git a/src/Headroom/FileSupport/Python.hs b/src/Headroom/FileSupport/Python.hs index 9ce96ec..ba59781 100644 --- a/src/Headroom/FileSupport/Python.hs +++ b/src/Headroom/FileSupport/Python.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.Python -Description : Support for /Python/ source code files -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Basic support for /Python/ source code files. This implementation doesn't -extract any variables or template data. --} - -module Headroom.FileSupport.Python - ( fileSupport - ) -where - -import Headroom.Data.Regex ( isMatch - , re - ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - , defaultFileSupport - ) -import Headroom.FileType.Types ( FileType(Python) ) +-- | +-- Module : Headroom.FileSupport.Python +-- Description : Support for /Python/ source code files +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Basic support for /Python/ source code files. This implementation doesn't +-- extract any variables or template data. +module Headroom.FileSupport.Python ( + fileSupport +) where + +import Headroom.Data.Regex ( + isMatch + , re + ) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + , defaultFileSupport + ) +import Headroom.FileType.Types (FileType (Python)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(Python) ) fileSupport :: FileSupport fileSupport = defaultFileSupport Python syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^#(?!!)|] - , saIsCommentEnd = isMatch [re|^#(?!!)|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^#(?!!)|] + , saIsCommentEnd = isMatch [re|^#(?!!)|] + } diff --git a/src/Headroom/FileSupport/Rust.hs b/src/Headroom/FileSupport/Rust.hs index 95d9038..bc01c84 100644 --- a/src/Headroom/FileSupport/Rust.hs +++ b/src/Headroom/FileSupport/Rust.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.Rust -Description : Support for /Rust/ source code files -Copyright : (c) 2019-2022 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(Rust) ) +-- | +-- Module : Headroom.FileSupport.Rust +-- Description : Support for /Rust/ source code files +-- Copyright : (c) 2019-2022 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 (Rust)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(Rust) ) fileSupport :: FileSupport fileSupport = defaultFileSupport Rust syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Scala.hs b/src/Headroom/FileSupport/Scala.hs index ec7cb48..9de3d44 100644 --- a/src/Headroom/FileSupport/Scala.hs +++ b/src/Headroom/FileSupport/Scala.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.Scala -Description : Support for /Scala/ source code files -Copyright : (c) 2019-2022 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(Scala) ) +-- | +-- Module : Headroom.FileSupport.Scala +-- Description : Support for /Scala/ source code files +-- Copyright : (c) 2019-2022 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 (Scala)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(Scala) ) fileSupport :: FileSupport fileSupport = defaultFileSupport Scala syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] - , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Shell.hs b/src/Headroom/FileSupport/Shell.hs index c62383e..e9849a7 100644 --- a/src/Headroom/FileSupport/Shell.hs +++ b/src/Headroom/FileSupport/Shell.hs @@ -1,33 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.FileSupport.Shell -Description : Support for /Shell/ source code files -Copyright : (c) 2019-2022 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(Shell) ) +-- | +-- Module : Headroom.FileSupport.Shell +-- Description : Support for /Shell/ source code files +-- Copyright : (c) 2019-2022 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 (Shell)) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -35,10 +33,11 @@ import Headroom.FileType.Types ( FileType(Shell) ) fileSupport :: FileSupport fileSupport = defaultFileSupport Shell syntaxAnalysis - ------------------------------ PRIVATE FUNCTIONS ----------------------------- syntaxAnalysis :: SyntaxAnalysis -syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^#(?!!)|] - , saIsCommentEnd = isMatch [re|^#(?!!)|] - } +syntaxAnalysis = + SyntaxAnalysis + { saIsCommentStart = isMatch [re|^#(?!!)|] + , saIsCommentEnd = isMatch [re|^#(?!!)|] + } diff --git a/src/Headroom/FileSupport/TemplateData.hs b/src/Headroom/FileSupport/TemplateData.hs index 63909e5..989a749 100644 --- a/src/Headroom/FileSupport/TemplateData.hs +++ b/src/Headroom/FileSupport/TemplateData.hs @@ -1,48 +1,44 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.FileSupport.TemplateData -Description : Custom data specific to file support implementations -Copyright : (c) 2019-2022 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 +-- | +-- Module : Headroom.FileSupport.TemplateData +-- Description : Custom data specific to file support implementations +-- Copyright : (c) 2019-2022 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) + = -- | additional template data for /Haskell/ + HaskellTemplateData HaskellTemplateData' + | -- | no additional template data provided + NoTemplateData + 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) - + { 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) + { htdHaddockOffsets :: HaddockOffsets + -- ^ offsets for /Haddock/ fields + } + deriving (Eq, Show) diff --git a/src/Headroom/FileSupport/Types.hs b/src/Headroom/FileSupport/Types.hs index 4fd1ecb..2b912c3 100644 --- a/src/Headroom/FileSupport/Types.hs +++ b/src/Headroom/FileSupport/Types.hs @@ -1,93 +1,89 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StrictData #-} -{-| -Module : Headroom.FileSupport.Types -Description : Data types for "Headroom.FileSupport" module -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX +-- | +-- Module : Headroom.FileSupport.Types +-- Description : Data types for "Headroom.FileSupport" module +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Data types for "Headroom.FileSupport" module in separated module +-- (to avoid cyclic dependencies). +module Headroom.FileSupport.Types ( + -- * Data Types + FileSupport (..) + , SyntaxAnalysis (..) -Data types for "Headroom.FileSupport" module in separated module -(to avoid cyclic dependencies). --} + -- * Smart Constructors + , defaultFileSupport -module Headroom.FileSupport.Types - ( -- * Data Types - FileSupport(..) - , SyntaxAnalysis(..) - -- * Smart Constructors - , defaultFileSupport - -- * Function Type Aliases - , ExtractTemplateDataFn - , ExtractVariablesFn - ) -where - -import Headroom.Config.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 + -- * Function Type Aliases + , ExtractTemplateDataFn + , ExtractVariablesFn +) where +import Headroom.Config.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 -- | Set of functions that every file support needs to implement. data FileSupport = FileSupport - { fsSyntaxAnalysis :: SyntaxAnalysis - , fsExtractTemplateData :: ExtractTemplateDataFn - , fsExtractVariables :: ExtractVariablesFn - , fsFileType :: FileType - } - + { fsSyntaxAnalysis :: SyntaxAnalysis + , fsExtractTemplateData :: ExtractTemplateDataFn + , fsExtractVariables :: ExtractVariablesFn + , fsFileType :: FileType + } -- | Set of functions used to analyze source code. data SyntaxAnalysis = SyntaxAnalysis - { saIsCommentStart :: Text -> Bool - , saIsCommentEnd :: Text -> Bool - } - + { 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 ExtractTemplateDataFn = + forall a. + Template a => + -- | template to use for extraction + a -> + -- | copyright header syntax + HeaderSyntax -> + -- | extracted template data + TemplateData -- | 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 - +type ExtractVariablesFn = + -- | header template + HeaderTemplate -> + -- | header position as @(startLine, endLine)@ + Maybe (Int, Int) -> + -- | analyzed source code file + SourceCode -> + -- | extracted variables + 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 - } +defaultFileSupport :: + -- | type of the source code file + FileType -> + -- | function that analyzes source code + SyntaxAnalysis -> + -- | resulting 'FileSupport' + FileSupport +defaultFileSupport fileType syntaxAnalysis = + FileSupport + { fsSyntaxAnalysis = syntaxAnalysis + , fsExtractTemplateData = const . const $ NoTemplateData + , fsExtractVariables = const . const . const $ mempty + , fsFileType = fileType + } diff --git a/src/Headroom/FileType.hs b/src/Headroom/FileType.hs index 0018a02..0416bae 100644 --- a/src/Headroom/FileType.hs +++ b/src/Headroom/FileType.hs @@ -1,75 +1,82 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-| -Module : Headroom.FileType -Description : Logic for handlig supported file types -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing functions for working with the 'FileType', such as performing -detection based on the file extension, etc. --} - -module Headroom.FileType - ( configByFileType - , fileTypeByExt - , listExtensions - ) -where - -import Headroom.Config.Types ( CtHeaderConfig - , CtHeadersConfig - , HeaderConfig(..) - , HeadersConfig(..) - ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.FileType.Types ( FileType(..) ) -import RIO -import qualified RIO.List as L +-- | +-- Module : Headroom.FileType +-- Description : Logic for handlig supported file types +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing functions for working with the 'FileType', such as performing +-- detection based on the file extension, etc. +module Headroom.FileType ( + configByFileType + , fileTypeByExt + , listExtensions +) where +import Headroom.Config.Types ( + CtHeaderConfig + , CtHeadersConfig + , HeaderConfig (..) + , HeadersConfig (..) + ) +import Headroom.Data.EnumExtra (EnumExtra (..)) +import Headroom.FileType.Types (FileType (..)) +import RIO +import qualified RIO.List as L -- | Returns 'FileType' for given file extension (without dot), using configured -- values from the 'HeadersConfig'. -fileTypeByExt :: CtHeadersConfig -- ^ license headers configuration - -> Text -- ^ file extension (without dot) - -> Maybe FileType -- ^ found 'FileType' +fileTypeByExt :: + -- | license headers configuration + CtHeadersConfig -> + -- | file extension (without dot) + Text -> + -- | found 'FileType' + Maybe FileType fileTypeByExt config ext = - L.find (elem ext . listExtensions config) (allValues @FileType) - + L.find (elem ext . listExtensions config) (allValues @FileType) -- | Lists all recognized file extensions for given 'FileType', using configured -- values from the 'HeadersConfig'. -listExtensions :: CtHeadersConfig -- ^ license headers configuration - -> FileType -- ^ 'FileType' for which to list extensions - -> [Text] -- ^ list of appropriate file extensions +listExtensions :: + -- | license headers configuration + CtHeadersConfig -> + -- | 'FileType' for which to list extensions + FileType -> + -- | list of appropriate file extensions + [Text] listExtensions config fileType = - hcFileExtensions (configByFileType config fileType) - + hcFileExtensions (configByFileType config fileType) -- | Returns the proper 'HeaderConfig' for the given 'FileType', selected -- from the 'HeadersConfig'. -configByFileType :: CtHeadersConfig -- ^ license headers configuration - -> FileType -- ^ selected 'FileType' - -> CtHeaderConfig -- ^ appropriate 'HeaderConfig' -configByFileType HeadersConfig {..} fileType = case fileType of - C -> hscC - CPP -> hscCpp - CSS -> hscCss - Dart -> hscDart - Go -> hscGo - Haskell -> hscHaskell - HTML -> hscHtml - Java -> hscJava - JS -> hscJs - Kotlin -> hscKotlin - PHP -> hscPhp - PureScript -> hscPureScript - Python -> hscPython - Rust -> hscRust - Scala -> hscScala - Shell -> hscShell +configByFileType :: + -- | license headers configuration + CtHeadersConfig -> + -- | selected 'FileType' + FileType -> + -- | appropriate 'HeaderConfig' + CtHeaderConfig +configByFileType HeadersConfig{..} fileType = case fileType of + C -> hscC + CPP -> hscCpp + CSS -> hscCss + Dart -> hscDart + Go -> hscGo + Haskell -> hscHaskell + HTML -> hscHtml + Java -> hscJava + JS -> hscJs + Kotlin -> hscKotlin + PHP -> hscPhp + PureScript -> hscPureScript + Python -> hscPython + Rust -> hscRust + Scala -> hscScala + Shell -> hscShell diff --git a/src/Headroom/FileType/Types.hs b/src/Headroom/FileType/Types.hs index feec0df..dd401e6 100644 --- a/src/Headroom/FileType/Types.hs +++ b/src/Headroom/FileType/Types.hs @@ -1,40 +1,53 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.FileType.Types -Description : Data types for "Headroom.FileType" -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types for "Headroom.FileType" modules. --} - +-- | +-- Module : Headroom.FileType.Types +-- Description : Data types for "Headroom.FileType" +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains data types for "Headroom.FileType" modules. module Headroom.FileType.Types where -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import RIO - +import Headroom.Data.EnumExtra (EnumExtra (..)) +import RIO -- | Supported type of source code file. data FileType - = C -- ^ support for /C/ programming language - | CPP -- ^ support for /C++/ programming language - | CSS -- ^ support for /CSS/ - | Dart -- ^ support for /Dart/ programming language - | Go -- ^ support for /Go/ programming language - | Haskell -- ^ support for /Haskell/ programming language - | HTML -- ^ support for /HTML/ - | Java -- ^ support for /Java/ programming language - | JS -- ^ support for /JavaScript/ programming language - | Kotlin -- ^ support for /Kotlin/ programming language - | PHP -- ^ support for /PHP/ programming language - | PureScript -- ^ support for /PureScript/ programming language - | Python -- ^ support for /Python/ programming language - | Rust -- ^ support for /Rust/ programming language - | Scala -- ^ support for /Scala/ programming language - | Shell -- ^ support for /Shell/ - deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + = -- | support for /C/ programming language + C + | -- | support for /C++/ programming language + CPP + | -- | support for /CSS/ + CSS + | -- | support for /Dart/ programming language + Dart + | -- | support for /Go/ programming language + Go + | -- | support for /Haskell/ programming language + Haskell + | -- | support for /HTML/ + HTML + | -- | support for /Java/ programming language + Java + | -- | support for /JavaScript/ programming language + JS + | -- | support for /Kotlin/ programming language + Kotlin + | -- | support for /PHP/ programming language + PHP + | -- | support for /PureScript/ programming language + PureScript + | -- | support for /Python/ programming language + Python + | -- | support for /Rust/ programming language + Rust + | -- | support for /Scala/ programming language + Scala + | -- | support for /Shell/ + Shell + deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) diff --git a/src/Headroom/Header.hs b/src/Headroom/Header.hs index cfc08e8..5c34186 100644 --- a/src/Headroom/Header.hs +++ b/src/Headroom/Header.hs @@ -1,178 +1,181 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Headroom.Header -Description : Operations with copyright/license headers -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} -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 +-- Description : Operations with copyright/license headers +-- Copyright : (c) 2019-2022 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 -module Headroom.Header - ( -- * Header Info Extraction - extractHeaderInfo - , extractHeaderTemplate - -- * License header manipulation - , addHeader - , dropHeader - , replaceHeader - -- * Copyright Header Detection - , findHeader - , findBlockHeader - , findLineHeader - , splitSource - ) -where + -- * License header manipulation + , addHeader + , dropHeader + , replaceHeader -import Headroom.Config.Types ( CtHeaderConfig - , CtHeadersConfig - , HeaderConfig(..) - , 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 + -- * Copyright Header Detection + , findHeader + , findBlockHeader + , findLineHeader + , splitSource +) where +import Headroom.Config.Types ( + CtHeaderConfig + , CtHeadersConfig + , HeaderConfig (..) + , 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 - +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 - +extractHeaderInfo :: + -- | template info + HeaderTemplate -> + -- | text used for detection + SourceCode -> + -- | resulting file info + HeaderInfo +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 :: + -- | configuration for license headers + CtHeadersConfig -> + -- | type of source code files this template is for + FileType -> + -- | parsed template + TemplateType -> + -- | resulting template info + HeaderTemplate 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) - + 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] - +addHeader :: + -- | additional info about the header + HeaderInfo -> + -- | text of the new header + Text -> + -- | source code where to add the header + SourceCode -> + -- | resulting source code with added header + SourceCode +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 :: + -- | additional info about the header + HeaderInfo -> + -- | text of the file from which to drop the header + SourceCode -> + -- | resulting text with dropped header + SourceCode +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 - + 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 :: + -- | additional info about the header + HeaderInfo -> + -- | text of the new header + Text -> + -- | text of the file where to replace the header + SourceCode -> + -- | resulting text with replaced header + SourceCode replaceHeader fileInfo header = addHeader' . dropHeader' - where - addHeader' = addHeader infoWithoutPos header - dropHeader' = dropHeader fileInfo - infoWithoutPos = fileInfo & hiHeaderPosL .~ Nothing - + 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). @@ -180,54 +183,49 @@ replaceHeader fileInfo header = addHeader' . dropHeader' -- delegates its work to either 'findBlockHeader' or 'findLineHeader'. -- -- >>> 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 -}")] +-- >>> let hc = HeaderConfig ["hs"] 0 0 0 0 [] [] (LineComment [re|^--|] Nothing) +-- >>> 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]) - +findHeader :: + -- | appropriate header configuration + CtHeaderConfig -> + -- | text in which to detect the header + SourceCode -> + -- | header position @(startLine, endLine)@ + Maybe (Int, Int) +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. --- --- >>> 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 :: + -- | starting pattern (e.g. @{\-@ or @/*@) + Regex -> + -- | ending pattern (e.g. @-\}@ or @*/@) + Regex -> + -- | source code in which to detect the header + SourceCode -> + -- | line number offset (adds to resulting position) + Int -> + -- | header position @(startLine + offset, endLine + offset)@ + Maybe (Int, Int) 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 - + 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. @@ -236,25 +234,25 @@ findBlockHeader start end sc offset = mapT2 (+ offset) <$> position -- >>> 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 pattern (e.g. @--@ or @//@) + Regex -> + -- | source code in which to detect the header + SourceCode -> + -- | line number offset (adds to resulting position) + Int -> + -- | header position @(startLine + offset, endLine + offset)@ + Maybe (Int, Int) 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 - + 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: -- @@ -279,23 +277,22 @@ findLineHeader prefix sc offset = mapT2 (+ offset) <$> position -- -- >>> 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 :: + [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 - - + 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 index f78e18b..0fd2a76 100644 --- a/src/Headroom/Header/Sanitize.hs +++ b/src/Headroom/Header/Sanitize.hs @@ -1,37 +1,33 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Header.Sanitize -Description : Logic for sanitizing license headers -Copyright : (c) 2019-2022 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.Config.Types ( HeaderSyntax(..) ) -import qualified Headroom.Data.Regex as R -import qualified Headroom.Data.Text as T -import RIO -import qualified RIO.Text as T - +-- | +-- Module : Headroom.Header.Sanitize +-- Description : Logic for sanitizing license headers +-- Copyright : (c) 2019-2022 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.Config.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 ------------------------------ @@ -44,20 +40,20 @@ import qualified RIO.Text as T -- >>> 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 :: + -- | describes comment syntax of the header + HeaderSyntax -> + -- | text containint the comment + Text -> + -- | input 'HeaderSyntax' with added prefix (if found) + HeaderSyntax 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) - + 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 @@ -67,64 +63,67 @@ findPrefix syntax text = case syntax of -- >>> 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 :: + -- | header syntax definition that may contain prefix + HeaderSyntax -> + -- | header to sanitize + Text -> + -- | sanitized header + Text sanitizeSyntax syntax = mapCommentLines syntax (process mPrefix) - where - process Nothing l = Just l - process (Just p) l | p `T.isPrefixOf` l = Just l - | otherwise = Just $ addPrefix p l - mPrefix = case syntax of - BlockComment _ _ p -> p - LineComment _ p -> p - + where + process Nothing l = Just l + process (Just p) l + | p `T.isPrefixOf` l = Just l + | otherwise = Just $ addPrefix p l + mPrefix = case syntax of + BlockComment _ _ p -> p + LineComment _ p -> p -- | Strips comment syntax from given text. -- -- >>> 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 :: + -- | copyright header syntax + HeaderSyntax -> + -- | input text from which to strip the syntax + Text -> + -- | processed text + Text stripCommentSyntax syntax = 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 - + 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 ----------------------------- addPrefix :: Text -> Text -> Text -addPrefix p l | " " `T.isSuffixOf` p || " " `T.isPrefixOf` l = p <> l - | otherwise = p <> " " <> l - - -mapCommentLines :: Foldable t - => HeaderSyntax - -> (Text -> t Text) - -> Text - -> Text +addPrefix p l + | " " `T.isSuffixOf` p || " " `T.isPrefixOf` l = p <> l + | T.null l = p + | otherwise = p <> " " <> l + +mapCommentLines :: + Foldable t => + HeaderSyntax -> + (Text -> t Text) -> + Text -> + Text mapCommentLines syntax f = T.mapLinesF $ \case - line | isCommentBody syntax line -> toList . f $ line - | otherwise -> [line] - + line + | isCommentBody syntax line -> toList . f $ line + | otherwise -> [line] isCommentBody :: HeaderSyntax -> Text -> Bool -isCommentBody (LineComment _ _ ) _ = True +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 index 60c0ab9..a9f6965 100644 --- a/src/Headroom/Header/Types.hs +++ b/src/Headroom/Header/Types.hs @@ -1,56 +1,51 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Header.Types -Description : Data types for "Headroom.Header" -Copyright : (c) 2019-2022 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.Config.Types ( CtHeaderConfig ) -import Headroom.FileSupport.TemplateData ( TemplateData ) -import Headroom.FileType.Types ( FileType ) -import Headroom.Meta ( TemplateType ) -import Headroom.Variables.Types ( Variables ) -import RIO +-- | +-- Module : Headroom.Header.Types +-- Description : Data types for "Headroom.Header" +-- Copyright : (c) 2019-2022 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.Config.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) - + { 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) + { 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/IO/FileSystem.hs b/src/Headroom/IO/FileSystem.hs index 41a48cd..c35b87f 100644 --- a/src/Headroom/IO/FileSystem.hs +++ b/src/Headroom/IO/FileSystem.hs @@ -1,136 +1,152 @@ +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -Module : Headroom.IO.FileSystem -Description : File system related IO operations -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing functions for working with the local file system, its file and -directories. --} - -module Headroom.IO.FileSystem - ( -- * Type Aliases - CreateDirectoryFn - , DoesFileExistFn - , FindFilesFn - , FindFilesByExtsFn - , FindFilesByTypesFn - , GetCurrentDirectoryFn - , GetUserDirectoryFn - , ListFilesFn - , LoadFileFn - , WriteFileFn - -- * Polymorphic Record - , FileSystem(..) - , mkFileSystem - -- * Traversing the File System - , findFiles - , findFilesByExts - , findFilesByTypes - , listFiles - , loadFile - -- * Working with Files Metadata - , fileExtension - -- * Other - , excludePaths - ) -where - -import Headroom.Config.Types ( CtHeadersConfig ) -import Headroom.Data.Regex ( Regex - , match - ) -import Headroom.FileType ( listExtensions ) -import Headroom.FileType.Types ( FileType ) -import RIO -import RIO.Directory ( createDirectoryIfMissing - , doesDirectoryExist - , doesFileExist - , getCurrentDirectory - , getDirectoryContents - , getHomeDirectory - ) -import RIO.FilePath ( isExtensionOf - , takeExtension - , () - ) -import qualified RIO.List as L -import qualified RIO.Text as T +-- | +-- Module : Headroom.IO.FileSystem +-- Description : File system related IO operations +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing functions for working with the local file system, its file and +-- directories. +module Headroom.IO.FileSystem ( + -- * Type Aliases + CreateDirectoryFn + , DoesFileExistFn + , FindFilesFn + , FindFilesByExtsFn + , FindFilesByTypesFn + , GetCurrentDirectoryFn + , GetUserDirectoryFn + , ListFilesFn + , LoadFileFn + , WriteFileFn + + -- * Polymorphic Record + , FileSystem (..) + , mkFileSystem + + -- * Traversing the File System + , findFiles + , findFilesByExts + , findFilesByTypes + , listFiles + , loadFile + + -- * Working with Files Metadata + , fileExtension + + -- * Other + , excludePaths +) where + +import Headroom.Config.Types (CtHeadersConfig) +import Headroom.Data.Regex ( + Regex + , match + ) +import Headroom.FileType (listExtensions) +import Headroom.FileType.Types (FileType) +import RIO +import RIO.Directory ( + createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , getDirectoryContents + , getHomeDirectory + ) +import RIO.FilePath ( + isExtensionOf + , takeExtension + , () + ) +import qualified RIO.List as L +import qualified RIO.Text as T -------------------------------- TYPE ALIASES -------------------------------- -- | Type of a function that creates new empty directory on the given path. -type CreateDirectoryFn m - = FilePath -- ^ path of new directory - -> m () -- ^ /IO/ action result - +type CreateDirectoryFn m = + -- | path of new directory + FilePath -> + -- | /IO/ action result + m () -- | Type of a function that returns 'True' if the argument file exists and is -- not a directory, and 'False' otherwise. -type DoesFileExistFn m - = FilePath -- ^ path to check - -> m Bool -- ^ whether the given path is existing file - +type DoesFileExistFn m = + -- | path to check + FilePath -> + -- | whether the given path is existing file + m Bool -- | Type of a function that recursively finds files on given path whose -- filename matches the predicate. -type FindFilesFn m - = FilePath -- ^ path to search - -> (FilePath -> Bool) -- ^ predicate to match filename - -> m [FilePath] -- ^ found files - +type FindFilesFn m = + -- | path to search + FilePath -> + -- | predicate to match filename + (FilePath -> Bool) -> + -- | found files + m [FilePath] -- | Type of a function that recursively finds files on given path by file -- extensions. -type FindFilesByExtsFn m - = FilePath -- ^ path to search - -> [Text] -- ^ list of file extensions (without dot) - -> m [FilePath] -- ^ list of found files - +type FindFilesByExtsFn m = + -- | path to search + FilePath -> + -- | list of file extensions (without dot) + [Text] -> + -- | list of found files + m [FilePath] -- | Type of a function that recursively find files on given path by their -- file types. -type FindFilesByTypesFn m - = CtHeadersConfig -- ^ configuration of license headers - -> [FileType] -- ^ list of file types - -> FilePath -- ^ path to search - -> m [FilePath] -- ^ list of found files - +type FindFilesByTypesFn m = + -- | configuration of license headers + CtHeadersConfig -> + -- | list of file types + [FileType] -> + -- | path to search + FilePath -> + -- | list of found files + m [FilePath] -- | Type of a function that obtains the current working directory as an -- absolute path. type GetCurrentDirectoryFn m = m FilePath - -- | Type of a function that obtains the user's home directory as an absolute -- path. type GetUserDirectoryFn m = m FilePath - -- | Type of a function that recursively find all files on given path. If file -- reference is passed instead of directory, such file path is returned. -type ListFilesFn m - = FilePath -- ^ path to search - -> m [FilePath] -- ^ list of found files +type ListFilesFn m = + -- | path to search + FilePath -> + -- | list of found files + m [FilePath] -- | Type of a function that loads file content in UTF-8 encoding. -type LoadFileFn m - = FilePath -- ^ file path - -> m Text -- ^ file content - +type LoadFileFn m = + -- | file path + FilePath -> + -- | file content + m Text -- | Type of a function that writes file content in UTF-8 encoding. -type WriteFileFn m - = FilePath -- ^ file path - -> Text -- ^ file content - -> m () -- ^ write result +type WriteFileFn m = + -- | file path + FilePath -> + -- | file content + Text -> + -- | write result + m () ----------------------------- POLYMORPHIC RECORD ----------------------------- @@ -141,46 +157,46 @@ type WriteFileFn m -- for testing, which is not as easy if you wire some of the provided functions -- directly. data FileSystem m = FileSystem - { fsCreateDirectory :: CreateDirectoryFn m - -- ^ Function that creates new empty directory on the given path. - , fsDoesFileExist :: DoesFileExistFn m - -- ^ Function that returns 'True' if the argument file exists and is not - -- a directory, and 'False' otherwise. - , fsFindFiles :: FindFilesFn m - -- ^ Function that recursively finds files on given path whose filename - -- matches the predicate. - , fsFindFilesByExts :: FindFilesByExtsFn m - -- ^ Function that recursively finds files on given path by file extensions. - , fsFindFilesByTypes :: FindFilesByTypesFn m - -- ^ Function that recursively find files on given path by their file types. - , fsGetCurrentDirectory :: GetCurrentDirectoryFn m - -- ^ Function that obtains the current working directory as an absolute path. - , fsGetUserDirectory :: GetUserDirectoryFn m - -- ^ Function that obtains the user's home directory as an absolute path. - , fsListFiles :: ListFilesFn m - -- ^ Function that recursively find all files on given path. If file reference - -- is passed instead of directory, such file path is returned. - , fsLoadFile :: LoadFileFn m - -- ^ Function that loads file content in UTF-8 encoding. - , fsWriteFile :: WriteFileFn m - -- ^ Function that writes file content in UTF-8 encoding. - } - + { fsCreateDirectory :: CreateDirectoryFn m + -- ^ Function that creates new empty directory on the given path. + , fsDoesFileExist :: DoesFileExistFn m + -- ^ Function that returns 'True' if the argument file exists and is not + -- a directory, and 'False' otherwise. + , fsFindFiles :: FindFilesFn m + -- ^ Function that recursively finds files on given path whose filename + -- matches the predicate. + , fsFindFilesByExts :: FindFilesByExtsFn m + -- ^ Function that recursively finds files on given path by file extensions. + , fsFindFilesByTypes :: FindFilesByTypesFn m + -- ^ Function that recursively find files on given path by their file types. + , fsGetCurrentDirectory :: GetCurrentDirectoryFn m + -- ^ Function that obtains the current working directory as an absolute path. + , fsGetUserDirectory :: GetUserDirectoryFn m + -- ^ Function that obtains the user's home directory as an absolute path. + , fsListFiles :: ListFilesFn m + -- ^ Function that recursively find all files on given path. If file reference + -- is passed instead of directory, such file path is returned. + , fsLoadFile :: LoadFileFn m + -- ^ Function that loads file content in UTF-8 encoding. + , fsWriteFile :: WriteFileFn m + -- ^ Function that writes file content in UTF-8 encoding. + } -- | Creates new 'FileSystem' that performs actual disk /IO/ operations. mkFileSystem :: MonadIO m => FileSystem m -mkFileSystem = FileSystem { fsCreateDirectory = createDirectoryIfMissing True - , fsDoesFileExist = doesFileExist - , fsFindFiles = findFiles - , fsFindFilesByExts = findFilesByExts - , fsFindFilesByTypes = findFilesByTypes - , fsGetCurrentDirectory = getCurrentDirectory - , fsGetUserDirectory = getHomeDirectory - , fsListFiles = listFiles - , fsLoadFile = loadFile - , fsWriteFile = writeFileUtf8 - } - +mkFileSystem = + FileSystem + { fsCreateDirectory = createDirectoryIfMissing True + , fsDoesFileExist = doesFileExist + , fsFindFiles = findFiles + , fsFindFilesByExts = findFilesByExts + , fsFindFilesByTypes = findFilesByTypes + , fsGetCurrentDirectory = getCurrentDirectory + , fsGetUserDirectory = getHomeDirectory + , fsListFiles = listFiles + , fsLoadFile = loadFile + , fsWriteFile = writeFileUtf8 + } ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -188,66 +204,64 @@ mkFileSystem = FileSystem { fsCreateDirectory = createDirectoryIfMissing True findFiles :: MonadIO m => FindFilesFn m findFiles path predicate = fmap (filter predicate) (listFiles path) - -- | Recursively finds files on given path by file extensions. findFilesByExts :: MonadIO m => FindFilesByExtsFn m findFilesByExts path exts = findFiles path predicate - where predicate p = any (`isExtensionOf` p) (fmap T.unpack exts) - + where + predicate p = any (`isExtensionOf` p) (fmap T.unpack exts) -- | Recursively find files on given path by their file types. findFilesByTypes :: MonadIO m => FindFilesByTypesFn m findFilesByTypes headersConfig types path = - findFilesByExts path (types >>= listExtensions headersConfig) - + findFilesByExts path (types >>= listExtensions headersConfig) -- | Recursively find all files on given path. If file reference is passed -- instead of directory, such file path is returned. listFiles :: MonadIO m => ListFilesFn m listFiles fileOrDir = do - isDir <- doesDirectoryExist fileOrDir - if isDir then listDirectory fileOrDir else pure [fileOrDir] - where - listDirectory dir = do - names <- getDirectoryContents dir - let filteredNames = filter (`notElem` [".", ".."]) names - paths <- forM filteredNames $ \name -> do - let path = dir name - isDirectory <- doesDirectoryExist path - if isDirectory then listFiles path else pure [path] - pure $ concat paths - + isDir <- doesDirectoryExist fileOrDir + if isDir then listDirectory fileOrDir else pure [fileOrDir] + where + listDirectory dir = do + names <- getDirectoryContents dir + let filteredNames = filter (`notElem` [".", ".."]) names + paths <- forM filteredNames $ \name -> do + let path = dir name + isDirectory <- doesDirectoryExist path + if isDirectory then listFiles path else pure [path] + pure $ concat paths -- | Returns file extension for given path (if file), or nothing otherwise. -- -- >>> fileExtension "path/to/some/file.txt" -- Just "txt" -fileExtension :: FilePath - -- ^ path from which to extract file extension - -> Maybe Text - -- ^ extracted file extension +fileExtension :: + -- | path from which to extract file extension + FilePath -> + -- | extracted file extension + Maybe Text fileExtension (takeExtension -> '.' : xs) = Just $ T.pack xs -fileExtension _ = Nothing - +fileExtension _ = Nothing -- | Loads file content in UTF8 encoding. loadFile :: MonadIO m => LoadFileFn m loadFile = readFileUtf8 - -- | 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) -- >>> excludePaths [[re|\.hidden|], [re|zzz|]] ["foo/.hidden", "test/bar", "x/zzz/e"] -- ["test/bar"] -excludePaths :: [Regex] - -- ^ patterns describing paths to exclude - -> [FilePath] - -- ^ list of file paths - -> [FilePath] - -- ^ resulting list of file paths -excludePaths _ [] = [] -excludePaths [] paths = paths +excludePaths :: + -- | patterns describing paths to exclude + [Regex] -> + -- | list of file paths + [FilePath] -> + -- | resulting list of file paths + [FilePath] +excludePaths _ [] = [] +excludePaths [] paths = paths excludePaths patterns paths = L.filter excluded paths - where excluded item = all (\p -> isNothing $ match p (T.pack item)) patterns + where + excluded item = all (\p -> isNothing $ match p (T.pack item)) patterns diff --git a/src/Headroom/IO/KVStore.hs b/src/Headroom/IO/KVStore.hs index 7833c41..de50e74 100644 --- a/src/Headroom/IO/KVStore.hs +++ b/src/Headroom/IO/KVStore.hs @@ -1,193 +1,201 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-| -Module : Headroom.IO.KVStore -Description : Key-value persistent store -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This is really simple /key-value/ persistent store that uses /SQLite/ as a -backend. Main goal is to provide /type-safe/ way how to define value keys, that -can be later used to set/put the actual value into the store. --} - -module Headroom.IO.KVStore - ( -- * Type Aliases - GetValueFn - , PutValueFn - , KVStore(..) - -- * Type Classes - , ValueCodec(..) - -- * Data Types - , ValueKey(..) - , StorePath(..) - -- * Public Functions - , inMemoryKVStore - , sqliteKVStore - , valueKey - ) -where - -import Database.Persist ( PersistStoreRead(..) - , PersistStoreWrite(..) - ) -import Database.Persist.Sqlite ( runMigrationSilent - , runSqlite - ) -import Database.Persist.TH ( mkMigrate - , mkPersist - , persistLowerCase - , share - , sqlSettings - ) -import RIO -import qualified RIO.Map as M -import qualified RIO.Text as T -import RIO.Time ( UTCTime - , defaultTimeLocale - , formatTime - , parseTimeM - ) +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.IO.KVStore +-- Description : Key-value persistent store +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This is really simple /key-value/ persistent store that uses /SQLite/ as a +-- backend. Main goal is to provide /type-safe/ way how to define value keys, that +-- can be later used to set/put the actual value into the store. +module Headroom.IO.KVStore ( + -- * Type Aliases + GetValueFn + , PutValueFn + , KVStore (..) + + -- * Type Classes + , ValueCodec (..) + + -- * Data Types + , ValueKey (..) + , StorePath (..) + + -- * Public Functions + , inMemoryKVStore + , sqliteKVStore + , valueKey +) where + +import Database.Persist ( + PersistStoreRead (..) + , PersistStoreWrite (..) + ) +import Database.Persist.Sqlite ( + runMigrationSilent + , runSqlite + ) +import Database.Persist.TH ( + mkMigrate + , mkPersist + , persistLowerCase + , share + , sqlSettings + ) +import RIO +import qualified RIO.Map as M +import qualified RIO.Text as T +import RIO.Time ( + UTCTime + , defaultTimeLocale + , formatTime + , parseTimeM + ) ------------------------------ TEMPLATE HASKELL ------------------------------ -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| StoreRecord Id Text value Text deriving Show |] - -------------------------------- TYPE ALIASES -------------------------------- -- | Gets the value for given 'ValueKey' from the store. -type GetValueFn m - = forall a - . (ValueCodec a) - => ValueKey a -- ^ key for the value - -> m (Maybe a) -- ^ value (if found) - +type GetValueFn m = + forall a. + (ValueCodec a) => + -- | key for the value + ValueKey a -> + -- | value (if found) + m (Maybe a) -- | Puts the value for given 'ValueKey' into the store. -type PutValueFn m - = forall a - . (ValueCodec a) - => ValueKey a -- ^ key for the value - -> a -- ^ value to put into store - -> m () -- ^ operation result - +type PutValueFn m = + forall a. + (ValueCodec a) => + -- | key for the value + ValueKey a -> + -- | value to put into store + a -> + -- | operation result + m () ----------------------------- POLYMORPHIC RECORD ----------------------------- -- | /Polymorphic record/ composed of /key-value/ store operations, allowing to -- abstract over concrete implementation without (ab)using /type classes/. data KVStore m = KVStore - { kvGetValue :: GetValueFn m - , kvPutValue :: PutValueFn m - } - + { kvGetValue :: GetValueFn m + , kvPutValue :: PutValueFn m + } -- | Constructs persistent instance of 'KVStore' that uses /SQLite/ as a backend. -sqliteKVStore :: MonadIO m - => StorePath -- ^ path of the store location - -> KVStore m -- ^ store instance +sqliteKVStore :: + MonadIO m => + -- | path of the store location + StorePath -> + -- | store instance + KVStore m sqliteKVStore sp = - KVStore { kvGetValue = getValueSQLite sp, kvPutValue = putValueSQLite sp } - + KVStore{kvGetValue = getValueSQLite sp, kvPutValue = putValueSQLite sp} -- | Constructs non-persistent in-memory instance of 'KVStore'. inMemoryKVStore :: MonadIO m => m (KVStore m) inMemoryKVStore = do - ref <- newIORef M.empty - pure KVStore { kvGetValue = getValueInMemory ref - , kvPutValue = putValueInMemory ref - } + ref <- newIORef M.empty + pure + KVStore + { kvGetValue = getValueInMemory ref + , kvPutValue = putValueInMemory ref + } -------------------------------- TYPE CLASSES -------------------------------- -- | Represents way how to encode/decode concrete types into textual -- representation used by the store to hold values. class ValueCodec a where - - -- | Encodes value into textual representation. - encodeValue :: a -- ^ value to encode - -> Text -- ^ textual representation - - - -- | Decodes value from textual representation. - decodeValue :: Text -- ^ value to decode - -> Maybe a -- ^ decoded value (if available) - + -- | Encodes value into textual representation. + encodeValue :: + -- | value to encode + a -> + -- | textual representation + Text + + -- | Decodes value from textual representation. + decodeValue :: + -- | value to decode + Text -> + -- | decoded value (if available) + Maybe a instance ValueCodec Text where - encodeValue = id - decodeValue = Just + encodeValue = id + decodeValue = Just instance ValueCodec UTCTime where - encodeValue = T.pack . formatTime defaultTimeLocale "%FT%T%Q" - decodeValue = parseTimeM True defaultTimeLocale "%FT%T%Q" . T.unpack + encodeValue = T.pack . formatTime defaultTimeLocale "%FT%T%Q" + decodeValue = parseTimeM True defaultTimeLocale "%FT%T%Q" . T.unpack --------------------------------- DATA TYPES --------------------------------- -- | /Type-safe/ representation of the key for specific value. newtype ValueKey a = ValueKey Text deriving (Eq, Show) - -- | Constructor function for 'ValueKey'. valueKey :: Text -> ValueKey a valueKey = ValueKey - -- | Path to the store (e.g. path of the /SQLite/ database on filesystem). newtype StorePath = StorePath Text deriving (Eq, Show) - ------------------------------ PRIVATE FUNCTIONS ----------------------------- getValueInMemory :: MonadIO m => IORef (Map Text Text) -> GetValueFn m getValueInMemory ref (ValueKey key) = do - storeMap <- readIORef ref - pure $ M.lookup key storeMap >>= decodeValue - + storeMap <- readIORef ref + pure $ M.lookup key storeMap >>= decodeValue putValueInMemory :: MonadIO m => IORef (Map Text Text) -> PutValueFn m putValueInMemory ref (ValueKey key) value = do - modifyIORef ref $ M.insert key (encodeValue value) - pure () - + modifyIORef ref $ M.insert key (encodeValue value) + pure () getValueSQLite :: MonadIO m => StorePath -> GetValueFn m getValueSQLite (StorePath path) (ValueKey key) = do - liftIO . runSqlite path $ do - _ <- runMigrationSilent migrateAll - maybeValue <- get $ StoreRecordKey key - case maybeValue of - Just (StoreRecord v) -> pure . decodeValue $ v - Nothing -> pure Nothing - + liftIO . runSqlite path $ do + _ <- runMigrationSilent migrateAll + maybeValue <- get $ StoreRecordKey key + case maybeValue of + Just (StoreRecord v) -> pure . decodeValue $ v + Nothing -> pure Nothing putValueSQLite :: MonadIO m => StorePath -> PutValueFn m putValueSQLite (StorePath path) (ValueKey key) value = do - liftIO . runSqlite path $ do - _ <- runMigrationSilent migrateAll - repsert (StoreRecordKey key) (StoreRecord $ encodeValue value) + liftIO . runSqlite path $ do + _ <- runMigrationSilent migrateAll + repsert (StoreRecordKey key) (StoreRecord $ encodeValue value) diff --git a/src/Headroom/IO/Network.hs b/src/Headroom/IO/Network.hs index 93d7b6c..786ca6c 100644 --- a/src/Headroom/IO/Network.hs +++ b/src/Headroom/IO/Network.hs @@ -1,151 +1,155 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Headroom.IO.Network -Description : Network related IO operations -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing support to perform selected network IO operations, such as -downloading file content, etc. --} - -module Headroom.IO.Network - ( -- * Type Aliases - DownloadContentFn - -- * Polymorphic Record - , Network(..) - , mkNetwork - -- * Network IO operations - , downloadContent - , -- * Error Data Types - NetworkError(..) - ) -where - -import Data.String.Interpolate ( i ) -import Headroom.Meta ( buildVersion - , productName - , productVendor - ) -import Headroom.Meta.Version ( printVersion ) -import Headroom.Types ( fromHeadroomError - , toHeadroomError - ) -import qualified Network.HTTP.Client as HC -import Network.HTTP.Req ( BsResponse - , GET(GET) - , HttpException(..) - , MonadHttp - , NoReqBody(NoReqBody) - , bsResponse - , defaultHttpConfig - , header - , req - , responseBody - , runReq - , useURI - ) -import qualified Network.HTTP.Req as Req -import qualified Network.HTTP.Types.Status as HC -import RIO -import qualified RIO.Text as T -import qualified Text.URI as URI -import Text.URI ( URI ) +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.IO.Network +-- Description : Network related IO operations +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing support to perform selected network IO operations, such as +-- downloading file content, etc. +module Headroom.IO.Network ( + -- * Type Aliases + DownloadContentFn + + -- * Polymorphic Record + , Network (..) + , mkNetwork + + -- * Network IO operations + , downloadContent + + -- * Error Data Types + , NetworkError (..) +) where + +import Data.String.Interpolate (i) +import Headroom.Meta ( + buildVersion + , productName + , productVendor + ) +import Headroom.Meta.Version (printVersion) +import Headroom.Types ( + fromHeadroomError + , toHeadroomError + ) +import qualified Network.HTTP.Client as HC +import Network.HTTP.Req ( + BsResponse + , GET (GET) + , HttpException (..) + , MonadHttp + , NoReqBody (NoReqBody) + , bsResponse + , defaultHttpConfig + , header + , req + , responseBody + , runReq + , useURI + ) +import qualified Network.HTTP.Req as Req +import qualified Network.HTTP.Types.Status as HC +import RIO +import qualified RIO.Text as T +import Text.URI (URI) +import qualified Text.URI as URI -------------------------------- TYPE ALIASES -------------------------------- -- | Type of a function that returns content of remote resource. -type DownloadContentFn m - = URI -- ^ /URI/ of remote resource - -> m ByteString -- ^ downloaded content - +type DownloadContentFn m = + -- | /URI/ of remote resource + URI -> + -- | downloaded content + m ByteString ----------------------------- POLYMORPHIC RECORD ----------------------------- -- | Polymorphic record of functions performing network IO operations. data Network m = Network - { nDownloadContent :: DownloadContentFn m -- ^ downloads remote content - } - + { nDownloadContent :: DownloadContentFn m + -- ^ downloads remote content + } -- | Constructs new 'Network' that performs real network /IO/ operations. mkNetwork :: MonadIO m => Network m -mkNetwork = Network { nDownloadContent = downloadContent } - +mkNetwork = Network{nDownloadContent = downloadContent} ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Downloads content of remote resource as 'ByteString'. Note that only -- @http@ and @https@ protocols are supported at this moment. -downloadContent :: MonadIO m - => URI -- ^ /URI/ of remote resource - -> m ByteString -- ^ downloaded content +downloadContent :: + MonadIO m => + -- | /URI/ of remote resource + URI -> + -- | downloaded content + m ByteString downloadContent uri = runReq defaultHttpConfig $ do - response <- httpGet uri - pure $ responseBody response + response <- httpGet uri + pure $ responseBody response ------------------------------ PRIVATE FUNCTIONS ----------------------------- headers :: Req.Option scheme headers = header "User-Agent" $ encodeUtf8 ua - where - ua = productVendor <> "/" <> productName <> "-" <> printVersion buildVersion - + where + ua = productVendor <> "/" <> productName <> "-" <> printVersion buildVersion httpGet :: (MonadHttp m, MonadThrow m, MonadUnliftIO m) => URI -> m BsResponse httpGet uri = do - urlE <- maybe (throwM $ InvalidURL uri) pure (useURI uri) - eitherRes <- case urlE of - Left url -> doGet $ fst url - Right url -> doGet $ fst url - case eitherRes of - Left err -> handleHttpException uri err - Right res -> pure res - where - doGet u = try @_ @HttpException $ req GET u NoReqBody bsResponse headers - + urlE <- maybe (throwM $ InvalidURL uri) pure (useURI uri) + eitherRes <- case urlE of + Left url -> doGet $ fst url + Right url -> doGet $ fst url + case eitherRes of + Left err -> handleHttpException uri err + Right res -> pure res + where + doGet u = try @_ @HttpException $ req GET u NoReqBody bsResponse headers handleHttpException :: MonadThrow m => URI -> HttpException -> m BsResponse handleHttpException uri ex = case ex of - VanillaHttpException (HC.HttpExceptionRequest _ c) -> case c of - HC.ConnectionFailure ex' -> - throwM $ ConnectionFailure uri (T.pack $ displayException ex') - HC.StatusCodeException response _ -> - let code = HC.statusCode . HC.responseStatus $ response - message = HC.statusMessage . HC.responseStatus $ response - in throwM $ InvalidStatus uri code (decodeUtf8Lenient message) + VanillaHttpException (HC.HttpExceptionRequest _ c) -> case c of + HC.ConnectionFailure ex' -> + throwM $ ConnectionFailure uri (T.pack $ displayException ex') + HC.StatusCodeException response _ -> + let code = HC.statusCode . HC.responseStatus $ response + message = HC.statusMessage . HC.responseStatus $ response + in throwM $ InvalidStatus uri code (decodeUtf8Lenient message) + _ -> throwM ex _ -> throwM ex - _ -> throwM ex --------------------------------- ERROR TYPES -------------------------------- -- | Error related to network operations. data NetworkError - = ConnectionFailure URI Text -- ^ connection failure - | InvalidStatus URI Int Text -- ^ invalid response status - | InvalidURL URI -- ^ given /URI/ is not valid - deriving (Eq, Show) - + = -- | connection failure + ConnectionFailure URI Text + | -- | invalid response status + InvalidStatus URI Int Text + | -- | given /URI/ is not valid + InvalidURL URI + deriving (Eq, Show) instance Exception NetworkError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: NetworkError -> String displayException' = \case - ConnectionFailure uri ex -> [i|Error connecting to #{URI.render uri}: #{ex}|] - InvalidStatus uri status message -> - [i|Error downloading #{URI.render uri}: #{status} #{message}|] - InvalidURL uri -> [i|Cannot build URL from input URI: #{URI.render uri}|] + ConnectionFailure uri ex -> [i|Error connecting to #{URI.render uri}: #{ex}|] + InvalidStatus uri status message -> + [i|Error downloading #{URI.render uri}: #{status} #{message}|] + InvalidURL uri -> [i|Cannot build URL from input URI: #{URI.render uri}|] diff --git a/src/Headroom/Meta.hs b/src/Headroom/Meta.hs index 4048d59..087fc8d 100644 --- a/src/Headroom/Meta.hs +++ b/src/Headroom/Meta.hs @@ -1,97 +1,85 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -{-| -Module : Headroom.Meta -Description : Application metadata (name, vendor, etc.) -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing application metadata, such as application name, vendor, -version, etc. --} - -module Headroom.Meta - ( TemplateType - , buildVersion - , configBreakingChanges - , configFileName - , cacheFileName - , globalConfigDirName - , globalConfigFileName - , productDesc - , productInfo - , productName - , productVendor - , webDoc - , webDocConfigCurr - , webDocMigration - , webRepo - ) -where - -import Data.Version ( showVersion ) -import Headroom.Meta.Version ( Version(..) - , parseVersion - , printVersion - , pvp - ) -import Headroom.Template.Mustache ( Mustache ) -import Paths_headroom ( version ) -import RIO -import RIO.Partial ( fromJust ) -import qualified RIO.Text as T +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.Meta +-- Description : Application metadata (name, vendor, etc.) +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing application metadata, such as application name, vendor, +-- version, etc. +module Headroom.Meta ( + TemplateType + , buildVersion + , configBreakingChanges + , configFileName + , cacheFileName + , globalConfigDirName + , globalConfigFileName + , productDesc + , productInfo + , productName + , productVendor + , webDoc + , webDocConfigCurr + , webDocMigration + , webRepo +) where + +import Data.Version (showVersion) +import Headroom.Meta.Version ( + Version (..) + , parseVersion + , printVersion + , pvp + ) +import Headroom.Template.Mustache (Mustache) +import Paths_headroom (version) +import RIO +import RIO.Partial (fromJust) +import qualified RIO.Text as T -- | Type of the template format used for license headers. type TemplateType = Mustache - -- | Application version, as specified in @headroom.cabal@ file. 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" - -- | Name of the global configuration directory globalConfigDirName :: IsString a => a globalConfigDirName = ".headroom" - -- | Name of the YAML global configuration file. globalConfigFileName :: IsString a => a globalConfigFileName = "global-config.yaml" - -- | Name of the global cache file. cacheFileName :: IsString a => a cacheFileName = "cache.sqlite" - -- | Full product description. productDesc :: Text productDesc = "manage your source code license headers" - -- | Product info. productInfo :: Text productInfo = - mconcat [productName, ", v", printVersion buildVersion, " :: ", webRepo] - + mconcat [productName, ", v", printVersion buildVersion, " :: ", webRepo] -- | Product name. productName :: Text @@ -105,17 +93,14 @@ productVendor = "norcane" 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 index 0ccdd8e..7ad0c94 100644 --- a/src/Headroom/Meta/Version.hs +++ b/src/Headroom/Meta/Version.hs @@ -1,73 +1,69 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskellQuotes #-} - -{-| -Module : Headroom.Meta.Version -Description : Type safe representation of Haskell PVP version -Copyright : (c) 2019-2022 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 - +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Meta.Version +-- Description : Type safe representation of Haskell PVP version +-- Copyright : (c) 2019-2022 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) - + { 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 - + 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 - + parseJSON (String s) = maybe (error . errorMsg $ s) pure (parseVersion s) + parseJSON other = error . errorMsg . tshow $ other ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -75,29 +71,30 @@ instance FromJSON Version where -- -- >>> 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 :: + -- | input text to parse version from + Text -> + -- | parsed 'Version' + Maybe Version parseVersion raw = do - groups <- match [re|^v?([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$|] raw - check (mapMaybe T.read groups) - where - check [ma1, ma2, mi, p] = Just $ Version ma1 ma2 mi p - check _ = Nothing - + groups <- match [re|^v?([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$|] raw + check (mapMaybe 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' to print + Version -> + -- | textual representation + Text printVersion (Version ma1 ma2 mi p) = T.intercalate "." chunks - where chunks = tshow <$> [ma1, ma2, mi, p] - + where + chunks = tshow <$> [ma1, ma2, mi, p] -- | Similar to 'printVersion', but adds the @v@ prefix in front of the version -- number. @@ -107,33 +104,35 @@ printVersion (Version ma1 ma2 mi p) = T.intercalate "." chunks 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 - +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 + 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')." - ] +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/PostProcess.hs b/src/Headroom/PostProcess.hs index 9ef5116..f43f4a2 100644 --- a/src/Headroom/PostProcess.hs +++ b/src/Headroom/PostProcess.hs @@ -1,170 +1,168 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Headroom.PostProcess -Description : Support for /post-processors/ -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -/Post-processing functions/ are basically functions that allows to post-process -already rendered /license headers/. This is useful to perform some additional -operations such as some sort of text alignment, update some parts of the header, -etc. --} - -module Headroom.PostProcess - ( postProcess - , configuredPostProcess - , postProcessHeader - -- * Environment Data Types - , ConfiguredEnv(..) - , mkConfiguredEnv - ) -where - -import Headroom.Config.Types ( CtPostProcessConfigs - , PostProcessConfig(..) - , PostProcessConfigs(..) - , UpdateCopyrightConfig(..) - ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.PostProcess.Types ( PostProcess(..) ) -import Headroom.PostProcess.UpdateCopyright - ( SelectedAuthors(..) - , UpdateCopyrightMode(..) - , updateCopyright - ) -import Headroom.Template ( Template(..) ) -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -import Headroom.Types ( CurrentYear(..) ) -import Headroom.Variables.Types ( Variables(..) ) -import Lens.Micro ( traverseOf ) -import RIO - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.PostProcess +-- Description : Support for /post-processors/ +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- /Post-processing functions/ are basically functions that allows to post-process +-- already rendered /license headers/. This is useful to perform some additional +-- operations such as some sort of text alignment, update some parts of the header, +-- etc. +module Headroom.PostProcess ( + postProcess + , configuredPostProcess + , postProcessHeader + + -- * Environment Data Types + , ConfiguredEnv (..) + , mkConfiguredEnv +) where + +import Headroom.Config.Types ( + CtPostProcessConfigs + , PostProcessConfig (..) + , PostProcessConfigs (..) + , UpdateCopyrightConfig (..) + ) +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Lens ( + suffixLenses + , suffixLensesFor + ) +import Headroom.PostProcess.Types (PostProcess (..)) +import Headroom.PostProcess.UpdateCopyright ( + SelectedAuthors (..) + , UpdateCopyrightMode (..) + , updateCopyright + ) +import Headroom.Template (Template (..)) +import Headroom.Template.TemplateRef (TemplateRef (..)) +import Headroom.Types (CurrentYear (..)) +import Headroom.Variables.Types (Variables (..)) +import Lens.Micro (traverseOf) +import RIO suffixLenses ''PostProcessConfigs suffixLenses ''UpdateCopyrightConfig suffixLensesFor ["ppcConfig"] ''PostProcessConfig - -- | Environemnt data type for the composed /post-processor/ -- ('configuredPostProcess'). data ConfiguredEnv = ConfiguredEnv - { ceCurrentYear :: CurrentYear - -- ^ current year - , cePostProcessConfigs :: CtPostProcessConfigs - -- ^ configuration of /post-processor/ - , ceUpdateCopyrightMode :: UpdateCopyrightMode - -- ^ mode used by the 'updateCopyright' /post-processor/ - } - deriving (Eq, Show) + { ceCurrentYear :: CurrentYear + -- ^ current year + , cePostProcessConfigs :: CtPostProcessConfigs + -- ^ configuration of /post-processor/ + , ceUpdateCopyrightMode :: UpdateCopyrightMode + -- ^ mode used by the 'updateCopyright' /post-processor/ + } + deriving (Eq, Show) suffixLensesFor ["ceCurrentYear", "ceUpdateCopyrightMode"] ''ConfiguredEnv instance Has CurrentYear ConfiguredEnv where - hasLens = ceCurrentYearL + hasLens = ceCurrentYearL instance Has UpdateCopyrightMode ConfiguredEnv where - hasLens = ceUpdateCopyrightModeL - + hasLens = ceUpdateCopyrightModeL -- | Constructor function for 'ConfiguredEnv' data type. This function takes -- 'Variables' as argument, because it performs template compilation on -- selected fields of 'CtPostProcessConfigs'. -mkConfiguredEnv :: forall a m - . (Template a, MonadThrow m) - => CurrentYear - -- ^ current year - -> Variables - -- ^ template variables - -> CtPostProcessConfigs - -- ^ configuration for /post-processors/ - -> m ConfiguredEnv - -- ^ environment data type +mkConfiguredEnv :: + forall a m. + (Template a, MonadThrow m) => + -- | current year + CurrentYear -> + -- | template variables + Variables -> + -- | configuration for /post-processors/ + CtPostProcessConfigs -> + -- | environment data type + m ConfiguredEnv mkConfiguredEnv ceCurrentYear vars configs = do - cePostProcessConfigs <- compileTemplates @a vars configs - let ceUpdateCopyrightMode = mode cePostProcessConfigs - pure ConfiguredEnv { .. } - where - authorsL = ppcsUpdateCopyrightL . ppcConfigL . uccSelectedAuthorsL - mode = \configs' -> maybe UpdateAllAuthors - (UpdateSelectedAuthors . SelectedAuthors) - (configs' ^. authorsL) - + cePostProcessConfigs <- compileTemplates @a vars configs + let ceUpdateCopyrightMode = mode cePostProcessConfigs + pure ConfiguredEnv{..} + where + authorsL = ppcsUpdateCopyrightL . ppcConfigL . uccSelectedAuthorsL + mode = \configs' -> + maybe + UpdateAllAuthors + (UpdateSelectedAuthors . SelectedAuthors) + (configs' ^. authorsL) -- | Runs the /post-processing function/ using the given /environment/ and text -- of rendered /license header/ as input. -postProcess :: PostProcess env - -- ^ /post-processor/ to run - -> env - -- ^ environment value - -> Text - -- ^ text of rendered /license header/ - -> Text - -- ^ processed text of /license header/ +postProcess :: + -- | /post-processor/ to run + PostProcess env -> + -- | environment value + env -> + -- | text of rendered /license header/ + Text -> + -- | processed text of /license header/ + Text postProcess (PostProcess fn) env input = runReader (fn input) env - -- | Composition of various /post-processors/, which environment is -- based on /YAML/ configuration and which can be enabled/disabled to fit -- end user's needs. -configuredPostProcess :: (Has CurrentYear env, Has UpdateCopyrightMode env) - => CtPostProcessConfigs - -- ^ configuration of /post-processors/ - -> PostProcess env - -- ^ composed /post-processor/ -configuredPostProcess PostProcessConfigs {..} = mconcat - [ifEnabled ppcsUpdateCopyright updateCopyright] - where - ifEnabled PostProcessConfig {..} fn | ppcEnabled = fn - | otherwise = mempty - +configuredPostProcess :: + (Has CurrentYear env, Has UpdateCopyrightMode env) => + -- | configuration of /post-processors/ + CtPostProcessConfigs -> + -- | composed /post-processor/ + PostProcess env +configuredPostProcess PostProcessConfigs{..} = + mconcat + [ifEnabled ppcsUpdateCopyright updateCopyright] + where + ifEnabled PostProcessConfig{..} fn + | ppcEnabled = fn + | otherwise = mempty -- | Takes already rendered /license header/ and post-process it based on the -- given configuration. -postProcessHeader :: ConfiguredEnv - -- ^ configuration used to define post-processing behaviour - -> Text - -- ^ rendered text of /license header/ - -> Text - -- ^ post-processed text of /license header/ +postProcessHeader :: + -- | configuration used to define post-processing behaviour + ConfiguredEnv -> + -- | rendered text of /license header/ + Text -> + -- | post-processed text of /license header/ + Text postProcessHeader env = - postProcess (configuredPostProcess (cePostProcessConfigs env)) env - + postProcess (configuredPostProcess (cePostProcessConfigs env)) env ------------------------------ PRIVATE FUNCTIONS ----------------------------- -compileTemplates :: forall a m - . (Template a, MonadThrow m) - => Variables - -> CtPostProcessConfigs - -> m CtPostProcessConfigs +compileTemplates :: + forall a m. + (Template a, MonadThrow m) => + Variables -> + CtPostProcessConfigs -> + m CtPostProcessConfigs compileTemplates vars configs = configs & traverseOf authorsL compileAuthors' - where - authorsL = ppcsUpdateCopyrightL . ppcConfigL . uccSelectedAuthorsL - compileAuthors' = mapM . mapM $ compileAuthor - compileAuthor = \author -> do - parsed <- parseTemplate @a (InlineRef author) author - renderTemplate vars parsed - - - - + where + authorsL = ppcsUpdateCopyrightL . ppcConfigL . uccSelectedAuthorsL + compileAuthors' = mapM . mapM $ compileAuthor + compileAuthor = \author -> do + parsed <- parseTemplate @a (InlineRef author) author + renderTemplate vars parsed diff --git a/src/Headroom/PostProcess/Types.hs b/src/Headroom/PostProcess/Types.hs index be1fed3..09f3f63 100644 --- a/src/Headroom/PostProcess/Types.hs +++ b/src/Headroom/PostProcess/Types.hs @@ -1,25 +1,21 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.PostProcess.Types -Description : Data types for /post-processing/ -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types and /type class/ instances for the -/post-processing/ functions. --} - -module Headroom.PostProcess.Types - ( PostProcess(..) - ) -where - -import RIO +-- | +-- Module : Headroom.PostProcess.Types +-- Description : Data types for /post-processing/ +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains data types and /type class/ instances for the +-- /post-processing/ functions. +module Headroom.PostProcess.Types ( + PostProcess (..) +) where +import RIO -- | Definition of /post-processor/, i.e. function, that is applied to -- already rendered /license header/, performs some logic and returns modified @@ -43,7 +39,7 @@ import RIO newtype PostProcess env = PostProcess (Text -> Reader env Text) instance Semigroup (PostProcess env) where - PostProcess fnX <> PostProcess fnY = PostProcess $ fnX >=> fnY + PostProcess fnX <> PostProcess fnY = PostProcess $ fnX >=> fnY instance Monoid (PostProcess env) where - mempty = PostProcess $ \input -> pure input + mempty = PostProcess $ \input -> pure input diff --git a/src/Headroom/PostProcess/UpdateCopyright.hs b/src/Headroom/PostProcess/UpdateCopyright.hs index 934eb68..a3c71f7 100644 --- a/src/Headroom/PostProcess/UpdateCopyright.hs +++ b/src/Headroom/PostProcess/UpdateCopyright.hs @@ -1,61 +1,61 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.PostProcess.UpdateCopyright -Description : /Post-processor/ for updating years in copyrights -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides functionality for updating years in copyright statements -in already rendered /license headers/. --} - -module Headroom.PostProcess.UpdateCopyright - ( -- * Data Types - SelectedAuthors(..) - , UpdateCopyrightMode(..) - -- * Header Functions - , updateCopyright - -- * Helper Functions - , updateYears - ) -where - -import Data.String.Interpolate ( i ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Regex ( re - , replace - ) -import Headroom.Data.Text ( mapLines - , read - ) -import Headroom.PostProcess.Types ( PostProcess(..) ) -import Headroom.Types ( CurrentYear(..) ) -import RIO -import qualified RIO.NonEmpty as NE -import qualified RIO.Text as T +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.PostProcess.UpdateCopyright +-- Description : /Post-processor/ for updating years in copyrights +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides functionality for updating years in copyright statements +-- in already rendered /license headers/. +module Headroom.PostProcess.UpdateCopyright ( + -- * Data Types + SelectedAuthors (..) + , UpdateCopyrightMode (..) + + -- * Header Functions + , updateCopyright + + -- * Helper Functions + , updateYears +) where + +import Data.String.Interpolate (i) +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Regex ( + re + , replace + ) +import Headroom.Data.Text ( + mapLines + , read + ) +import Headroom.PostProcess.Types (PostProcess (..)) +import Headroom.Types (CurrentYear (..)) +import RIO +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T --------------------------------- DATA TYPES --------------------------------- -- | Non-empty list of authors for which to update years in their copyrights. newtype SelectedAuthors = SelectedAuthors (NonEmpty Text) deriving (Eq, Show) - -- | Mode that changes behaviour of the 'updateCopyright' function. data UpdateCopyrightMode - = UpdateAllAuthors -- ^ updates years in copyrights for all authors - | UpdateSelectedAuthors SelectedAuthors -- ^ updates years in copyrights only for selected authors - deriving (Eq, Show) - + = -- | updates years in copyrights for all authors + UpdateAllAuthors + | -- | updates years in copyrights only for selected authors + UpdateSelectedAuthors SelectedAuthors + deriving (Eq, Show) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -65,19 +65,20 @@ data UpdateCopyrightMode -- = Reader Environment Parameters -- ['CurrentYear'] value of the current year -- ['UpdateCopyrightMode'] mode specifying the behaviour of the updater -updateCopyright :: (Has CurrentYear env, Has UpdateCopyrightMode env) - => PostProcess env +updateCopyright :: + (Has CurrentYear env, Has UpdateCopyrightMode env) => + PostProcess env updateCopyright = PostProcess $ \input -> do - currentYear <- viewL - mode <- viewL - pure $ mapLines (update mode currentYear) input - where - update mode year line | shouldUpdate mode line = updateYears year line - | otherwise = line - shouldUpdate UpdateAllAuthors _ = True - shouldUpdate (UpdateSelectedAuthors (SelectedAuthors authors)) input = - any (`T.isInfixOf` input) (NE.toList authors) - + currentYear <- viewL + mode <- viewL + pure $ mapLines (update mode currentYear) input + where + update mode year line + | shouldUpdate mode line = updateYears year line + | otherwise = line + shouldUpdate UpdateAllAuthors _ = True + shouldUpdate (UpdateSelectedAuthors (SelectedAuthors authors)) input = + any (`T.isInfixOf` input) (NE.toList authors) -- | Updates years and years ranges in given text. -- @@ -92,24 +93,27 @@ updateCopyright = PostProcess $ \input -> do -- -- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2019" -- "Copyright (c) 2018-2020" -updateYears :: CurrentYear -- ^ current year - -> Text -- ^ text to update - -> Text -- ^ text with updated years +updateYears :: + -- | current year + CurrentYear -> + -- | text to update + Text -> + -- | text with updated years + Text updateYears cy = replace [re|(\d{4})(?:-)?(\d{4})?|] go - where - go _ [r1] | (Just y1) <- read r1 = bumpYear cy y1 - go _ rs@[_, _] | [Just y1, Just y2] <- read <$> rs = bumpRange cy y1 y2 - go other _ = other - + where + go _ [r1] | (Just y1) <- read r1 = bumpYear cy y1 + go _ rs@[_, _] | [Just y1, Just y2] <- read <$> rs = bumpRange cy y1 y2 + go other _ = other ------------------------------ PRIVATE FUNCTIONS ----------------------------- bumpYear :: CurrentYear -> Integer -> Text -bumpYear (CurrentYear cy) y | y >= cy = tshow y - | otherwise = [i|#{y}-#{cy}|] - +bumpYear (CurrentYear cy) y + | y >= cy = tshow y + | otherwise = [i|#{y}-#{cy}|] bumpRange :: CurrentYear -> Integer -> Integer -> Text -bumpRange (CurrentYear cy) y1 y2 | y2 >= cy = [i|#{y1}-#{y2}|] - | otherwise = [i|#{y1}-#{cy}|] - +bumpRange (CurrentYear cy) y1 y2 + | y2 >= cy = [i|#{y1}-#{y2}|] + | otherwise = [i|#{y1}-#{cy}|] diff --git a/src/Headroom/SourceCode.hs b/src/Headroom/SourceCode.hs index f6831af..b941e00 100644 --- a/src/Headroom/SourceCode.hs +++ b/src/Headroom/SourceCode.hs @@ -1,70 +1,71 @@ -{-# LANGUAGE DerivingStrategies #-} +{-# 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-2022 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 - +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.SourceCode +-- Description : Type safe representation of analyzed source code +-- Copyright : (c) 2019-2022 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) + = -- | Line of code + Code + | -- | Line of comment + 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) - + = SourceCode [CodeLine] + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -72,86 +73,88 @@ newtype SourceCode -- 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 :: + -- | initial state of analyzing function + a -> + -- | function that analyzes currently processed line + (Text -> State a LineType) -> + -- | raw source code to analyze + Text -> + -- | analyzed 'SourceCode' + 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 :: + -- | source code to convert back to plain text + SourceCode -> + -- | resulting plain text + 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 :: + -- | predicate (and transform) function + (CodeLine -> Maybe a) -> + -- | source code to search in + SourceCode -> + -- | first matching line (if found) + Maybe (Int, a) 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) - + 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 :: + -- | predicate (and transform) function + (CodeLine -> Maybe a) -> + -- | source code to search in + SourceCode -> + -- | last matching line (if found) + Maybe (Int, a) lastMatching f sc = - let matching = firstMatching f . inner @_ @[CodeLine] reverse $ sc - lastIdx = length (coerce sc :: [CodeLine]) - 1 - in fmap (first (lastIdx -)) matching - + 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 :: + -- | source code to strip + SourceCode -> + -- | stripped source code + SourceCode 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 :: + -- | source code to strip + SourceCode -> + -- | stripped source code + SourceCode 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 :: + -- | index of first line to be included into the snippet + Int -> + -- | index of the first line after the snippet + Int -> + -- | source code to cut + SourceCode -> + -- | cut snippet + SourceCode cut s e = inner @_ @[CodeLine] (L.take (e - s) . L.drop s) diff --git a/src/Headroom/Template.hs b/src/Headroom/Template.hs index 0e39f86..f00d16e 100644 --- a/src/Headroom/Template.hs +++ b/src/Headroom/Template.hs @@ -1,86 +1,84 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Template -Description : Extensible templating support -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing interface for working with template files in extensible way. -Supported template is represented by the 'Template' /type class/. --} - -module Headroom.Template - ( -- * Extendable Template Support - Template(..) - -- * Helper Functions - , emptyTemplate - -- * Error Data Types - , TemplateError(..) - ) -where - -import Data.String.Interpolate ( iii ) -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -import Headroom.Types ( fromHeadroomError - , toHeadroomError - ) -import Headroom.Variables.Types ( Variables(..) ) -import RIO -import qualified RIO.Text as T - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Template +-- Description : Extensible templating support +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing interface for working with template files in extensible way. +-- Supported template is represented by the 'Template' /type class/. +module Headroom.Template ( + -- * Extendable Template Support + Template (..) + + -- * Helper Functions + , emptyTemplate + + -- * Error Data Types + , TemplateError (..) +) where + +import Data.String.Interpolate (iii) +import Headroom.Template.TemplateRef (TemplateRef (..)) +import Headroom.Types ( + fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types (Variables (..)) +import RIO +import qualified RIO.Text as T -- | /Type class/ representing supported template file. class Template a where - - -- | Returns list of supported file extensions for this template type. - templateExtensions :: NonEmpty Text - -- ^ list of supported file extensions - - - -- | Parses template from given raw text. - parseTemplate :: MonadThrow m - => TemplateRef - -- ^ reference to template source - -> Text - -- ^ raw template text - -> m a - -- ^ parsed template - - - -- | Renders parsed template and replaces all variables with actual values. - renderTemplate :: MonadThrow m - => Variables - -- ^ values of variables to replace - -> a - -- ^ parsed template to render - -> m Text - -- ^ rendered template text - - - -- | Returns the raw text of the template, same that has been parsed by - -- 'parseTemplate' method. - rawTemplate :: a - -- ^ template for which to return raw template text - -> Text - -- ^ raw template text - - - -- | Returns a reference to template source, from which this template was - -- loaded. - templateRef :: a - -- ^ template for which to return reference - -> TemplateRef - -- ^ template reference - + -- | Returns list of supported file extensions for this template type. + templateExtensions :: + -- | list of supported file extensions + NonEmpty Text + + -- | Parses template from given raw text. + parseTemplate :: + MonadThrow m => + -- | reference to template source + TemplateRef -> + -- | raw template text + Text -> + -- | parsed template + m a + + -- | Renders parsed template and replaces all variables with actual values. + renderTemplate :: + MonadThrow m => + -- | values of variables to replace + Variables -> + -- | parsed template to render + a -> + -- | rendered template text + m Text + + -- | Returns the raw text of the template, same that has been parsed by + -- 'parseTemplate' method. + rawTemplate :: + -- | template for which to return raw template text + a -> + -- | raw template text + Text + + -- | Returns a reference to template source, from which this template was + -- loaded. + templateRef :: + -- | template for which to return reference + a -> + -- | template reference + TemplateRef ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -88,27 +86,28 @@ class Template a where emptyTemplate :: (MonadThrow m, Template a) => m a emptyTemplate = parseTemplate (InlineRef T.empty) T.empty - --------------------------------- ERROR TYPES -------------------------------- -- | Error during processing template. data TemplateError - = MissingVariables Text [Text] -- ^ missing variable values - | ParseError Text -- ^ error parsing raw template text - deriving (Eq, Show, Typeable) - + = -- | missing variable values + MissingVariables Text [Text] + | -- | error parsing raw template text + ParseError Text + deriving (Eq, Show, Typeable) instance Exception TemplateError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: TemplateError -> String displayException' = \case - MissingVariables name variables -> [iii| + MissingVariables name variables -> + [iii| Missing variables for #{name}: #{variables} |] - ParseError msg -> [iii| + ParseError msg -> + [iii| Error parsing template: #{msg} |] diff --git a/src/Headroom/Template/Mustache.hs b/src/Headroom/Template/Mustache.hs index c77f223..f043e66 100644 --- a/src/Headroom/Template/Mustache.hs +++ b/src/Headroom/Template/Mustache.hs @@ -1,76 +1,71 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Template.Mustache -Description : Implementation of /Mustache/ template support -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides support for -templates. --} - -module Headroom.Template.Mustache - ( Mustache(..) - ) -where +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Template ( Template(..) - , TemplateError(..) - ) -import Headroom.Template.TemplateRef ( TemplateRef - , renderRef - ) -import Headroom.Variables.Types ( Variables(..) ) -import RIO -import qualified RIO.Text as T -import qualified Text.Mustache as MU -import Text.Mustache.Render ( SubstitutionError(..) ) +-- | +-- Module : Headroom.Template.Mustache +-- Description : Implementation of /Mustache/ template support +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides support for +-- templates. +module Headroom.Template.Mustache ( + Mustache (..) +) where +import Headroom.Template ( + Template (..) + , TemplateError (..) + ) +import Headroom.Template.TemplateRef ( + TemplateRef + , renderRef + ) +import Headroom.Variables.Types (Variables (..)) +import RIO +import qualified RIO.Text as T +import qualified Text.Mustache as MU +import Text.Mustache.Render (SubstitutionError (..)) -- | The /Mustache/ template. data Mustache = Mustache - { mCompiledTemplate :: MU.Template - , mRawTemplate :: Text - , mTemplateRef :: TemplateRef - } - deriving Show + { mCompiledTemplate :: MU.Template + , mRawTemplate :: Text + , mTemplateRef :: TemplateRef + } + deriving (Show) instance Eq Mustache where - a == b = mRawTemplate a == mRawTemplate b - + a == b = mRawTemplate a == mRawTemplate b -- | Support for /Mustache/ templates. instance Template Mustache where - templateExtensions = "mustache" :| [] - parseTemplate = parseTemplate' - renderTemplate = renderTemplate' - rawTemplate = mRawTemplate - templateRef = mTemplateRef - + templateExtensions = "mustache" :| [] + parseTemplate = parseTemplate' + renderTemplate = renderTemplate' + rawTemplate = mRawTemplate + templateRef = mTemplateRef parseTemplate' :: MonadThrow m => TemplateRef -> Text -> m Mustache parseTemplate' ref raw = - case MU.compileTemplate (T.unpack $ renderRef ref) raw of - Left err -> throwM . ParseError $ tshow err - Right res -> pure $ Mustache res raw ref - + case MU.compileTemplate (T.unpack $ renderRef ref) raw of + Left err -> throwM . ParseError $ tshow err + Right res -> pure $ Mustache res raw ref renderTemplate' :: MonadThrow m => Variables -> Mustache -> m Text renderTemplate' (Variables variables) (Mustache t@(MU.Template name _ _) _ _) = - case MU.checkedSubstitute t variables of - ([], rendered) -> pure rendered - (errs, rendered) -> - let errs' = missingVariables errs - missingVariables = concatMap $ \case - (VariableNotFound ps) -> ps - _ -> [] - in if length errs == length errs' - then throwM $ MissingVariables (T.pack name) errs' - else pure rendered + case MU.checkedSubstitute t variables of + ([], rendered) -> pure rendered + (errs, rendered) -> + let errs' = missingVariables errs + missingVariables = concatMap $ \case + (VariableNotFound ps) -> ps + _ -> [] + in if length errs == length errs' + then throwM $ MissingVariables (T.pack name) errs' + else pure rendered diff --git a/src/Headroom/Template/TemplateRef.hs b/src/Headroom/Template/TemplateRef.hs index 2d35fd5..b840c3e 100644 --- a/src/Headroom/Template/TemplateRef.hs +++ b/src/Headroom/Template/TemplateRef.hs @@ -1,79 +1,83 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -Module : Headroom.Template.TemplateRef -Description : Representation of reference to template file -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -'TemplateRef' data type represents reference to template file, either local or -remote, which can be later opened/downloaded and parsed into template. --} - -module Headroom.Template.TemplateRef - ( -- * Data Types - TemplateRef(..) - -- * Constructor Functions - , mkTemplateRef - -- * Public Functions - , renderRef - -- * Error Types - , TemplateRefError(..) - ) -where - -import Data.Aeson ( FromJSON(..) - , Value(String) - ) -import Data.String.Interpolate ( i - , iii - ) -import Headroom.Data.EnumExtra ( textToEnum ) -import Headroom.Data.Regex ( match - , re - ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Types ( LicenseType - , fromHeadroomError - , toHeadroomError - ) -import RIO -import qualified RIO.Text as T -import qualified Text.URI as URI -import Text.URI ( URI(..) - , mkURI - ) - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Template.TemplateRef +-- Description : Representation of reference to template file +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- 'TemplateRef' data type represents reference to template file, either local or +-- remote, which can be later opened/downloaded and parsed into template. +module Headroom.Template.TemplateRef ( + -- * Data Types + TemplateRef (..) + + -- * Constructor Functions + , mkTemplateRef + + -- * Public Functions + , renderRef + + -- * Error Types + , TemplateRefError (..) +) where + +import Data.Aeson ( + FromJSON (..) + , Value (String) + ) +import Data.String.Interpolate ( + i + , iii + ) +import Headroom.Data.EnumExtra (textToEnum) +import Headroom.Data.Regex ( + match + , re + ) +import Headroom.FileType.Types (FileType (..)) +import Headroom.Types ( + LicenseType + , fromHeadroomError + , toHeadroomError + ) +import RIO +import qualified RIO.Text as T +import Text.URI ( + URI (..) + , mkURI + ) +import qualified Text.URI as URI --------------------------------- DATA TYPES --------------------------------- -- | Reference to the template (e.g. local file, URI address). data TemplateRef - = InlineRef Text - | LocalTemplateRef FilePath -- ^ template path on local file system - | UriTemplateRef URI -- ^ remote template URI adress - | BuiltInRef LicenseType FileType - deriving (Eq, Ord, Show) - + = InlineRef Text + | -- | template path on local file system + LocalTemplateRef FilePath + | -- | remote template URI adress + UriTemplateRef URI + | BuiltInRef LicenseType FileType + deriving (Eq, Ord, Show) instance FromJSON TemplateRef where - parseJSON = \case - String s -> maybe (error $ T.unpack s) pure (mkTemplateRef s) - other -> error $ "Invalid value for template reference: " <> show other - + parseJSON = \case + String s -> maybe (error $ T.unpack s) pure (mkTemplateRef s) + other -> error $ "Invalid value for template reference: " <> show other ------------------------------ PUBLIC FUNCTIONS ------------------------------ @@ -86,54 +90,61 @@ instance FromJSON TemplateRef where -- -- >>> mkTemplateRef "https://foo.bar/haskell.mustache" :: Maybe TemplateRef -- Just (UriTemplateRef (URI {uriScheme = Just "https", uriAuthority = Right (Authority {authUserInfo = Nothing, authHost = "foo.bar", authPort = Nothing}), uriPath = Just (False,"haskell.mustache" :| []), uriQuery = [], uriFragment = Nothing})) -mkTemplateRef :: MonadThrow m - => Text -- ^ input text - -> m TemplateRef -- ^ created 'TemplateRef' (or error) +mkTemplateRef :: + MonadThrow m => + -- | input text + Text -> + -- | created 'TemplateRef' (or error) + m TemplateRef mkTemplateRef raw = case match [re|(^\w+):\/\/|] raw of - Just (_ : p : _) | p `elem` ["http", "https"] -> uriTemplateRef - | otherwise -> throwM $ UnsupportedUriProtocol p raw - _ -> pure . LocalTemplateRef . T.unpack $ raw - where - uriTemplateRef = extractFileType >> UriTemplateRef <$> mkURI raw - extractFileType = case match [re|(\w+)\.(\w+)$|] raw of - Just (_ : (textToEnum @FileType -> (Just ft )) : _ : _) -> pure ft - _ -> throwM $ UnrecognizedTemplateName raw - + Just (_ : p : _) + | p `elem` ["http", "https"] -> uriTemplateRef + | otherwise -> throwM $ UnsupportedUriProtocol p raw + _ -> pure . LocalTemplateRef . T.unpack $ raw + where + uriTemplateRef = extractFileType >> UriTemplateRef <$> mkURI raw + extractFileType = case match [re|(\w+)\.(\w+)$|] raw of + Just (_ : (textToEnum @FileType -> (Just ft)) : _ : _) -> pure ft + _ -> throwM $ UnrecognizedTemplateName raw ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Renders given 'TemplateRef' into human-friendly text. -renderRef :: TemplateRef -- ^ 'TemplateRef' to render - -> Text -- ^ rendered text -renderRef (InlineRef content) = [i||] -renderRef (LocalTemplateRef path ) = T.pack path -renderRef (UriTemplateRef uri ) = URI.render uri -renderRef (BuiltInRef lt ft ) = [i||] - +renderRef :: + -- | 'TemplateRef' to render + TemplateRef -> + -- | rendered text + Text +renderRef (InlineRef content) = [i||] +renderRef (LocalTemplateRef path) = T.pack path +renderRef (UriTemplateRef uri) = URI.render uri +renderRef (BuiltInRef lt ft) = [i||] --------------------------------- ERROR TYPES -------------------------------- -- | Error related to template references. data TemplateRefError - = UnrecognizedTemplateName Text -- ^ not a valid format for template name - | UnsupportedUriProtocol Text Text -- ^ URI protocol not supported - deriving (Eq, Show) - + = -- | not a valid format for template name + UnrecognizedTemplateName Text + | -- | URI protocol not supported + UnsupportedUriProtocol Text Text + deriving (Eq, Show) instance Exception TemplateRefError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: TemplateRefError -> String displayException' = \case - UnrecognizedTemplateName raw -> [iii| + UnrecognizedTemplateName raw -> + [iii| Cannot extract file type and template type from path #{raw}. Please make sure that the path ends with '.', for example '/path/to/haskell.mustache'. |] - UnsupportedUriProtocol protocol raw -> [iii| + UnsupportedUriProtocol protocol raw -> + [iii| Protocol '#{protocol}' of in URI '#{raw}' is not supported. Make sure that you use either HTTP or HTTPS URIs. |] diff --git a/src/Headroom/Types.hs b/src/Headroom/Types.hs index 3f84507..5866494 100644 --- a/src/Headroom/Types.hs +++ b/src/Headroom/Types.hs @@ -1,88 +1,96 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.Types -Description : Application data types -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module containing most of the data types used by the application. --} - -module Headroom.Types - ( -- * Error Data Types - HeadroomError(..) - -- ** Helper Functions - , fromHeadroomError - , toHeadroomError - -- * Other Data Types - , CurrentYear(..) - , LicenseType(..) - ) -where - -import Data.Aeson ( FromJSON(..) - , Value(String) - ) -import Data.Typeable ( cast ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import RIO -import qualified RIO.Text as T - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Types +-- Description : Application data types +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module containing most of the data types used by the application. +module Headroom.Types ( + -- * Error Data Types + HeadroomError (..) + + -- ** Helper Functions + , fromHeadroomError + , toHeadroomError + + -- * Other Data Types + , CurrentYear (..) + , LicenseType (..) +) where + +import Data.Aeson ( + FromJSON (..) + , Value (String) + ) +import Data.Typeable (cast) +import Headroom.Data.EnumExtra (EnumExtra (..)) +import RIO +import qualified RIO.Text as T -- | Top-level of the /Headroom/ exception hierarchy. -data HeadroomError = forall e . Exception e => HeadroomError e +data HeadroomError = forall e. Exception e => HeadroomError e instance Show HeadroomError where - show (HeadroomError he) = show he + show (HeadroomError he) = show he instance Exception HeadroomError where - displayException (HeadroomError he) = displayException he - + displayException (HeadroomError he) = displayException he -- | Wraps given exception into 'HeadroomError'. -toHeadroomError :: Exception e - => e -- ^ exception to wrap - -> SomeException -- ^ wrapped exception +toHeadroomError :: + Exception e => + -- | exception to wrap + e -> + -- | wrapped exception + SomeException toHeadroomError = toException . HeadroomError - -- | Unwraps given exception from 'HeadroomError'. -fromHeadroomError :: Exception e - => SomeException -- ^ exception to unwrap - -> Maybe e -- ^ unwrapped exception +fromHeadroomError :: + Exception e => + -- | exception to unwrap + SomeException -> + -- | unwrapped exception + Maybe e fromHeadroomError e = do - HeadroomError he <- fromException e - cast he - + HeadroomError he <- fromException e + cast he -- | Wraps the value of current year. newtype CurrentYear = CurrentYear - { unCurrentYear :: Integer -- ^ value of current year - } - deriving (Eq, Show) - + { unCurrentYear :: Integer + -- ^ value of current year + } + deriving (Eq, Show) -- | Supported type of open source license. data LicenseType - = Apache2 -- ^ support for /Apache-2.0/ license - | BSD3 -- ^ support for /BSD-3-Clause/ license - | GPL2 -- ^ support for /GNU GPL2/ license - | GPL3 -- ^ support for /GNU GPL3/ license - | MIT -- ^ support for /MIT/ license - | MPL2 -- ^ support for /MPL2/ license - deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + = -- | support for /Apache-2.0/ license + Apache2 + | -- | support for /BSD-3-Clause/ license + BSD3 + | -- | support for /GNU GPL2/ license + GPL2 + | -- | support for /GNU GPL3/ license + GPL3 + | -- | support for /MIT/ license + MIT + | -- | support for /MPL2/ license + MPL2 + deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) instance FromJSON LicenseType where - parseJSON = \case - String s -> case textToEnum s of - Just licenseType -> pure licenseType - _ -> error $ "Unknown license type: " <> T.unpack s - other -> error $ "Invalid value for run mode: " <> show other + parseJSON = \case + String s -> case textToEnum s of + Just licenseType -> pure licenseType + _ -> error $ "Unknown license type: " <> T.unpack s + other -> error $ "Invalid value for run mode: " <> show other diff --git a/src/Headroom/UI.hs b/src/Headroom/UI.hs index e321eef..0b349d2 100644 --- a/src/Headroom/UI.hs +++ b/src/Headroom/UI.hs @@ -1,20 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.UI -Description : UI Components -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX +-- | +-- Module : Headroom.UI +-- Description : UI Components +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Various UI components. +module Headroom.UI ( + module Headroom.UI.Progress +) where -Various UI components. --} - -module Headroom.UI - ( module Headroom.UI.Progress - ) -where - -import Headroom.UI.Progress +import Headroom.UI.Progress diff --git a/src/Headroom/UI/Message.hs b/src/Headroom/UI/Message.hs index d44e440..d186c61 100644 --- a/src/Headroom/UI/Message.hs +++ b/src/Headroom/UI/Message.hs @@ -1,64 +1,59 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.UI.Message -Description : UI component for message box -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing UI component for message box (info/warning/error). --} - -module Headroom.UI.Message - ( MessageType(..) - , Message(..) - , messageInfo - , messageWarn - , messageError - ) -where - -import Data.String.Interpolate ( i ) -import RIO +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module : Headroom.UI.Message +-- Description : UI component for message box +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing UI component for message box (info/warning/error). +module Headroom.UI.Message ( + MessageType (..) + , Message (..) + , messageInfo + , messageWarn + , messageError +) where + +import Data.String.Interpolate (i) +import RIO -- | Type of the message box (info/warning/error). data MessageType - = Info -- ^ info message type - | Warn -- ^ warning message type - | Error -- ^ error message type - deriving (Eq, Show) + = -- | info message type + Info + | -- | warning message type + Warn + | -- | error message type + Error + deriving (Eq, Show) instance Display MessageType where - textDisplay Info = "[i]" - textDisplay Warn = "[!]" - textDisplay Error = "[x]" - + textDisplay Info = "[i]" + textDisplay Warn = "[!]" + textDisplay Error = "[x]" -- | Data type for message box. data Message = Message MessageType Text - deriving (Eq, Show) + deriving (Eq, Show) instance Display Message where - textDisplay (Message tp tx) = [i|#{textDisplay tp} #{tx}|] - + textDisplay (Message tp tx) = [i|#{textDisplay tp} #{tx}|] -- | Creates 'Message' of type 'Info'. messageInfo :: Text -> Message messageInfo = Message Info - -- | Creates 'Message' of type 'Warn'. messageWarn :: Text -> Message messageWarn = Message Warn - -- | Creates 'Message' of type 'Error'. messageError :: Text -> Message messageError = Message Error diff --git a/src/Headroom/UI/Progress.hs b/src/Headroom/UI/Progress.hs index 910c9ba..2766cb8 100644 --- a/src/Headroom/UI/Progress.hs +++ b/src/Headroom/UI/Progress.hs @@ -1,53 +1,49 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StrictData #-} -{-| -Module : Headroom.UI.Progress -Description : UI component for displaying progress -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This component displays progress in format @[CURR of TOTAL]@. --} - -module Headroom.UI.Progress - ( Progress(..) - , zipWithProgress - ) -where - -import RIO -import qualified RIO.Text as T -import Text.Printf ( printf ) +-- | +-- Module : Headroom.UI.Progress +-- Description : UI component for displaying progress +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This component displays progress in format @[CURR of TOTAL]@. +module Headroom.UI.Progress ( + Progress (..) + , zipWithProgress +) where +import RIO +import qualified RIO.Text as T +import Text.Printf (printf) -- | Progress indication. First argument is current progress, second the maximum -- value. data Progress = Progress Int Int - deriving (Eq, Show) - + deriving (Eq, Show) instance Display Progress where - textDisplay (Progress current total) = T.pack - $ mconcat ["[", currentS, " of ", totalS, "]"] - where - format = "%" <> (show . length $ totalS) <> "d" - currentS = printf format current - totalS = show total - + textDisplay (Progress current total) = + T.pack $ + mconcat ["[", currentS, " of ", totalS, "]"] + where + format = "%" <> (show . length $ totalS) <> "d" + currentS = printf format current + totalS = show total -- | Zips given list with the progress info. -- -- >>> zipWithProgress ["a", "b"] -- [(Progress 1 2,"a"),(Progress 2 2,"b")] -zipWithProgress :: [a] - -- ^ list to zip with progress - -> [(Progress, a)] - -- ^ zipped result +zipWithProgress :: + -- | list to zip with progress + [a] -> + -- | zipped result + [(Progress, a)] zipWithProgress list = zip progresses list - where - listLength = length list - progresses = fmap (`Progress` listLength) [1 .. listLength] + where + listLength = length list + progresses = fmap (`Progress` listLength) [1 .. listLength] diff --git a/src/Headroom/UI/Table.hs b/src/Headroom/UI/Table.hs index 59eece3..8143b88 100644 --- a/src/Headroom/UI/Table.hs +++ b/src/Headroom/UI/Table.hs @@ -1,34 +1,31 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Headroom.UI.Table -Description : UI components for rendering tables -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing UI components for tables. --} +-- | +-- Module : Headroom.UI.Table +-- Description : UI components for rendering tables +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing UI components for tables. module Headroom.UI.Table where -import qualified Headroom.Data.Text as T -import RIO -import qualified RIO.List.Partial as LP -import qualified RIO.Text as T - +import qualified Headroom.Data.Text as T +import RIO +import qualified RIO.List.Partial as LP +import qualified RIO.Text as T -- | Represents two columns wide table. newtype Table2 = Table2 [(Text, Text)] deriving (Eq, Show) instance Display Table2 where - textDisplay (Table2 rows) = - let maxWidth = (+ 1) . maximum' . fmap (T.length . fst) $ rows - aligned = fmap (\(c1, c2) -> T.justifyLeft maxWidth ' ' c1 <> c2) rows - in T.fromLines aligned - where - maximum' [] = 0 - maximum' xs = LP.maximum xs + textDisplay (Table2 rows) = + let maxWidth = (+ 1) . maximum' . fmap (T.length . fst) $ rows + aligned = fmap (\(c1, c2) -> T.justifyLeft maxWidth ' ' c1 <> c2) rows + in T.fromLines aligned + where + maximum' [] = 0 + maximum' xs = LP.maximum xs diff --git a/src/Headroom/Updater.hs b/src/Headroom/Updater.hs index 2188683..9b08b4c 100644 --- a/src/Headroom/Updater.hs +++ b/src/Headroom/Updater.hs @@ -1,127 +1,132 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.Updater -Description : Update Manager for Headroom -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -/Update Manager (Updater)/ is responsible for fetching data about latest version -of /Headroom/ and informing user about available updates. In future versions, it -might be capable to update /Headroom/ binaries automatically. --} - -module Headroom.Updater - ( checkUpdates - , fetchLatestVersion - , parseLatestVersion - -- * Error Data Types - , UpdaterError(..) - ) -where - -import Data.Aeson ( Value(String) ) -import qualified Data.Aeson as A -import Data.String.Interpolate ( iii ) -import Data.Time ( UTCTime(utctDay) ) -import Headroom.Config.Global ( UpdaterConfig(..) ) -import Headroom.Data.Has ( Has(..) - , HasRIO - ) -import Headroom.IO.KVStore ( KVStore(..) - , valueKey - ) -import Headroom.IO.Network ( Network(..) ) -import Headroom.Meta ( buildVersion ) -import Headroom.Meta.Version ( Version - , parseVersion - ) -import Headroom.Types ( fromHeadroomError - , toHeadroomError - ) -import Lens.Micro.Aeson ( key ) -import RIO -import qualified RIO.ByteString.Lazy as BL -import qualified RIO.Text as T -import RIO.Time ( diffDays - , getCurrentTime - ) -import qualified Text.URI as URI - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Updater +-- Description : Update Manager for Headroom +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- /Update Manager (Updater)/ is responsible for fetching data about latest version +-- of /Headroom/ and informing user about available updates. In future versions, it +-- might be capable to update /Headroom/ binaries automatically. +module Headroom.Updater ( + checkUpdates + , fetchLatestVersion + , parseLatestVersion + + -- * Error Data Types + , UpdaterError (..) +) where + +import Data.Aeson (Value (String)) +import qualified Data.Aeson as A +import Data.String.Interpolate (iii) +import Data.Time (UTCTime (utctDay)) +import Headroom.Config.Global (UpdaterConfig (..)) +import Headroom.Data.Has ( + Has (..) + , HasRIO + ) +import Headroom.IO.KVStore ( + KVStore (..) + , valueKey + ) +import Headroom.IO.Network (Network (..)) +import Headroom.Meta (buildVersion) +import Headroom.Meta.Version ( + Version + , parseVersion + ) +import Headroom.Types ( + fromHeadroomError + , toHeadroomError + ) +import Lens.Micro.Aeson (key) +import RIO +import qualified RIO.ByteString.Lazy as BL +import qualified RIO.Text as T +import RIO.Time ( + diffDays + , getCurrentTime + ) +import qualified Text.URI as URI -- | Check whether newer version is available (if enabled by configuration). -checkUpdates :: (HasRIO KVStore env, HasRIO Network env) - => UpdaterConfig - -> RIO env (Maybe Version) -checkUpdates UpdaterConfig {..} = do - KVStore {..} <- viewL - now <- getCurrentTime - maybeLastCheckDate <- kvGetValue lastCheckDateKey - let today = utctDay now - shouldCheck = ucCheckForUpdates && case utctDay <$> maybeLastCheckDate of - Just lastCheck - | abs (diffDays lastCheck today) > ucUpdateIntervalDays -> True - | otherwise -> False - Nothing -> True - when shouldCheck $ kvPutValue lastCheckDateKey now - if shouldCheck then isNewer <$> fetchLatestVersion else pure Nothing - where - lastCheckDateKey = valueKey @UTCTime "updater/last-check-date" - isNewer version | version > buildVersion = Just version - | otherwise = Nothing - +checkUpdates :: + (HasRIO KVStore env, HasRIO Network env) => + UpdaterConfig -> + RIO env (Maybe Version) +checkUpdates UpdaterConfig{..} = do + KVStore{..} <- viewL + now <- getCurrentTime + maybeLastCheckDate <- kvGetValue lastCheckDateKey + let today = utctDay now + shouldCheck = + ucCheckForUpdates && case utctDay <$> maybeLastCheckDate of + Just lastCheck + | abs (diffDays lastCheck today) > ucUpdateIntervalDays -> True + | otherwise -> False + Nothing -> True + when shouldCheck $ kvPutValue lastCheckDateKey now + if shouldCheck then isNewer <$> fetchLatestVersion else pure Nothing + where + lastCheckDateKey = valueKey @UTCTime "updater/last-check-date" + isNewer version + | version > buildVersion = Just version + | otherwise = Nothing -- | Fetches and parses latest version from update server. fetchLatestVersion :: (HasRIO Network env) => RIO env Version fetchLatestVersion = do - Network {..} <- viewL - apiURI <- latestVersionApiURI - resp <- catchAny (nDownloadContent apiURI) handleError - case A.decode (BL.fromStrict resp) of - Just json -> parseLatestVersion json - _ -> throwM $ CannotDetectVersion "cannot fetch response" - where - handleError = throwM . CannotDetectVersion . T.pack . displayException - latestVersionApiURI = URI.mkURI - "https://api.github.com/repos/vaclavsvejcar/headroom/releases/latest" - - + Network{..} <- viewL + apiURI <- latestVersionApiURI + resp <- catchAny (nDownloadContent apiURI) handleError + case A.decode (BL.fromStrict resp) of + Just json -> parseLatestVersion json + _ -> throwM $ CannotDetectVersion "cannot fetch response" + where + handleError = throwM . CannotDetectVersion . T.pack . displayException + latestVersionApiURI = + URI.mkURI + "https://api.github.com/repos/vaclavsvejcar/headroom/releases/latest" -- | Parses latest version number from /GitHub/ API response. -parseLatestVersion :: MonadThrow m - => Value -- ^ raw JSON response from /GitHub/ - -> m Version -- ^ parsed version +parseLatestVersion :: + MonadThrow m => + -- | raw JSON response from /GitHub/ + Value -> + -- | parsed version + m Version parseLatestVersion json = case json ^? key "name" of - Just (String rawValue) -> case parseVersion rawValue of - Just version -> pure version - _ -> throwM $ CannotDetectVersion "cannot parse version" - _ -> throwM $ CannotDetectVersion "cannot parse response" - + Just (String rawValue) -> case parseVersion rawValue of + Just version -> pure version + _ -> throwM $ CannotDetectVersion "cannot parse version" + _ -> throwM $ CannotDetectVersion "cannot parse response" --------------------------------- ERROR TYPES -------------------------------- -- | Error during processing updates. data UpdaterError = CannotDetectVersion Text - deriving (Eq, Show, Typeable) + deriving (Eq, Show, Typeable) instance Exception UpdaterError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: UpdaterError -> String displayException' = \case - CannotDetectVersion reason -> [iii| + CannotDetectVersion reason -> + [iii| Cannot get latest Headroom version from update servers, reason: #{reason}. |] diff --git a/src/Headroom/Variables.hs b/src/Headroom/Variables.hs index 811f28c..268768a 100644 --- a/src/Headroom/Variables.hs +++ b/src/Headroom/Variables.hs @@ -1,79 +1,84 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.Variables -Description : Support for template variables -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module containing costructor and useful functions for the 'Variables' data type. --} - -module Headroom.Variables - ( -- * Constructing Variables - mkVariables - , dynamicVariables - -- * Parsing Variables - , parseVariables - -- * Processing Variables - , compileVariables - ) -where - -import Data.String.Interpolate ( iii ) -import Headroom.Template ( Template(..) ) -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -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 - +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Headroom.Variables +-- Description : Support for template variables +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module containing costructor and useful functions for the 'Variables' data type. +module Headroom.Variables ( + -- * Constructing Variables + mkVariables + , dynamicVariables + + -- * Parsing Variables + , parseVariables + + -- * Processing Variables + , compileVariables +) where + +import Data.String.Interpolate (iii) +import Headroom.Template (Template (..)) +import Headroom.Template.TemplateRef (TemplateRef (..)) +import Headroom.Types ( + CurrentYear (..) + , fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types (Variables (..)) +import RIO +import qualified RIO.HashMap as HM +import qualified RIO.Text as T -- | Constructor function for 'Variables' data type. -- -- >>> mkVariables [("key1", "value1")] -- Variables (fromList [("key1","value1")]) -mkVariables :: [(Text, Text)] -- ^ pairs of /key-value/ - -> Variables -- ^ constructed variables +mkVariables :: + -- | pairs of /key-value/ + [(Text, Text)] -> + -- | constructed variables + Variables mkVariables = Variables . HM.fromList - -- | /Dynamic variables/ that are common for all parsed files. -- -- * @___current_year__@ - current year -dynamicVariables :: CurrentYear -- ^ current year - -> Variables -- ^ map of /dynamic variables/ +dynamicVariables :: + -- | current year + CurrentYear -> + -- | map of /dynamic variables/ + Variables dynamicVariables (CurrentYear year) = - mkVariables [("_current_year", tshow year)] - + mkVariables [("_current_year", tshow year)] -- | Parses variables from raw input in @key=value@ format. -- -- >>> parseVariables ["key1=value1"] -- Variables (fromList [("key1","value1")]) -parseVariables :: MonadThrow m - => [Text] -- ^ list of raw variables - -> m Variables -- ^ parsed variables +parseVariables :: + MonadThrow m => + -- | list of raw variables + [Text] -> + -- | parsed variables + m Variables parseVariables variables = fmap mkVariables (mapM parse variables) - where - parse input = case T.split (== '=') input of - [key, value] -> pure (key, value) - _ -> throwM $ InvalidVariable input - + where + parse input = case T.split (== '=') input of + [key, value] -> pure (key, value) + _ -> throwM $ InvalidVariable input -- | Compiles variable values that are itself mini-templates, where their -- variables will be substituted by other variable values (if possible). @@ -85,35 +90,38 @@ parseVariables variables = fmap mkVariables (mapM parse variables) -- >>> let expected = mkVariables [("name", "John"), ("msg", "Hello, John")] -- >>> compiled == Just expected -- True -compileVariables :: forall a m - . (Template a, MonadThrow m) - => Variables -- ^ input variables to compile - -> m Variables -- ^ compiled variables +compileVariables :: + forall a m. + (Template a, MonadThrow m) => + -- | input variables to compile + Variables -> + -- | compiled variables + m Variables compileVariables variables@(Variables kvs) = do - compiled <- mapM compileVariable (HM.toList kvs) - pure $ mkVariables compiled - where - compileVariable (key, value) = do - parsed <- parseTemplate @a (InlineRef value) value - rendered <- renderTemplate variables parsed - pure (key, rendered) - + compiled <- mapM compileVariable (HM.toList kvs) + pure $ mkVariables compiled + where + compileVariable (key, value) = do + parsed <- parseTemplate @a (InlineRef value) value + rendered <- renderTemplate variables parsed + pure (key, rendered) --------------------------------- Error Types -------------------------------- -- | Exception specific to the "Headroom.Variables" module. -data VariablesError = InvalidVariable Text -- ^ invalid variable input (as @key=value@) - deriving (Eq, Show) - +data VariablesError + = -- | invalid variable input (as @key=value@) + InvalidVariable Text + deriving (Eq, Show) instance Exception VariablesError where - displayException = displayException' - toException = toHeadroomError - fromException = fromHeadroomError - + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError displayException' :: VariablesError -> String displayException' = \case - InvalidVariable raw -> [iii| + 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 index cf1a1de..301b7bb 100644 --- a/src/Headroom/Variables/Types.hs +++ b/src/Headroom/Variables/Types.hs @@ -1,30 +1,27 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| -Module : Headroom.Variables.Types -Description : Data types for "Headroom.Variables" -Copyright : (c) 2019-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX +-- | +-- Module : Headroom.Variables.Types +-- Description : Data types for "Headroom.Variables" +-- Copyright : (c) 2019-2022 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains data types for "Headroom.Variables" module. +module Headroom.Variables.Types ( + Variables (..) +) where -This module contains data types for "Headroom.Variables" module. --} - -module Headroom.Variables.Types - ( Variables(..) - ) -where - -import RIO +import RIO -- | Map of /static/ and /dynamic variables/. Use 'Headroom.Variables.mkVariables' function for -- more convenient construction of this data type. newtype Variables = Variables (HashMap Text Text) deriving (Eq, Show) instance Semigroup Variables where - (Variables x) <> (Variables y) = Variables (y <> x) + (Variables x) <> (Variables y) = Variables (y <> x) instance Monoid Variables where - mempty = Variables mempty + mempty = Variables mempty diff --git a/test/Headroom/Command/InitSpec.hs b/test/Headroom/Command/InitSpec.hs index 062cd34..de2bf80 100644 --- a/test/Headroom/Command/InitSpec.hs +++ b/test/Headroom/Command/InitSpec.hs @@ -1,89 +1,88 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} - -module Headroom.Command.InitSpec - ( spec - ) -where - -import Headroom.Command.Init -import Headroom.Command.Types ( CommandInitOptions(..) ) -import Headroom.Config.Types ( LicenseType(..) ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.IO.FileSystem ( FileSystem(..) ) -import RIO -import RIO.FilePath ( () ) -import qualified RIO.List as L -import Test.Hspec - +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Headroom.Command.InitSpec ( + spec +) where + +import Headroom.Command.Init +import Headroom.Command.Types (CommandInitOptions (..)) +import Headroom.Config.Types (LicenseType (..)) +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Lens ( + suffixLenses + , suffixLensesFor + ) +import Headroom.FileType.Types (FileType (..)) +import Headroom.IO.FileSystem (FileSystem (..)) +import RIO +import RIO.FilePath (()) +import qualified RIO.List as L +import Test.Hspec data TestEnv = TestEnv - { envLogFunc :: LogFunc - , envFileSystem :: FileSystem (RIO TestEnv) - , envInitOptions :: CommandInitOptions - , envPaths :: Paths - } + { envLogFunc :: LogFunc + , envFileSystem :: FileSystem (RIO TestEnv) + , envInitOptions :: CommandInitOptions + , envPaths :: Paths + } suffixLenses ''TestEnv suffixLensesFor ["fsDoesFileExist"] ''FileSystem suffixLensesFor ["pConfigFile"] ''Paths instance HasLogFunc TestEnv where - logFuncL = envLogFuncL + logFuncL = envLogFuncL instance Has CommandInitOptions TestEnv where - hasLens = envInitOptionsL + hasLens = envInitOptionsL instance Has (FileSystem (RIO TestEnv)) TestEnv where - hasLens = envFileSystemL + hasLens = envFileSystemL instance Has Paths TestEnv where - hasLens = envPathsL - + hasLens = envPathsL spec :: Spec spec = do + describe "doesAppConfigExist" $ do + it "checks that configuration file exists in selected directory" $ do + let env' = env & envFileSystemL . fsDoesFileExistL .~ check + check path = pure $ env' ^. envPathsL . pConfigFileL == path + runRIO env' doesAppConfigExist `shouldReturn` True - describe "doesAppConfigExist" $ do - it "checks that configuration file exists in selected directory" $ do - let env' = env & envFileSystemL . fsDoesFileExistL .~ check - check path = pure $ env' ^. envPathsL . pConfigFileL == path - runRIO env' doesAppConfigExist `shouldReturn` True - - - describe "findSupportedFileTypes" $ do - it "recursively finds all known file types present in given path" $ do - L.sort <$> runRIO env findSupportedFileTypes `shouldReturn` [HTML] - + describe "findSupportedFileTypes" $ do + it "recursively finds all known file types present in given path" $ do + L.sort <$> runRIO env findSupportedFileTypes `shouldReturn` [HTML] env :: TestEnv -env = TestEnv { .. } - where - envLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) - envInitOptions = CommandInitOptions - { cioSourcePaths = ["test-data" "test-traverse"] - , cioLicenseType = BSD3 - } - envPaths = Paths { pConfigFile = "test-data" "configs" "full.yaml" - , pTemplatesDir = "headroom-templates" - } - envFileSystem = FileSystem { fsCreateDirectory = undefined - , fsDoesFileExist = undefined - , fsFindFiles = undefined - , fsFindFilesByExts = undefined - , fsFindFilesByTypes = undefined - , fsGetCurrentDirectory = undefined - , fsGetUserDirectory = undefined - , fsListFiles = undefined - , fsLoadFile = undefined - , fsWriteFile = undefined - } - +env = TestEnv{..} + where + envLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) + envInitOptions = + CommandInitOptions + { cioSourcePaths = ["test-data" "test-traverse"] + , cioLicenseType = BSD3 + } + envPaths = + Paths + { pConfigFile = "test-data" "configs" "full.yaml" + , pTemplatesDir = "headroom-templates" + } + envFileSystem = + FileSystem + { fsCreateDirectory = undefined + , fsDoesFileExist = undefined + , fsFindFiles = undefined + , fsFindFilesByExts = undefined + , fsFindFilesByTypes = undefined + , fsGetCurrentDirectory = undefined + , fsGetUserDirectory = undefined + , fsListFiles = undefined + , fsLoadFile = undefined + , fsWriteFile = undefined + } diff --git a/test/Headroom/Command/ReadersSpec.hs b/test/Headroom/Command/ReadersSpec.hs index 9424b0c..e7430cd 100644 --- a/test/Headroom/Command/ReadersSpec.hs +++ b/test/Headroom/Command/ReadersSpec.hs @@ -1,30 +1,29 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module Headroom.Command.ReadersSpec - ( spec - ) -where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Command.Readers -import Headroom.Config.Types ( LicenseType ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.FileType.Types ( FileType ) -import RIO -import qualified RIO.Text as T -import Test.Hspec -import Test.Hspec.QuickCheck ( prop ) -import Test.QuickCheck +module Headroom.Command.ReadersSpec ( + spec +) where +import Headroom.Command.Readers +import Headroom.Config.Types (LicenseType) +import Headroom.Data.EnumExtra (EnumExtra (..)) +import Headroom.FileType.Types (FileType) +import RIO +import qualified RIO.Text as T +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck spec :: Spec spec = do - describe "parseLicense" $ do - prop "should parse license and file type from raw input" prop_parseLicense - where - 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) + describe "parseLicense" $ do + prop "should parse license and file type from raw input" prop_parseLicense + where + 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 index 68de8ef..79798f5 100644 --- a/test/Headroom/Command/RunSpec.hs +++ b/test/Headroom/Command/RunSpec.hs @@ -1,167 +1,169 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Headroom.Command.RunSpec - ( spec - ) -where - -import Headroom.Command.Run -import Headroom.Config.Types ( CtPostProcessConfigs - , HeaderSyntax(..) - , PostProcessConfig(..) - , PostProcessConfigs(..) - , 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.FileType.Types ( FileType(..) ) -import Headroom.IO.FileSystem ( FileSystem(..) ) -import Headroom.IO.Network ( Network(..) ) -import Headroom.Meta ( TemplateType ) -import Headroom.Template ( Template(..) ) -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -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.QuickCheck.Monadic -import Text.URI.QQ ( uri ) - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Headroom.Command.RunSpec ( + spec +) where + +import Headroom.Command.Run +import Headroom.Config.Types ( + CtPostProcessConfigs + , HeaderSyntax (..) + , PostProcessConfig (..) + , PostProcessConfigs (..) + , 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.FileType.Types (FileType (..)) +import Headroom.IO.FileSystem (FileSystem (..)) +import Headroom.IO.Network (Network (..)) +import Headroom.Meta (TemplateType) +import Headroom.Template (Template (..)) +import Headroom.Template.Mustache (Mustache) +import Headroom.Template.TemplateRef (TemplateRef (..)) +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.QuickCheck.Monadic +import Text.URI.QQ (uri) data TestEnv = TestEnv - { envLogFunc :: LogFunc - , envCurrentYear :: CurrentYear - , envFileSystem :: FileSystem (RIO TestEnv) - , envNetwork :: Network (RIO TestEnv) - , envPostProcessConfigs :: CtPostProcessConfigs - } + { envLogFunc :: LogFunc + , envCurrentYear :: CurrentYear + , envFileSystem :: FileSystem (RIO TestEnv) + , envNetwork :: Network (RIO TestEnv) + , envPostProcessConfigs :: CtPostProcessConfigs + } suffixLenses ''TestEnv suffixLensesFor ["fsFindFilesByExts", "fsLoadFile"] ''FileSystem suffixLensesFor ["nDownloadContent"] ''Network instance HasLogFunc TestEnv where - logFuncL = envLogFuncL + logFuncL = envLogFuncL instance Has CtPostProcessConfigs TestEnv where - hasLens = envPostProcessConfigsL + hasLens = envPostProcessConfigsL instance Has CurrentYear TestEnv where - hasLens = envCurrentYearL + hasLens = envCurrentYearL instance Has (FileSystem (RIO TestEnv)) TestEnv where - hasLens = envFileSystemL + hasLens = envFileSystemL instance Has (Network (RIO TestEnv)) TestEnv where - hasLens = envNetworkL - + hasLens = envNetworkL spec :: Spec spec = do - - describe "loadTemplateRefs" $ do - it "should load templates from given references" $ do - let env' = - env - & (envFileSystemL . fsFindFilesByExtsL .~ fsFindFilesByExts') - & (envFileSystemL . fsLoadFileL .~ fsLoadFile') - & (envNetworkL . nDownloadContentL .~ nDownloadContent') - fsFindFilesByExts' = \path _ -> case path of - "test-dir" -> pure ["haskell.mustache", "rust.mustache"] - _ -> throwString "INVALID" - fsLoadFile' = \case - "haskell.mustache" -> pure "haskell local" - "rust.mustache" -> pure "rust\nlocal\n" - _ -> throwString "INVALID" - nDownloadContent' = \case - [uri|http://test.com/haskell.mustache|] -> pure "haskell URI" - _ -> throwString "INVALID" - refs = - [ UriTemplateRef [uri|http://test.com/haskell.mustache|] - , LocalTemplateRef "test-dir" - ] - templates <- runRIO env' $ loadTemplateRefs @Mustache refs - M.size templates `shouldBe` 2 - M.member Haskell templates `shouldBe` True - M.member Rust templates `shouldBe` True - rawTemplate <$> M.lookup Haskell templates `shouldBe` Just "haskell local" - rawTemplate <$> M.lookup Rust templates `shouldBe` Just "rust\nlocal" - - - describe "typeOfTemplate" $ do - let fileTypes = fmap (T.toLower . enumToText) (allValues @FileType) - templateExt = NE.head $ templateExtensions @TemplateType - pathGen = elements $ fmap (<> "." <> templateExt) fileTypes - prop_typeOfTemplate = monadicIO $ do - path <- T.unpack <$> pick pathGen - result <- run (runRIO env $ typeOfTemplate path) - assert $ isJust result - - prop "should detect type of template from template path" prop_typeOfTemplate - - - describe "postProcessHeader'" $ do - it "should perform expected post-processing on license header" $ do - let sample = fromLines - [ "-- Copyright (c) 2018-2019 1st Author" - , "Copyright (c) 2017 2nd Author" - ] - expected = fromLines - [ "-- Copyright (c) 2018-2019 1st Author" - , "-- Copyright (c) 2017-2020 2nd Author" - ] - vars = mkVariables [("sndAuthor", "2nd Author")] - syntax = LineComment [re|^--|] (Just "--") - runRIO env (postProcessHeader' @Mustache syntax vars sample) - `shouldReturn` expected - + describe "loadTemplateRefs" $ do + it "should load templates from given references" $ do + let env' = + env + & (envFileSystemL . fsFindFilesByExtsL .~ fsFindFilesByExts') + & (envFileSystemL . fsLoadFileL .~ fsLoadFile') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + fsFindFilesByExts' = \path _ -> case path of + "test-dir" -> pure ["haskell.mustache", "rust.mustache"] + _ -> throwString "INVALID" + fsLoadFile' = \case + "haskell.mustache" -> pure "haskell local" + "rust.mustache" -> pure "rust\nlocal\n" + _ -> throwString "INVALID" + nDownloadContent' = \case + [uri|http://test.com/haskell.mustache|] -> pure "haskell URI" + _ -> throwString "INVALID" + refs = + [ UriTemplateRef [uri|http://test.com/haskell.mustache|] + , LocalTemplateRef "test-dir" + ] + templates <- runRIO env' $ loadTemplateRefs @Mustache refs + M.size templates `shouldBe` 2 + M.member Haskell templates `shouldBe` True + M.member Rust templates `shouldBe` True + rawTemplate <$> M.lookup Haskell templates `shouldBe` Just "haskell local" + rawTemplate <$> M.lookup Rust templates `shouldBe` Just "rust\nlocal" + + describe "typeOfTemplate" $ do + let fileTypes = fmap (T.toLower . enumToText) (allValues @FileType) + templateExt = NE.head $ templateExtensions @TemplateType + pathGen = elements $ fmap (<> "." <> templateExt) fileTypes + prop_typeOfTemplate = monadicIO $ do + path <- T.unpack <$> pick pathGen + result <- run (runRIO env $ typeOfTemplate path) + assert $ isJust result + + prop "should detect type of template from template path" prop_typeOfTemplate + + describe "postProcessHeader'" $ do + it "should perform expected post-processing on license header" $ do + let sample = + fromLines + [ "-- Copyright (c) 2018-2019 1st Author" + , "Copyright (c) 2017 2nd Author" + ] + expected = + fromLines + [ "-- Copyright (c) 2018-2019 1st Author" + , "-- Copyright (c) 2017-2020 2nd Author" + ] + vars = mkVariables [("sndAuthor", "2nd Author")] + syntax = LineComment [re|^--|] (Just "--") + runRIO env (postProcessHeader' @Mustache syntax vars sample) + `shouldReturn` expected env :: TestEnv -env = TestEnv { .. } - where - envLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) - envCurrentYear = CurrentYear 2020 - envFileSystem = FileSystem { fsCreateDirectory = undefined - , fsDoesFileExist = undefined - , fsFindFiles = undefined - , fsFindFilesByExts = undefined - , fsFindFilesByTypes = undefined - , fsGetCurrentDirectory = undefined - , fsGetUserDirectory = undefined - , fsListFiles = undefined - , fsLoadFile = undefined - , fsWriteFile = undefined - } - envNetwork = Network { nDownloadContent = undefined } - envPostProcessConfigs = PostProcessConfigs - { ppcsUpdateCopyright = PostProcessConfig - { ppcEnabled = True - , ppcConfig = UpdateCopyrightConfig - { uccSelectedAuthors = - Just $ "{{ sndAuthor }}" :| [] - } - } - } +env = TestEnv{..} + where + envLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) + envCurrentYear = CurrentYear 2020 + envFileSystem = + FileSystem + { fsCreateDirectory = undefined + , fsDoesFileExist = undefined + , fsFindFiles = undefined + , fsFindFilesByExts = undefined + , fsFindFilesByTypes = undefined + , fsGetCurrentDirectory = undefined + , fsGetUserDirectory = undefined + , fsListFiles = undefined + , fsLoadFile = undefined + , fsWriteFile = undefined + } + envNetwork = Network{nDownloadContent = undefined} + envPostProcessConfigs = + PostProcessConfigs + { ppcsUpdateCopyright = + PostProcessConfig + { ppcEnabled = True + , ppcConfig = + UpdateCopyrightConfig + { uccSelectedAuthors = + Just $ "{{ sndAuthor }}" :| [] + } + } + } diff --git a/test/Headroom/Config/CompatSpec.hs b/test/Headroom/Config/CompatSpec.hs index d2b7e9a..c3b3a2f 100644 --- a/test/Headroom/Config/CompatSpec.hs +++ b/test/Headroom/Config/CompatSpec.hs @@ -1,58 +1,57 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Headroom.Config.CompatSpec - ( spec - ) -where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config.Compat -import Headroom.Meta.Version ( Version(..) - , pvp - ) -import RIO -import Test.Hspec +module Headroom.Config.CompatSpec ( + spec +) where +import Headroom.Config.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 - - it "fails when source YAML has invalid syntax" $ do - let yaml = "invalid: [:]" - curr = [pvp|0.2.0.0|] - versions = [[pvp|0.1.0.0|], [pvp|0.2.1.0|], [pvp|0.4.0.0|]] - let err (CannotParseYaml _) = True - err _ = False - checkCompatibility versions curr yaml `shouldThrow` err + 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 + + it "fails when source YAML has invalid syntax" $ do + let yaml = "invalid: [:]" + curr = [pvp|0.2.0.0|] + versions = [[pvp|0.1.0.0|], [pvp|0.2.1.0|], [pvp|0.4.0.0|]] + let err (CannotParseYaml _) = True + err _ = False + checkCompatibility versions curr yaml `shouldThrow` err diff --git a/test/Headroom/Config/EnrichSpec.hs b/test/Headroom/Config/EnrichSpec.hs index f5b4cdb..c812f0b 100644 --- a/test/Headroom/Config/EnrichSpec.hs +++ b/test/Headroom/Config/EnrichSpec.hs @@ -1,48 +1,44 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.Config.EnrichSpec - ( spec - ) -where - -import Headroom.Config.Enrich -import RIO -import Test.Hspec +module Headroom.Config.EnrichSpec ( + spec +) where +import Headroom.Config.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 + 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/Config/GlobalSpec.hs b/test/Headroom/Config/GlobalSpec.hs index 0db5ecf..b8aafbf 100644 --- a/test/Headroom/Config/GlobalSpec.hs +++ b/test/Headroom/Config/GlobalSpec.hs @@ -1,86 +1,88 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} - -module Headroom.Config.GlobalSpec - ( spec - ) -where - -import Headroom.Config.Global -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.Embedded ( defaultGlobalConfig ) -import Headroom.IO.FileSystem ( FileSystem(..) - , mkFileSystem - ) -import Headroom.Meta ( globalConfigDirName - , globalConfigFileName - ) -import RIO -import RIO.Directory ( doesFileExist ) -import RIO.FilePath ( () ) -import Test.Hspec +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Headroom.Config.GlobalSpec ( + spec +) where +import Headroom.Config.Global +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Lens ( + suffixLenses + , suffixLensesFor + ) +import Headroom.Embedded (defaultGlobalConfig) +import Headroom.IO.FileSystem ( + FileSystem (..) + , mkFileSystem + ) +import Headroom.Meta ( + globalConfigDirName + , globalConfigFileName + ) +import RIO +import RIO.Directory (doesFileExist) +import RIO.FilePath (()) +import Test.Hspec data TestEnv = TestEnv - { envFileSystem :: FileSystem (RIO TestEnv) - } + { envFileSystem :: FileSystem (RIO TestEnv) + } suffixLenses ''TestEnv -suffixLensesFor [ "fsCreateDirectory" - , "fsDoesFileExist" - , "fsGetUserDirectory" - , "fsWriteFile" - ] ''FileSystem +suffixLensesFor + [ "fsCreateDirectory" + , "fsDoesFileExist" + , "fsGetUserDirectory" + , "fsWriteFile" + ] + ''FileSystem instance Has (FileSystem (RIO TestEnv)) TestEnv where - hasLens = envFileSystemL + hasLens = envFileSystemL env :: TestEnv -env = TestEnv - { envFileSystem = FileSystem { fsCreateDirectory = undefined - , fsDoesFileExist = undefined - , fsFindFiles = undefined - , fsFindFilesByExts = undefined - , fsFindFilesByTypes = undefined - , fsGetCurrentDirectory = undefined - , fsGetUserDirectory = undefined - , fsListFiles = undefined - , fsLoadFile = undefined - , fsWriteFile = undefined - } - } - +env = + TestEnv + { envFileSystem = + FileSystem + { fsCreateDirectory = undefined + , fsDoesFileExist = undefined + , fsFindFiles = undefined + , fsFindFilesByExts = undefined + , fsFindFilesByTypes = undefined + , fsGetCurrentDirectory = undefined + , fsGetUserDirectory = undefined + , fsListFiles = undefined + , fsLoadFile = undefined + , fsWriteFile = undefined + } + } spec :: Spec spec = do + describe "initGlobalConfigIfNeeded" $ do + it "creates new config file and parent directory when needed" $ do + withSystemTempDirectory "global-config" $ \dir -> do + let cfgPath = dir globalConfigDirName globalConfigFileName + fsCreateDirectory0 = fsCreateDirectory mkFileSystem + fsWriteFile0 = fsWriteFile mkFileSystem + env' = + env + & (envFileSystemL . fsCreateDirectoryL .~ fsCreateDirectory0) + & (envFileSystemL . fsDoesFileExistL .~ fsDoesFileExist') + & (envFileSystemL . fsGetUserDirectoryL .~ fsGetUserDirectory') + & (envFileSystemL . fsWriteFileL .~ fsWriteFile0) + fsDoesFileExist' = const . pure $ False + fsGetUserDirectory' = pure dir + _ <- runRIO env' initGlobalConfigIfNeeded + result <- doesFileExist cfgPath + result `shouldBe` True - describe "initGlobalConfigIfNeeded" $ do - it "creates new config file and parent directory when needed" $ do - withSystemTempDirectory "global-config" $ \dir -> do - let cfgPath = dir globalConfigDirName globalConfigFileName - fsCreateDirectory0 = fsCreateDirectory mkFileSystem - fsWriteFile0 = fsWriteFile mkFileSystem - env' = - env - & (envFileSystemL . fsCreateDirectoryL .~ fsCreateDirectory0) - & (envFileSystemL . fsDoesFileExistL .~ fsDoesFileExist') - & (envFileSystemL . fsGetUserDirectoryL .~ fsGetUserDirectory') - & (envFileSystemL . fsWriteFileL .~ fsWriteFile0) - fsDoesFileExist' = const . pure $ False - fsGetUserDirectory' = pure dir - _ <- runRIO env' initGlobalConfigIfNeeded - result <- doesFileExist cfgPath - result `shouldBe` True - - - describe "parseGlobalConfig" $ do - it "parses embedded default config YAML" $ do - parseGlobalConfig defaultGlobalConfig `shouldSatisfy` isRight + describe "parseGlobalConfig" $ do + it "parses embedded default config YAML" $ do + parseGlobalConfig defaultGlobalConfig `shouldSatisfy` isRight diff --git a/test/Headroom/ConfigSpec.hs b/test/Headroom/ConfigSpec.hs index fcf8977..5521e30 100644 --- a/test/Headroom/ConfigSpec.hs +++ b/test/Headroom/ConfigSpec.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Headroom.ConfigSpec - ( spec - ) -where +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config -import Headroom.Embedded ( defaultConfig ) -import RIO -import Test.Hspec +module Headroom.ConfigSpec ( + spec +) where +import Headroom.Config +import Headroom.Embedded (defaultConfig) +import RIO +import Test.Hspec spec :: Spec spec = do - describe "parseAppConfig" $ do - it "should parse default bundled configuration" $ do - parseAppConfig defaultConfig `shouldSatisfy` isJust + describe "parseAppConfig" $ do + it "should parse default bundled configuration" $ do + parseAppConfig defaultConfig `shouldSatisfy` isJust diff --git a/test/Headroom/Data/CoerceSpec.hs b/test/Headroom/Data/CoerceSpec.hs index 561aaa2..e96307b 100644 --- a/test/Headroom/Data/CoerceSpec.hs +++ b/test/Headroom/Data/CoerceSpec.hs @@ -1,24 +1,21 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.Data.CoerceSpec - ( spec - ) -where - -import Headroom.Data.Coerce -import RIO -import qualified RIO.Text as T -import Test.Hspec +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 - + 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/EnumExtraSpec.hs b/test/Headroom/Data/EnumExtraSpec.hs index ae79b28..1340167 100644 --- a/test/Headroom/Data/EnumExtraSpec.hs +++ b/test/Headroom/Data/EnumExtraSpec.hs @@ -1,36 +1,35 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -module Headroom.Data.EnumExtraSpec - ( spec - ) -where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Data.EnumExtra -import RIO -import Test.Hspec +module Headroom.Data.EnumExtraSpec ( + spec +) where + +import Headroom.Data.EnumExtra +import RIO +import Test.Hspec data TestEnum - = Foo - | Bar - deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + = Foo + | Bar + deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) spec :: Spec spec = do - describe "allValues" $ do - it "should return list of all enum values" $ do - allValues @TestEnum `shouldBe` [Foo, Bar] - - describe "allValuesToText" $ do - it "should pretty print all enum values" $ do - allValuesToText @TestEnum `shouldBe` "Foo, Bar" + describe "allValues" $ do + it "should return list of all enum values" $ do + allValues @TestEnum `shouldBe` [Foo, Bar] - describe "enumToText" $ do - it "should show textual representation of enum value" $ do - enumToText Foo `shouldBe` "Foo" + describe "allValuesToText" $ do + it "should pretty print all enum values" $ do + allValuesToText @TestEnum `shouldBe` "Foo, Bar" - describe "textToEnum" $ do - it "should read enum value from textual representation" $ do - textToEnum "foo" `shouldBe` Just Foo + describe "enumToText" $ do + it "should show textual representation of enum value" $ do + enumToText Foo `shouldBe` "Foo" + describe "textToEnum" $ do + it "should read enum value from textual representation" $ do + textToEnum "foo" `shouldBe` Just Foo diff --git a/test/Headroom/Data/RegexSpec.hs b/test/Headroom/Data/RegexSpec.hs index f578260..4be8493 100644 --- a/test/Headroom/Data/RegexSpec.hs +++ b/test/Headroom/Data/RegexSpec.hs @@ -1,31 +1,29 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Headroom.Data.RegexSpec - ( spec - ) -where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Data.Regex -import RIO -import Test.Hspec +module Headroom.Data.RegexSpec ( + spec +) where +import Headroom.Data.Regex +import RIO +import Test.Hspec spec :: Spec spec = do - describe "match" $ do - it "matches regular expression against given sample" $ do - let regex = [re|foo|bar|] - match regex "xxx" `shouldSatisfy` isNothing - match regex "foz" `shouldSatisfy` isNothing - match regex "foosdas" `shouldSatisfy` isJust - match regex "barfoo" `shouldSatisfy` isJust - + describe "match" $ do + it "matches regular expression against given sample" $ do + let regex = [re|foo|bar|] + match regex "xxx" `shouldSatisfy` isNothing + match regex "foz" `shouldSatisfy` isNothing + match regex "foosdas" `shouldSatisfy` isJust + match regex "barfoo" `shouldSatisfy` isJust - 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 + 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/SerializationSpec.hs b/test/Headroom/Data/SerializationSpec.hs index af26256..26839b0 100644 --- a/test/Headroom/Data/SerializationSpec.hs +++ b/test/Headroom/Data/SerializationSpec.hs @@ -1,35 +1,32 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Headroom.Data.SerializationSpec - ( spec - ) -where +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Data.Serialization -import RIO -import qualified RIO.Map as M -import Test.Hspec +module Headroom.Data.SerializationSpec ( + spec +) where +import Headroom.Data.Serialization +import RIO +import qualified RIO.Map as M +import Test.Hspec spec :: Spec spec = do - describe "dropFieldPrefix" $ do - it "removes prefix and lowercases first letter for 'prSomeField'" $ do - dropFieldPrefix "prSomeField" `shouldBe` "someField" - - it "removes prefix and keeps case for 'prURLField'" $ do - dropFieldPrefix "prURLField" `shouldBe` "URLField" - - - describe "symbolCase" $ do - it "replaces camel cased string into symbol cased" $ do - let input = "camelCasedValue" - expected = "camel-cased-value" - symbolCase '-' input `shouldBe` expected - - - describe "prettyPrintYAML" $ do - it "pretty prints YAML" $ do - let input = M.fromList [("foo" :: Text, ["bar"] :: [Text])] - expected = "foo:\n- bar\n" - prettyPrintYAML input `shouldBe` expected + describe "dropFieldPrefix" $ do + it "removes prefix and lowercases first letter for 'prSomeField'" $ do + dropFieldPrefix "prSomeField" `shouldBe` "someField" + + it "removes prefix and keeps case for 'prURLField'" $ do + dropFieldPrefix "prURLField" `shouldBe` "URLField" + + describe "symbolCase" $ do + it "replaces camel cased string into symbol cased" $ do + let input = "camelCasedValue" + expected = "camel-cased-value" + symbolCase '-' input `shouldBe` expected + + describe "prettyPrintYAML" $ do + it "pretty prints YAML" $ do + let input = M.fromList [("foo" :: Text, ["bar"] :: [Text])] + expected = "foo:\n- bar\n" + prettyPrintYAML input `shouldBe` expected diff --git a/test/Headroom/Data/TextSpec.hs b/test/Headroom/Data/TextSpec.hs index 8871b13..a0e7606 100644 --- a/test/Headroom/Data/TextSpec.hs +++ b/test/Headroom/Data/TextSpec.hs @@ -1,96 +1,87 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -module Headroom.Data.TextSpec - ( spec - ) -where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Data.Text -import RIO -import qualified RIO.Text as T -import Test.Hspec +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" + 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/FileSupport/CPPSpec.hs b/test/Headroom/FileSupport/CPPSpec.hs index 4829927..bdb3b5b 100644 --- a/test/Headroom/FileSupport/CPPSpec.hs +++ b/test/Headroom/FileSupport/CPPSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.CPPSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.CPP -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index b41a283..ddd30af 100644 --- a/test/Headroom/FileSupport/CSSSpec.hs +++ b/test/Headroom/FileSupport/CSSSpec.hs @@ -1,34 +1,31 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.CSSSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.CSS -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index f6a6a92..f2f168f 100644 --- a/test/Headroom/FileSupport/CSpec.hs +++ b/test/Headroom/FileSupport/CSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.CSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.C -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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/DartSpec.hs b/test/Headroom/FileSupport/DartSpec.hs index 37037f7..e2cd7bd 100644 --- a/test/Headroom/FileSupport/DartSpec.hs +++ b/test/Headroom/FileSupport/DartSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.DartSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.Dart -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +module Headroom.FileSupport.DartSpec ( + spec +) where +import Headroom.FileSupport.Dart +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 + 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/GoSpec.hs b/test/Headroom/FileSupport/GoSpec.hs index e02f812..f007d94 100644 --- a/test/Headroom/FileSupport/GoSpec.hs +++ b/test/Headroom/FileSupport/GoSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.GoSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.Go -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +module Headroom.FileSupport.GoSpec ( + spec +) where +import Headroom.FileSupport.Go +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 + 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 index 29b8f36..9e9042a 100644 --- a/test/Headroom/FileSupport/HTMLSpec.hs +++ b/test/Headroom/FileSupport/HTMLSpec.hs @@ -1,34 +1,31 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.HTMLSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.HTML -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index 706fadc..d13987f 100644 --- a/test/Headroom/FileSupport/Haskell/HaddockSpec.hs +++ b/test/Headroom/FileSupport/Haskell/HaddockSpec.hs @@ -1,107 +1,107 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.FileSupport.Haskell.HaddockSpec - ( spec - ) -where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config.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.FileType.Types ( FileType(..) ) -import Headroom.IO.FileSystem ( loadFile ) -import Headroom.Template ( Template(..) ) -import Headroom.Template.Mustache ( Mustache(..) ) -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -import RIO -import RIO.FilePath ( () ) -import Test.Hspec +module Headroom.FileSupport.Haskell.HaddockSpec ( + spec +) where +import Headroom.Config.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.FileType.Types (FileType (..)) +import Headroom.IO.FileSystem (loadFile) +import Headroom.Template (Template (..)) +import Headroom.Template.Mustache (Mustache (..)) +import Headroom.Template.TemplateRef (TemplateRef (..)) +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 (BuiltInRef BSD3 Haskell) - $ licenseTemplate BSD3 Haskell - let syntax = BlockComment [re|^{-\||] [re|(? "haskell" "header-block.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 (block)" - , 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|(? "code-samples" - it "extracts fields from Haddock line module header" $ do - raw <- loadFile $ codeSamples "haskell" "header-line.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 (line)" - , hmhLongDesc = - Just - "Here is a longer description of this module, containing some\n\ - \commentary with @some markup@." - } - sample = analyzeSourceCode (fileSupport Haskell) raw - syntax = LineComment [re|^--|] (Just "-- ") - extractModuleHeader sample NoTemplateData syntax `shouldBe` expected + describe "extractOffsets" $ do + it "extract offsets for selected fields of module header" $ do + template <- + parseTemplate @Mustache (BuiltInRef BSD3 Haskell) $ + licenseTemplate BSD3 Haskell + let syntax = BlockComment [re|^{-\||] [re|(? "haskell" "header-block.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 (block)" + , 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|(? "haskell" "header-line.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 (line)" + , hmhLongDesc = + Just + "Here is a longer description of this module, containing some\n\ + \commentary with @some markup@." + } + sample = analyzeSourceCode (fileSupport Haskell) raw + syntax = LineComment [re|^--|] (Just "-- ") + extractModuleHeader sample NoTemplateData syntax `shouldBe` expected - 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 + describe "indentField" $ do + it "does nothing with single line text" $ do + let sample = fromLines ["hello"] + offset = Just 2 + indentField offset sample `shouldBe` sample - 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 + 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/FileSupport/HaskellSpec.hs b/test/Headroom/FileSupport/HaskellSpec.hs index 67a237a..3666216 100644 --- a/test/Headroom/FileSupport/HaskellSpec.hs +++ b/test/Headroom/FileSupport/HaskellSpec.hs @@ -1,87 +1,93 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.FileSupport.HaskellSpec - ( spec - ) -where - -import Data.String.Interpolate ( __i ) -import Headroom.Config ( makeHeadersConfig - , parseAppConfig - ) -import Headroom.Config.Types ( AppConfig(..) - , HeaderSyntax(..) - , LicenseType(..) - ) -import Headroom.Data.Regex ( re ) -import Headroom.Embedded ( defaultConfig - , licenseTemplate - ) -import Headroom.FileSupport ( analyzeSourceCode - , fileSupport - ) -import Headroom.FileSupport.TemplateData ( HaddockOffsets(..) - , HaskellTemplateData'(..) - , TemplateData(..) - ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Header ( extractHeaderTemplate ) -import Headroom.IO.FileSystem ( loadFile ) -import Headroom.Template ( Template(..) - , emptyTemplate - ) -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -import Headroom.Variables ( mkVariables ) -import RIO -import RIO.FilePath ( () ) -import Test.Hspec +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Headroom.FileSupport.HaskellSpec ( + spec +) where + +import Data.String.Interpolate (__i) +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Types ( + AppConfig (..) + , HeaderSyntax (..) + , LicenseType (..) + ) +import Headroom.Data.Regex (re) +import Headroom.Embedded ( + defaultConfig + , licenseTemplate + ) +import Headroom.FileSupport ( + analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.TemplateData ( + HaddockOffsets (..) + , HaskellTemplateData' (..) + , TemplateData (..) + ) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + ) +import Headroom.FileType.Types (FileType (..)) +import Headroom.Header (extractHeaderTemplate) +import Headroom.IO.FileSystem (loadFile) +import Headroom.Template ( + Template (..) + , emptyTemplate + ) +import Headroom.Template.Mustache (Mustache) +import Headroom.Template.TemplateRef (TemplateRef (..)) +import Headroom.Variables (mkVariables) +import RIO +import RIO.FilePath (()) +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 (BuiltInRef BSD3 Haskell) - (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| + 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 + (BuiltInRef BSD3 Haskell) + (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 @@ -99,28 +105,28 @@ spec = do 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 + 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 index 9448b00..ec04f79 100644 --- a/test/Headroom/FileSupport/JSSpec.hs +++ b/test/Headroom/FileSupport/JSSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.JSSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.JS -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index 46f1e19..6edb24a 100644 --- a/test/Headroom/FileSupport/JavaSpec.hs +++ b/test/Headroom/FileSupport/JavaSpec.hs @@ -1,82 +1,78 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.FileSupport.JavaSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config ( makeHeadersConfig - , parseAppConfig - ) -import Headroom.Config.Types ( AppConfig(..) ) -import Headroom.Embedded ( defaultConfig ) -import Headroom.FileSupport ( analyzeSourceCode - , fileSupport - ) -import Headroom.FileSupport.TemplateData ( TemplateData(..) ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import Headroom.FileType.Types ( FileType(Java) ) -import Headroom.Header ( extractHeaderTemplate ) -import Headroom.IO.FileSystem ( loadFile ) -import Headroom.Template ( emptyTemplate ) -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Variables ( mkVariables ) -import RIO -import RIO.FilePath ( () ) -import Test.Hspec +module Headroom.FileSupport.JavaSpec ( + spec +) where +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Types (AppConfig (..)) +import Headroom.Embedded (defaultConfig) +import Headroom.FileSupport ( + analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.TemplateData (TemplateData (..)) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + ) +import Headroom.FileType.Types (FileType (Java)) +import Headroom.Header (extractHeaderTemplate) +import Headroom.IO.FileSystem (loadFile) +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)) - , ("/** JavaDoc 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 - + let codeSamples = "test-data" "code-samples" "java" - describe "fsExtractVariables" $ do - it "extract variables from Java source code" $ do - template <- emptyTemplate @_ @Mustache - defaultConfig' <- parseAppConfig defaultConfig - config <- makeHeadersConfig (acLicenseHeaders 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 "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)) + , ("/** JavaDoc 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 "fsFileType" $ do - it "matches correct type for Java" $ do - fsFileType fileSupport' `shouldBe` Java + describe "fsExtractVariables" $ do + it "extract variables from Java source code" $ do + template <- emptyTemplate @_ @Mustache + defaultConfig' <- parseAppConfig defaultConfig + config <- makeHeadersConfig (acLicenseHeaders 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 - where - fileSupport' = fileSupport Java - checkSyntaxAnalysis (l, (s, e)) = - let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport' - in saIsCommentStart l == s && saIsCommentEnd l == e + 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/KotlinSpec.hs b/test/Headroom/FileSupport/KotlinSpec.hs index 23a0c02..c2b49c0 100644 --- a/test/Headroom/FileSupport/KotlinSpec.hs +++ b/test/Headroom/FileSupport/KotlinSpec.hs @@ -1,82 +1,78 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.FileSupport.KotlinSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config ( makeHeadersConfig - , parseAppConfig - ) -import Headroom.Config.Types ( AppConfig(..) ) -import Headroom.Embedded ( defaultConfig ) -import Headroom.FileSupport ( analyzeSourceCode - , fileSupport - ) -import Headroom.FileSupport.TemplateData ( TemplateData(..) ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import Headroom.FileType.Types ( FileType(Kotlin) ) -import Headroom.Header ( extractHeaderTemplate ) -import Headroom.IO.FileSystem ( loadFile ) -import Headroom.Template ( emptyTemplate ) -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Variables ( mkVariables ) -import RIO -import RIO.FilePath ( () ) -import Test.Hspec +module Headroom.FileSupport.KotlinSpec ( + spec +) where +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Types (AppConfig (..)) +import Headroom.Embedded (defaultConfig) +import Headroom.FileSupport ( + analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.TemplateData (TemplateData (..)) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + ) +import Headroom.FileType.Types (FileType (Kotlin)) +import Headroom.Header (extractHeaderTemplate) +import Headroom.IO.FileSystem (loadFile) +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" "kotlin" - - - 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)) - , ("/** KDoc comment start/end */", (True, True)) - ] - all checkSyntaxAnalysis samples `shouldBe` True - - - describe "fsExtractTemplateData" $ do - it "doesn't provide any custom data for Kotlin" $ do - template <- emptyTemplate @_ @Mustache - let syntax = undefined - expected = NoTemplateData - fsExtractTemplateData fileSupport' template syntax `shouldBe` expected - + let codeSamples = "test-data" "code-samples" "kotlin" - describe "fsExtractVariables" $ do - it "extract variables from Kotlin source code" $ do - template <- emptyTemplate @_ @Mustache - defaultConfig' <- parseAppConfig defaultConfig - config <- makeHeadersConfig (acLicenseHeaders defaultConfig') - raw <- loadFile $ codeSamples "sample1.kt" - let ht = extractHeaderTemplate config Kotlin template - headerPos = Just (0, 2) - expected = mkVariables [("_kotlin_package_name", "foo")] - sample = analyzeSourceCode fileSupport' raw - fsExtractVariables fileSupport' ht headerPos sample `shouldBe` expected + 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)) + , ("/** KDoc comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + describe "fsExtractTemplateData" $ do + it "doesn't provide any custom data for Kotlin" $ do + template <- emptyTemplate @_ @Mustache + let syntax = undefined + expected = NoTemplateData + fsExtractTemplateData fileSupport' template syntax `shouldBe` expected - describe "fsFileType" $ do - it "matches correct type for Kotlin" $ do - fsFileType fileSupport' `shouldBe` Kotlin + describe "fsExtractVariables" $ do + it "extract variables from Kotlin source code" $ do + template <- emptyTemplate @_ @Mustache + defaultConfig' <- parseAppConfig defaultConfig + config <- makeHeadersConfig (acLicenseHeaders defaultConfig') + raw <- loadFile $ codeSamples "sample1.kt" + let ht = extractHeaderTemplate config Kotlin template + headerPos = Just (0, 2) + expected = mkVariables [("_kotlin_package_name", "foo")] + sample = analyzeSourceCode fileSupport' raw + fsExtractVariables fileSupport' ht headerPos sample `shouldBe` expected - where - fileSupport' = fileSupport Kotlin - checkSyntaxAnalysis (l, (s, e)) = - let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport' - in saIsCommentStart l == s && saIsCommentEnd l == e + describe "fsFileType" $ do + it "matches correct type for Kotlin" $ do + fsFileType fileSupport' `shouldBe` Kotlin + where + fileSupport' = fileSupport Kotlin + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis{..} = fsSyntaxAnalysis fileSupport' + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/PHPSpec.hs b/test/Headroom/FileSupport/PHPSpec.hs index 8a2bff9..b62a08e 100644 --- a/test/Headroom/FileSupport/PHPSpec.hs +++ b/test/Headroom/FileSupport/PHPSpec.hs @@ -1,38 +1,35 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.PHPSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.PHP -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +module Headroom.FileSupport.PHPSpec ( + spec +) where +import Headroom.FileSupport.PHP +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)) - , ("/** DocBlock comment start" , (True, False)) - , ("block comment end */" , (False, True)) - , ("/* block comment start/end */" , (True, True)) - , ("/** DocBlock 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 + 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)) + , ("/** DocBlock comment start", (True, False)) + , ("block comment end */", (False, True)) + , ("/* block comment start/end */", (True, True)) + , ("/** DocBlock 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/PureScriptSpec.hs b/test/Headroom/FileSupport/PureScriptSpec.hs index 9254ec7..35150ba 100644 --- a/test/Headroom/FileSupport/PureScriptSpec.hs +++ b/test/Headroom/FileSupport/PureScriptSpec.hs @@ -1,81 +1,77 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.FileSupport.PureScriptSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config ( makeHeadersConfig - , parseAppConfig - ) -import Headroom.Config.Types ( AppConfig(..) ) -import Headroom.Embedded ( defaultConfig ) -import Headroom.FileSupport ( analyzeSourceCode - , fileSupport - ) -import Headroom.FileSupport.TemplateData ( TemplateData(..) ) -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Header ( extractHeaderTemplate ) -import Headroom.IO.FileSystem ( loadFile ) -import Headroom.Template ( emptyTemplate ) -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Variables ( mkVariables ) -import RIO -import RIO.FilePath ( () ) -import Test.Hspec +module Headroom.FileSupport.PureScriptSpec ( + spec +) where +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Types (AppConfig (..)) +import Headroom.Embedded (defaultConfig) +import Headroom.FileSupport ( + analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.TemplateData (TemplateData (..)) +import Headroom.FileSupport.Types ( + FileSupport (..) + , SyntaxAnalysis (..) + ) +import Headroom.FileType.Types (FileType (..)) +import Headroom.Header (extractHeaderTemplate) +import Headroom.IO.FileSystem (loadFile) +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 - + let codeSamples = "test-data" "code-samples" "purescript" - describe "fsExtractVariables" $ do - it "extract variables from PureScript source code" $ do - template <- emptyTemplate @_ @Mustache - defaultConfig' <- parseAppConfig defaultConfig - config <- makeHeadersConfig (acLicenseHeaders 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 "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 "fsFileType" $ do - it "matches correct type for PureScript" $ do - fsFileType fileSupport' `shouldBe` PureScript + describe "fsExtractVariables" $ do + it "extract variables from PureScript source code" $ do + template <- emptyTemplate @_ @Mustache + defaultConfig' <- parseAppConfig defaultConfig + config <- makeHeadersConfig (acLicenseHeaders 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 - where - fileSupport' = fileSupport PureScript - checkSyntaxAnalysis (l, (s, e)) = - let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport' - in saIsCommentStart l == s && saIsCommentEnd l == e + 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/PythonSpec.hs b/test/Headroom/FileSupport/PythonSpec.hs index 97235dc..f7f6cde 100644 --- a/test/Headroom/FileSupport/PythonSpec.hs +++ b/test/Headroom/FileSupport/PythonSpec.hs @@ -1,33 +1,30 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.PythonSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.Python -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +module Headroom.FileSupport.PythonSpec ( + spec +) where +import Headroom.FileSupport.Python +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 + 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/FileSupport/RustSpec.hs b/test/Headroom/FileSupport/RustSpec.hs index aeb39da..d970494 100644 --- a/test/Headroom/FileSupport/RustSpec.hs +++ b/test/Headroom/FileSupport/RustSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.RustSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.Rust -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index e501979..5927a69 100644 --- a/test/Headroom/FileSupport/ScalaSpec.hs +++ b/test/Headroom/FileSupport/ScalaSpec.hs @@ -1,36 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.ScalaSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.Scala -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index 9beaa69..a9a02bf 100644 --- a/test/Headroom/FileSupport/ShellSpec.hs +++ b/test/Headroom/FileSupport/ShellSpec.hs @@ -1,33 +1,30 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Headroom.FileSupport.ShellSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.FileSupport.Shell -import Headroom.FileSupport.Types ( FileSupport(..) - , SyntaxAnalysis(..) - ) -import RIO -import Test.Hspec +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 + 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 index a723262..45bbdbc 100644 --- a/test/Headroom/FileSupportSpec.hs +++ b/test/Headroom/FileSupportSpec.hs @@ -1,359 +1,374 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.FileSupportSpec - ( spec - ) -where - -import Headroom.FileSupport -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.IO.FileSystem ( loadFile ) -import Headroom.SourceCode ( LineType(..) - , SourceCode(..) - ) -import RIO -import RIO.FilePath ( () ) -import Test.Hspec +module Headroom.FileSupportSpec ( + spec +) where +import Headroom.FileSupport +import Headroom.FileType.Types (FileType (..)) +import Headroom.IO.FileSystem (loadFile) +import Headroom.SourceCode ( + LineType (..) + , SourceCode (..) + ) +import RIO +import RIO.FilePath (()) +import Test.Hspec spec :: Spec spec = do - let codeSamples = "test-data" "code-samples" + let codeSamples = "test-data" "code-samples" - 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 + 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 "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 "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 "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 "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 "analyzes Dart source code" $ do - sample <- loadFile $ codeSamples "go" "sample1.go" - let expected = SourceCode - [ (Code , "") - , (Comment, "// This is the") - , (Comment, "// header") - , (Code , "") - , (Code , "package main") - , (Code , "") - , (Comment, "// this is not the header") - , (Code , "import \"fmt\"") - , (Code , "func main() {") - , (Comment, " /* another comment */") - , (Code, " fmt.Println(\"hello world\")") - , (Code , "") - , (Comment, " /*") - , (Comment, " * block comment") - , (Comment, " */") - , (Code , "}") - ] - analyzeSourceCode (fileSupport Go) sample `shouldBe` expected + it "analyzes Dart source code" $ do + sample <- loadFile $ codeSamples "go" "sample1.go" + let expected = + SourceCode + [ (Code, "") + , (Comment, "// This is the") + , (Comment, "// header") + , (Code, "") + , (Code, "package main") + , (Code, "") + , (Comment, "// this is not the header") + , (Code, "import \"fmt\"") + , (Code, "func main() {") + , (Comment, " /* another comment */") + , (Code, " fmt.Println(\"hello world\")") + , (Code, "") + , (Comment, " /*") + , (Comment, " * block comment") + , (Comment, " */") + , (Code, "}") + ] + analyzeSourceCode (fileSupport Go) sample `shouldBe` expected - it "analyzes Go source code" $ do - sample <- loadFile $ codeSamples "dart" "sample1.dart" - let expected = SourceCode - [ (Code , "") - , (Comment, "// This is the") - , (Comment, "// header") - , (Code , "") - , (Comment, "// this is not header") - , (Code , "") - , (Comment, "// this is not the header") - , (Code , "void main() {") - , (Comment, " /* another comment */") - , (Code , " print('Hello, World!');") - , (Code , "}") - ] - analyzeSourceCode (fileSupport Dart) sample `shouldBe` expected + it "analyzes Go source code" $ do + sample <- loadFile $ codeSamples "dart" "sample1.dart" + let expected = + SourceCode + [ (Code, "") + , (Comment, "// This is the") + , (Comment, "// header") + , (Code, "") + , (Comment, "// this is not header") + , (Code, "") + , (Comment, "// this is not the header") + , (Code, "void main() {") + , (Comment, " /* another comment */") + , (Code, " print('Hello, World!');") + , (Code, "}") + ] + analyzeSourceCode (fileSupport Dart) 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 "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 "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 "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 "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 "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 "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 "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 "analyzes Kotlin source code" $ do - sample <- loadFile $ codeSamples "kotlin" "sample1.kt" - let expected = SourceCode - [ (Comment, "/*") - , (Comment, " * This is copyright header") - , (Comment, " */") - , (Code , "") - , (Code , "package foo") - , (Code , "") - , (Comment, "/** this is not license header */") - , (Code, "fun main(args : Array) {") - , (Code , " println(\"Hello, World!\")") - , (Code , "}") - ] - analyzeSourceCode (fileSupport Kotlin) sample `shouldBe` expected + it "analyzes Kotlin source code" $ do + sample <- loadFile $ codeSamples "kotlin" "sample1.kt" + let expected = + SourceCode + [ (Comment, "/*") + , (Comment, " * This is copyright header") + , (Comment, " */") + , (Code, "") + , (Code, "package foo") + , (Code, "") + , (Comment, "/** this is not license header */") + , (Code, "fun main(args : Array) {") + , (Code, " println(\"Hello, World!\")") + , (Code, "}") + ] + analyzeSourceCode (fileSupport Kotlin) sample `shouldBe` expected - it "analyzes PHP source code" $ do - sample <- loadFile $ codeSamples "php" "sample1.php" - let - expected = SourceCode - [ (Code , " "php" "sample1.php" + let expected = + SourceCode + [ (Code, " "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 "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 "analyzes Python source code" $ do - sample <- loadFile $ codeSamples "python" "sample1.py" - let expected = SourceCode - [ (Code , "#!/usr/bin/env python3") - , (Code , "") - , (Comment, "# This is") - , (Comment, "# header") - , (Code , "") - , (Comment, "# This is not") - , (Code , "") - , (Code, "print(\"This line will be printed.\")") - ] - analyzeSourceCode (fileSupport Python) sample `shouldBe` expected + it "analyzes Python source code" $ do + sample <- loadFile $ codeSamples "python" "sample1.py" + let expected = + SourceCode + [ (Code, "#!/usr/bin/env python3") + , (Code, "") + , (Comment, "# This is") + , (Comment, "# header") + , (Code, "") + , (Comment, "# This is not") + , (Code, "") + , (Code, "print(\"This line will be printed.\")") + ] + analyzeSourceCode (fileSupport Python) 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 "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 "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 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 + 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/FileTypeSpec.hs b/test/Headroom/FileTypeSpec.hs index c157cfb..8cdb72a 100644 --- a/test/Headroom/FileTypeSpec.hs +++ b/test/Headroom/FileTypeSpec.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Headroom.FileTypeSpec - ( spec - ) -where +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config ( makeHeadersConfig - , parseAppConfig - ) -import Headroom.Config.Types ( AppConfig(..) ) -import Headroom.Embedded ( defaultConfig ) -import Headroom.FileType -import Headroom.FileType.Types ( FileType(..) ) -import RIO -import Test.Hspec +module Headroom.FileTypeSpec ( + spec +) where +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Types (AppConfig (..)) +import Headroom.Embedded (defaultConfig) +import Headroom.FileType +import Headroom.FileType.Types (FileType (..)) +import RIO +import Test.Hspec spec :: Spec spec = do - describe "fileTypeByExt" $ do - it "parses FileType from file extension" $ do - pHeadersConfig <- acLicenseHeaders <$> parseAppConfig defaultConfig - headersConfig <- makeHeadersConfig pHeadersConfig - fileTypeByExt headersConfig "hs" `shouldBe` Just Haskell + describe "fileTypeByExt" $ do + it "parses FileType from file extension" $ do + pHeadersConfig <- acLicenseHeaders <$> parseAppConfig defaultConfig + headersConfig <- makeHeadersConfig pHeadersConfig + fileTypeByExt headersConfig "hs" `shouldBe` Just Haskell diff --git a/test/Headroom/Header/SanitizeSpec.hs b/test/Headroom/Header/SanitizeSpec.hs index 1707099..1b5602c 100644 --- a/test/Headroom/Header/SanitizeSpec.hs +++ b/test/Headroom/Header/SanitizeSpec.hs @@ -1,132 +1,132 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Headroom.Header.SanitizeSpec - ( spec - ) -where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Config.Types ( HeaderSyntax(..) ) -import Headroom.Data.Regex ( re ) -import Headroom.Data.Text ( fromLines ) -import Headroom.Header.Sanitize -import RIO -import Test.Hspec +module Headroom.Header.SanitizeSpec ( + spec +) where +import Headroom.Config.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 - ) +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Headroom.HeaderSpec ( + spec +) where + +import Headroom.Config ( + makeHeadersConfig + , parseAppConfig + ) +import Headroom.Config.Types ( + AppConfig (..) + , HeaderConfig (..) + , HeaderSyntax (..) + , HeadersConfig (..) + ) +import Headroom.Data.Regex (re) +import Headroom.Embedded (defaultConfig) +import Headroom.FileSupport ( + analyzeSourceCode + , fileSupport + ) +import Headroom.FileType.Types (FileType (..)) +import Headroom.Header +import Headroom.Header.Types (HeaderInfo (..)) +import Headroom.IO.FileSystem (loadFile) +import Headroom.SourceCode ( + LineType (..) + , SourceCode (..) + ) +import RIO +import RIO.FilePath (()) +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' <- parseAppConfig defaultConfig - HeadersConfig {..} <- makeHeadersConfig (acLicenseHeaders 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" - sampleDart <- loadSample Dart $ "dart" "sample1.dart" - sampleGo <- loadSample Go $ "go" "sample1.go" - 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" - sampleKotlin <- loadSample Kotlin $ "kotlin" "sample1.kt" - samplePhp1 <- loadSample PHP $ "php" "sample1.php" - samplePureScript1 <- loadSample PureScript $ "purescript" "full.purs" - samplePython1 <- loadSample Python $ "python" "sample1.py" - 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 hscDart sampleDart `shouldBe` Just (1, 2) - findHeader hscGo sampleGo `shouldBe` Just (1, 2) - 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 hscKotlin sampleKotlin `shouldBe` Just (0, 2) - findHeader hscPhp samplePhp1 `shouldBe` Just (2, 8) - findHeader hscPureScript samplePureScript1 `shouldBe` Just (1, 1) - findHeader hscPython samplePython1 `shouldBe` Just (2, 3) - 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 + 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' <- parseAppConfig defaultConfig + HeadersConfig{..} <- makeHeadersConfig (acLicenseHeaders 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" + sampleDart <- loadSample Dart $ "dart" "sample1.dart" + sampleGo <- loadSample Go $ "go" "sample1.go" + 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" + sampleKotlin <- loadSample Kotlin $ "kotlin" "sample1.kt" + samplePhp1 <- loadSample PHP $ "php" "sample1.php" + samplePureScript1 <- loadSample PureScript $ "purescript" "full.purs" + samplePython1 <- loadSample Python $ "python" "sample1.py" + 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 hscDart sampleDart `shouldBe` Just (1, 2) + findHeader hscGo sampleGo `shouldBe` Just (1, 2) + 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 hscKotlin sampleKotlin `shouldBe` Just (0, 2) + findHeader hscPhp samplePhp1 `shouldBe` Just (2, 8) + findHeader hscPureScript samplePureScript1 `shouldBe` Just (1, 1) + findHeader hscPython samplePython1 `shouldBe` Just (2, 3) + 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/IO/FileSystemSpec.hs b/test/Headroom/IO/FileSystemSpec.hs index b7342ab..c782f1d 100644 --- a/test/Headroom/IO/FileSystemSpec.hs +++ b/test/Headroom/IO/FileSystemSpec.hs @@ -1,71 +1,65 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Headroom.IO.FileSystemSpec - ( spec - ) -where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Data.Regex ( re ) -import Headroom.IO.FileSystem -import RIO -import RIO.FilePath ( () ) -import qualified RIO.List as L -import RIO.List ( sort ) -import Test.Hspec +module Headroom.IO.FileSystemSpec ( + spec +) where +import Headroom.Data.Regex (re) +import Headroom.IO.FileSystem +import RIO +import RIO.FilePath (()) +import RIO.List (sort) +import qualified RIO.List as L +import Test.Hspec spec :: Spec spec = do - describe "fileExtension" $ do - it "returns file extension for valid file path" $ do - fileExtension "/some/path/to/file.txt" `shouldBe` Just "txt" - - it "returns nothing for invalid file path" $ do - fileExtension "/some/nonsense/path" `shouldBe` Nothing - - - describe "findFiles" $ do - it "recursively finds files filtered by given predicate" $ do - let path = "test-data" "test-traverse" - predicate = ("b.html" `L.isSuffixOf`) - expected = ["test-data" "test-traverse" "foo" "b.html"] - sort <$> findFiles path predicate `shouldReturn` sort expected - + describe "fileExtension" $ do + it "returns file extension for valid file path" $ do + fileExtension "/some/path/to/file.txt" `shouldBe` Just "txt" - describe "findFilesByExts" $ do - it "recursively finds files filtered by its file extension" $ do - let path = "test-data" "test-traverse" - exts = ["xml"] - expected = ["test-data" "test-traverse" "foo" "test.xml"] - sort <$> findFilesByExts path exts `shouldReturn` sort expected + it "returns nothing for invalid file path" $ do + fileExtension "/some/nonsense/path" `shouldBe` Nothing + describe "findFiles" $ do + it "recursively finds files filtered by given predicate" $ do + let path = "test-data" "test-traverse" + predicate = ("b.html" `L.isSuffixOf`) + expected = ["test-data" "test-traverse" "foo" "b.html"] + sort <$> findFiles path predicate `shouldReturn` sort expected - describe "listFiles" $ do - it "recursively finds all files in directory" $ do - let path = "test-data" "test-traverse" - expected = - [ "test-data" "test-traverse" "a.html" - , "test-data" "test-traverse" "foo" "b.html" - , "test-data" "test-traverse" "foo" "test.xml" - , "test-data" "test-traverse" "foo" "bar" "c.html" - ] - sort <$> listFiles path `shouldReturn` sort expected + describe "findFilesByExts" $ do + it "recursively finds files filtered by its file extension" $ do + let path = "test-data" "test-traverse" + exts = ["xml"] + expected = ["test-data" "test-traverse" "foo" "test.xml"] + sort <$> findFilesByExts path exts `shouldReturn` sort expected - it "returns file if file path is passed as argument" $ do - let path = "test-data" "test-traverse" "a.html" - sort <$> listFiles path `shouldReturn` [path] + describe "listFiles" $ do + it "recursively finds all files in directory" $ do + let path = "test-data" "test-traverse" + expected = + [ "test-data" "test-traverse" "a.html" + , "test-data" "test-traverse" "foo" "b.html" + , "test-data" "test-traverse" "foo" "test.xml" + , "test-data" "test-traverse" "foo" "bar" "c.html" + ] + sort <$> listFiles path `shouldReturn` sort expected + it "returns file if file path is passed as argument" $ do + let path = "test-data" "test-traverse" "a.html" + sort <$> listFiles path `shouldReturn` [path] - describe "excludePaths" $ do - it "excludes paths matching selected pattern from input list" $ do - let patterns = [[re|\.stack-work|], [re|remove\.txt|]] - sample = - [ "/foo/bar/.stack-work/xx" - , "/hello/world" - , "foo/bar/remove.txt" - , "xx/yy" - ] - expected = ["/hello/world", "xx/yy"] - excludePaths patterns sample `shouldBe` expected + describe "excludePaths" $ do + it "excludes paths matching selected pattern from input list" $ do + let patterns = [[re|\.stack-work|], [re|remove\.txt|]] + sample = + [ "/foo/bar/.stack-work/xx" + , "/hello/world" + , "foo/bar/remove.txt" + , "xx/yy" + ] + expected = ["/hello/world", "xx/yy"] + excludePaths patterns sample `shouldBe` expected diff --git a/test/Headroom/IO/KVStoreSpec.hs b/test/Headroom/IO/KVStoreSpec.hs index eb7b5d1..b45d3ed 100644 --- a/test/Headroom/IO/KVStoreSpec.hs +++ b/test/Headroom/IO/KVStoreSpec.hs @@ -1,58 +1,52 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.IO.KVStoreSpec - ( spec - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.IO.KVStore -import RIO -import RIO.FilePath ( () ) -import qualified RIO.Text as T -import RIO.Time -import Test.Hspec +module Headroom.IO.KVStoreSpec ( + spec +) where +import Headroom.IO.KVStore +import RIO +import RIO.FilePath (()) +import qualified RIO.Text as T +import RIO.Time +import Test.Hspec spec :: Spec spec = do - - describe "SQLite store" $ do - it "reads and writes values from/to store" $ do - withSystemTempDirectory "sqlite-kvstore" $ \dir -> do - let path = StorePath . T.pack $ dir "test-db.sqlite" - fstKey = valueKey @Text "fst-key" - sndKey = valueKey @Text "snd-key" - KVStore {..} = sqliteKVStore path - maybeFst <- kvGetValue fstKey - _ <- kvPutValue sndKey "foo" - _ <- kvPutValue sndKey "bar" - maybeSnd <- kvGetValue sndKey - maybeFst `shouldBe` Nothing - maybeSnd `shouldBe` Just "bar" - - - describe "In-memory store" $ do - it "reads and writes values from/to store" $ do - let fstKey = valueKey @Text "fst-key" - sndKey = valueKey @Text "snd-key" - KVStore {..} <- inMemoryKVStore - maybeFst <- kvGetValue fstKey - _ <- kvPutValue sndKey "foo" - _ <- kvPutValue sndKey "bar" - maybeSnd <- kvGetValue sndKey - maybeFst `shouldBe` Nothing - maybeSnd `shouldBe` Just "bar" - - - describe "ValueCodec type class" $ do - it "has working instance for Text" $ do - let sample = "The Cake is a Lie" - decodeValue @Text (encodeValue sample) `shouldBe` Just sample - - it "has working instance for UTCTime" $ do - sample <- getCurrentTime - decodeValue @UTCTime (encodeValue sample) `shouldBe` Just sample - + describe "SQLite store" $ do + it "reads and writes values from/to store" $ do + withSystemTempDirectory "sqlite-kvstore" $ \dir -> do + let path = StorePath . T.pack $ dir "test-db.sqlite" + fstKey = valueKey @Text "fst-key" + sndKey = valueKey @Text "snd-key" + KVStore{..} = sqliteKVStore path + maybeFst <- kvGetValue fstKey + _ <- kvPutValue sndKey "foo" + _ <- kvPutValue sndKey "bar" + maybeSnd <- kvGetValue sndKey + maybeFst `shouldBe` Nothing + maybeSnd `shouldBe` Just "bar" + + describe "In-memory store" $ do + it "reads and writes values from/to store" $ do + let fstKey = valueKey @Text "fst-key" + sndKey = valueKey @Text "snd-key" + KVStore{..} <- inMemoryKVStore + maybeFst <- kvGetValue fstKey + _ <- kvPutValue sndKey "foo" + _ <- kvPutValue sndKey "bar" + maybeSnd <- kvGetValue sndKey + maybeFst `shouldBe` Nothing + maybeSnd `shouldBe` Just "bar" + + describe "ValueCodec type class" $ do + it "has working instance for Text" $ do + let sample = "The Cake is a Lie" + decodeValue @Text (encodeValue sample) `shouldBe` Just sample + + it "has working instance for UTCTime" $ do + sample <- getCurrentTime + decodeValue @UTCTime (encodeValue sample) `shouldBe` Just sample diff --git a/test/Headroom/Meta/VersionSpec.hs b/test/Headroom/Meta/VersionSpec.hs index 915f79a..cbade05 100644 --- a/test/Headroom/Meta/VersionSpec.hs +++ b/test/Headroom/Meta/VersionSpec.hs @@ -1,45 +1,39 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.Meta.VersionSpec - ( spec - ) -where +module Headroom.Meta.VersionSpec ( + spec +) where -import Headroom.Meta.Version -import RIO -import Test.Hspec +import Headroom.Meta.Version +import RIO +import Test.Hspec spec :: Spec spec = do - describe "Ord instance" $ do - it "correctly compare two values" $ do - compare [pvp|1.2.3.4|] [pvp|1.2.3.4|] `shouldBe` EQ - compare [pvp|0.1.0.0|] [pvp|0.1.0.1|] `shouldBe` LT - compare [pvp|1.1.0.0|] [pvp|0.1.0.1|] `shouldBe` GT - - - describe "parseVersion" $ do - it "parses valid Version from Text" $ do - parseVersion "0.1.2.3" `shouldBe` Just [pvp|0.1.2.3|] - parseVersion "v0.1.2.3" `shouldBe` Just [pvp|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 [pvp|1.2.3.4|] `shouldBe` "1.2.3.4" - - - describe "printVersionP" $ do - it "pretty prints given version (with 'v' prefix)" $ do - printVersionP [pvp|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 - + describe "Ord instance" $ do + it "correctly compare two values" $ do + compare [pvp|1.2.3.4|] [pvp|1.2.3.4|] `shouldBe` EQ + compare [pvp|0.1.0.0|] [pvp|0.1.0.1|] `shouldBe` LT + compare [pvp|1.1.0.0|] [pvp|0.1.0.1|] `shouldBe` GT + + describe "parseVersion" $ do + it "parses valid Version from Text" $ do + parseVersion "0.1.2.3" `shouldBe` Just [pvp|0.1.2.3|] + parseVersion "v0.1.2.3" `shouldBe` Just [pvp|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 [pvp|1.2.3.4|] `shouldBe` "1.2.3.4" + + describe "printVersionP" $ do + it "pretty prints given version (with 'v' prefix)" $ do + printVersionP [pvp|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/PostProcess/TypesSpec.hs b/test/Headroom/PostProcess/TypesSpec.hs index 520fc84..3d421d1 100644 --- a/test/Headroom/PostProcess/TypesSpec.hs +++ b/test/Headroom/PostProcess/TypesSpec.hs @@ -1,77 +1,69 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.PostProcess.TypesSpec - ( spec - ) -where - -import Headroom.Data.Has ( Has(..) ) -import Headroom.PostProcess ( postProcess ) -import Headroom.PostProcess.Types -import RIO -import Test.Hspec +module Headroom.PostProcess.TypesSpec ( + spec +) where +import Headroom.Data.Has (Has (..)) +import Headroom.PostProcess (postProcess) +import Headroom.PostProcess.Types +import RIO +import Test.Hspec spec :: Spec spec = do - - describe "Semigroup PostProcess" $ do - it "combines two values together" $ do - let fooEnv = FooEnv "_FOO_ENV" - barEnv = BarEnv "_BAR_ENV" - combinedEnv = CombinedEnv fooEnv barEnv - input = "input" - combinedFn = fooFn <> barFn - expected = "input_FOO_ENV_BAR_ENV" - postProcess combinedFn combinedEnv input `shouldBe` expected - - - describe "Monoid PostProcess" $ do - it "does nothing with the input" $ do - let input = "input" - testEnv = undefined - testFn = mempty - postProcess testFn testEnv input `shouldBe` input - + describe "Semigroup PostProcess" $ do + it "combines two values together" $ do + let fooEnv = FooEnv "_FOO_ENV" + barEnv = BarEnv "_BAR_ENV" + combinedEnv = CombinedEnv fooEnv barEnv + input = "input" + combinedFn = fooFn <> barFn + expected = "input_FOO_ENV_BAR_ENV" + postProcess combinedFn combinedEnv input `shouldBe` expected + + describe "Monoid PostProcess" $ do + it "does nothing with the input" $ do + let input = "input" + testEnv = undefined + testFn = mempty + postProcess testFn testEnv input `shouldBe` input ------------------------------- Test Data Types ------------------------------ - data FooEnv = FooEnv - { feValue :: Text - } + { feValue :: Text + } data BarEnv = BarEnv - { beValue :: Text - } + { beValue :: Text + } data CombinedEnv = CombinedEnv - { ceFooEnv :: FooEnv - , ceBarEnv :: BarEnv - } - + { ceFooEnv :: FooEnv + , ceBarEnv :: BarEnv + } instance Has FooEnv FooEnv where - hasLens = id + hasLens = id instance Has FooEnv CombinedEnv where - hasLens = lens ceFooEnv (\x y -> x { ceFooEnv = y }) + hasLens = lens ceFooEnv (\x y -> x{ceFooEnv = y}) instance Has BarEnv CombinedEnv where - hasLens = lens ceBarEnv (\x y -> x { ceBarEnv = y }) - + hasLens = lens ceBarEnv (\x y -> x{ceBarEnv = y}) fooFn :: (Has FooEnv env) => PostProcess env fooFn = PostProcess $ \input -> do - FooEnv {..} <- viewL - pure $ input <> feValue + FooEnv{..} <- viewL + pure $ input <> feValue barFn :: (Has BarEnv env) => PostProcess env barFn = PostProcess $ \input -> do - BarEnv {..} <- viewL - pure $ input <> beValue + BarEnv{..} <- viewL + pure $ input <> beValue diff --git a/test/Headroom/PostProcess/UpdateCopyrightSpec.hs b/test/Headroom/PostProcess/UpdateCopyrightSpec.hs index 439b30f..489647c 100644 --- a/test/Headroom/PostProcess/UpdateCopyrightSpec.hs +++ b/test/Headroom/PostProcess/UpdateCopyrightSpec.hs @@ -1,115 +1,113 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} - -module Headroom.PostProcess.UpdateCopyrightSpec - ( spec - ) -where - -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Text ( fromLines ) -import Headroom.PostProcess ( postProcess ) -import Headroom.PostProcess.UpdateCopyright -import Headroom.Types ( CurrentYear(..) ) -import RIO -import Test.Hspec - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Headroom.PostProcess.UpdateCopyrightSpec ( + spec +) where + +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Text (fromLines) +import Headroom.PostProcess (postProcess) +import Headroom.PostProcess.UpdateCopyright +import Headroom.Types (CurrentYear (..)) +import RIO +import Test.Hspec spec :: Spec spec = do - let currYear = CurrentYear 2020 - - - describe "updateCopyright" $ do - it "updates all authors when such mode selected" $ do - let - sample = fromLines - [ "Copyright (c) 2019 1st Author" - , "Copyright (c) 2017-2019 2nd Author" - ] - expected = fromLines - [ "Copyright (c) 2019-2020 1st Author" - , "Copyright (c) 2017-2020 2nd Author" - ] - testEnv = TestEnv currYear UpdateAllAuthors - postProcess updateCopyright testEnv sample `shouldBe` expected - - it "updates only selected authors in such mode" $ do - let sample = fromLines - [ "Copyright (c) 2019 1st Author" - , "Copyright (c) 2017-2019 2nd Author" - ] - expected = fromLines - [ "Copyright (c) 2019 1st Author" - , "Copyright (c) 2017-2020 2nd Author" - ] - mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] - testEnv = TestEnv currYear mode - postProcess updateCopyright testEnv sample `shouldBe` expected - - - describe "updateYears" $ do - it "does nothing on up-to-date year" $ do - let sample = "Copyright (c) 2020" - updateYears currYear sample `shouldBe` sample - - it "does nothing if year is higher than current year" $ do - let sample = "Copyright (c) 2021" - updateYears currYear sample `shouldBe` sample - - it "does nothing on up-to-date year range" $ do - let sample = "Copyright (c) 2018-2020" - updateYears currYear sample `shouldBe` sample - - it "does nothing if second year range is higher than current year" $ do - let sample = "Copyright (c) 2018-2021" - updateYears currYear sample `shouldBe` sample - - it "does nothing if entire year range is higher than current year" $ do - let sample = "Copyright (c) 2021-2023" - updateYears currYear sample `shouldBe` sample - - it "updates outdated year" $ do - let sample = "Copyright (c) 2019" - expected = "Copyright (c) 2019-2020" - updateYears currYear sample `shouldBe` expected - - it "updates outdated year range" $ do - let sample = "Copyright (c) 2017-2019" - expected = "Copyright (c) 2017-2020" - updateYears currYear sample `shouldBe` expected - - it "updates complex multi-line text" $ do - let sample = fromLines - [ "Copyright (c) 2019" - , "Copyright (c) 2020" - , "Copyright (c) 2019-2020" - , "Copyright (c) 2017-2019" - ] - expected = fromLines - [ "Copyright (c) 2019-2020" - , "Copyright (c) 2020" - , "Copyright (c) 2019-2020" - , "Copyright (c) 2017-2020" - ] - updateYears currYear sample `shouldBe` expected - + let currYear = CurrentYear 2020 + + describe "updateCopyright" $ do + it "updates all authors when such mode selected" $ do + let sample = + fromLines + [ "Copyright (c) 2019 1st Author" + , "Copyright (c) 2017-2019 2nd Author" + ] + expected = + fromLines + [ "Copyright (c) 2019-2020 1st Author" + , "Copyright (c) 2017-2020 2nd Author" + ] + testEnv = TestEnv currYear UpdateAllAuthors + postProcess updateCopyright testEnv sample `shouldBe` expected + + it "updates only selected authors in such mode" $ do + let sample = + fromLines + [ "Copyright (c) 2019 1st Author" + , "Copyright (c) 2017-2019 2nd Author" + ] + expected = + fromLines + [ "Copyright (c) 2019 1st Author" + , "Copyright (c) 2017-2020 2nd Author" + ] + mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] + testEnv = TestEnv currYear mode + postProcess updateCopyright testEnv sample `shouldBe` expected + + describe "updateYears" $ do + it "does nothing on up-to-date year" $ do + let sample = "Copyright (c) 2020" + updateYears currYear sample `shouldBe` sample + + it "does nothing if year is higher than current year" $ do + let sample = "Copyright (c) 2021" + updateYears currYear sample `shouldBe` sample + + it "does nothing on up-to-date year range" $ do + let sample = "Copyright (c) 2018-2020" + updateYears currYear sample `shouldBe` sample + + it "does nothing if second year range is higher than current year" $ do + let sample = "Copyright (c) 2018-2021" + updateYears currYear sample `shouldBe` sample + + it "does nothing if entire year range is higher than current year" $ do + let sample = "Copyright (c) 2021-2023" + updateYears currYear sample `shouldBe` sample + + it "updates outdated year" $ do + let sample = "Copyright (c) 2019" + expected = "Copyright (c) 2019-2020" + updateYears currYear sample `shouldBe` expected + + it "updates outdated year range" $ do + let sample = "Copyright (c) 2017-2019" + expected = "Copyright (c) 2017-2020" + updateYears currYear sample `shouldBe` expected + + it "updates complex multi-line text" $ do + let sample = + fromLines + [ "Copyright (c) 2019" + , "Copyright (c) 2020" + , "Copyright (c) 2019-2020" + , "Copyright (c) 2017-2019" + ] + expected = + fromLines + [ "Copyright (c) 2019-2020" + , "Copyright (c) 2020" + , "Copyright (c) 2019-2020" + , "Copyright (c) 2017-2020" + ] + updateYears currYear sample `shouldBe` expected ------------------------------- TEST DATA TYPES ------------------------------ - data TestEnv = TestEnv - { teCurrentYear :: CurrentYear - , teMode :: UpdateCopyrightMode - } - deriving (Eq, Show) + { teCurrentYear :: CurrentYear + , teMode :: UpdateCopyrightMode + } + deriving (Eq, Show) instance Has CurrentYear TestEnv where - hasLens = lens teCurrentYear (\x y -> x { teCurrentYear = y }) + hasLens = lens teCurrentYear (\x y -> x{teCurrentYear = y}) instance Has UpdateCopyrightMode TestEnv where - hasLens = lens teMode (\x y -> x { teMode = y }) - + hasLens = lens teMode (\x y -> x{teMode = y}) diff --git a/test/Headroom/PostProcessSpec.hs b/test/Headroom/PostProcessSpec.hs index 277e730..d2469f9 100644 --- a/test/Headroom/PostProcessSpec.hs +++ b/test/Headroom/PostProcessSpec.hs @@ -1,90 +1,94 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.PostProcessSpec - ( spec - ) -where - -import Headroom.Config.Types ( PostProcessConfig(..) - , PostProcessConfigs(..) - , UpdateCopyrightConfig(..) - ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Text ( fromLines ) -import Headroom.PostProcess -import Headroom.PostProcess.Types -import Headroom.PostProcess.UpdateCopyright -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Types ( CurrentYear(..) ) -import Headroom.Variables ( mkVariables ) -import RIO -import Test.Hspec +module Headroom.PostProcessSpec ( + spec +) where +import Headroom.Config.Types ( + PostProcessConfig (..) + , PostProcessConfigs (..) + , UpdateCopyrightConfig (..) + ) +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Text (fromLines) +import Headroom.PostProcess +import Headroom.PostProcess.Types +import Headroom.PostProcess.UpdateCopyright +import Headroom.Template.Mustache (Mustache) +import Headroom.Types (CurrentYear (..)) +import Headroom.Variables (mkVariables) +import RIO +import Test.Hspec spec :: Spec spec = do - let currentYear = CurrentYear 2020 - mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] - vars = mkVariables [("sndAuthor", "2nd Author")] - configs a = PostProcessConfigs - { ppcsUpdateCopyright = PostProcessConfig - { ppcEnabled = True - , ppcConfig = UpdateCopyrightConfig - { uccSelectedAuthors = Just - $ a - :| [] - } - } - } - configuredEnv a = ConfiguredEnv { ceCurrentYear = currentYear - , cePostProcessConfigs = configs a - , ceUpdateCopyrightMode = mode - } - - - describe "postProcess" $ do - it "executes the function for given environment" $ do - let testEnv = TestEnv "ENV" - input = "input" - expected = "input_ENV" - postProcess testFn testEnv input `shouldBe` expected - + let currentYear = CurrentYear 2020 + mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] + vars = mkVariables [("sndAuthor", "2nd Author")] + configs a = + PostProcessConfigs + { ppcsUpdateCopyright = + PostProcessConfig + { ppcEnabled = True + , ppcConfig = + UpdateCopyrightConfig + { uccSelectedAuthors = + Just $ + a + :| [] + } + } + } + configuredEnv a = + ConfiguredEnv + { ceCurrentYear = currentYear + , cePostProcessConfigs = configs a + , ceUpdateCopyrightMode = mode + } - describe "postProcessHeader" $ do - it "post-processes license header using given configuration" $ do - let header = fromLines - [ "License header" - , "Copyright (c) 2019 1st Author" - , "Copyright (c) 2018-2019 2nd Author" - ] - expected = fromLines - [ "License header" - , "Copyright (c) 2019 1st Author" - , "Copyright (c) 2018-2020 2nd Author" - ] - env = configuredEnv "2nd Author" - postProcessHeader env header `shouldBe` expected + describe "postProcess" $ do + it "executes the function for given environment" $ do + let testEnv = TestEnv "ENV" + input = "input" + expected = "input_ENV" + postProcess testFn testEnv input `shouldBe` expected + describe "postProcessHeader" $ do + it "post-processes license header using given configuration" $ do + let header = + fromLines + [ "License header" + , "Copyright (c) 2019 1st Author" + , "Copyright (c) 2018-2019 2nd Author" + ] + expected = + fromLines + [ "License header" + , "Copyright (c) 2019 1st Author" + , "Copyright (c) 2018-2020 2nd Author" + ] + env = configuredEnv "2nd Author" + postProcessHeader env header `shouldBe` expected - describe "mkConfiguredEnv" $ do - it "makes ConfiguredEnv from input parameters" $ do - let configsIn = configs "{{ sndAuthor }}" - out = configuredEnv "2nd Author" - mkConfiguredEnv @Mustache currentYear vars configsIn `shouldBe` Just out + describe "mkConfiguredEnv" $ do + it "makes ConfiguredEnv from input parameters" $ do + let configsIn = configs "{{ sndAuthor }}" + out = configuredEnv "2nd Author" + mkConfiguredEnv @Mustache currentYear vars configsIn `shouldBe` Just out ------------------------------- Test Data Types ------------------------------ newtype TestEnv = TestEnv Text instance Has TestEnv TestEnv where - hasLens = id + hasLens = id testFn :: (Has TestEnv env) => PostProcess env testFn = PostProcess $ \input -> do - TestEnv text <- viewL - pure $ input <> "_" <> text + TestEnv text <- viewL + pure $ input <> "_" <> text diff --git a/test/Headroom/SourceCodeSpec.hs b/test/Headroom/SourceCodeSpec.hs index fd648c8..fa8177b 100644 --- a/test/Headroom/SourceCodeSpec.hs +++ b/test/Headroom/SourceCodeSpec.hs @@ -1,106 +1,103 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.SourceCodeSpec - ( spec - ) -where - -import Headroom.SourceCode -import RIO -import qualified RIO.Text as T -import Test.Hspec +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 + 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 index caaa99e..544927b 100644 --- a/test/Headroom/Template/MustacheSpec.hs +++ b/test/Headroom/Template/MustacheSpec.hs @@ -1,65 +1,60 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.Template.MustacheSpec - ( spec - ) -where - -import Headroom.Template -import Headroom.Template.Mustache -import Headroom.Template.TemplateRef ( TemplateRef(..) ) -import Headroom.Variables ( mkVariables ) -import RIO -import Test.Hspec +module Headroom.Template.MustacheSpec ( + spec +) where +import Headroom.Template +import Headroom.Template.Mustache +import Headroom.Template.TemplateRef (TemplateRef (..)) +import Headroom.Variables (mkVariables) +import RIO +import Test.Hspec spec :: Spec spec = do - describe "parseTemplate" $ do - it "parses Mustache template from raw text" $ do - let template = "Hello, {{ name }}" - parsed = parseTemplate @Mustache (InlineRef template) template - parsed `shouldSatisfy` isJust - - - describe "renderTemplate" $ do - it "renders template with given variables" $ do - let template = "Hello, {{ name }}" - variables = mkVariables [("name", "John")] - parsed = parseTemplate @Mustache (InlineRef template) template - rendered = parsed >>= renderTemplate variables - rendered `shouldBe` Just "Hello, John" - - it "fails if not enough variables is provided" $ do - let template = "Hello, {{ name }} {{ surname }}" - variables = mkVariables [("name", "John")] - parsed = parseTemplate @Mustache (InlineRef template) template - let - err (MissingVariables "" ["surname"]) - = True - err _ = False - (parsed >>= renderTemplate variables) `shouldThrow` err - - it "renders template with conditionally set variable" $ do - let template = "Foo {{#bar}}{{bar}}{{/bar}}{{^bar}}BAR{{/bar}}" - variables = mempty - parsed = parseTemplate @Mustache (InlineRef template) template - rendered = parsed >>= renderTemplate variables - rendered `shouldBe` Just "Foo BAR" - - it "fails if non-existing variable is used with inverted sections" $ do - let template = "Foo {{bar}}{{^bar}}BAR{{/bar}}" - variables = mkVariables [("xx", "yy")] - parsed = parseTemplate @Mustache (InlineRef template) template - rendered = parsed >>= renderTemplate variables - rendered `shouldBe` Nothing - - - describe "rawTemplate" $ do - it "returns raw template text for already parsed template" $ do - let template = "Hello, {{ name }}" - parsed = parseTemplate @Mustache (InlineRef template) template - fmap rawTemplate parsed `shouldBe` Just template + describe "parseTemplate" $ do + it "parses Mustache template from raw text" $ do + let template = "Hello, {{ name }}" + parsed = parseTemplate @Mustache (InlineRef template) template + parsed `shouldSatisfy` isJust + + describe "renderTemplate" $ do + it "renders template with given variables" $ do + let template = "Hello, {{ name }}" + variables = mkVariables [("name", "John")] + parsed = parseTemplate @Mustache (InlineRef template) template + rendered = parsed >>= renderTemplate variables + rendered `shouldBe` Just "Hello, John" + + it "fails if not enough variables is provided" $ do + let template = "Hello, {{ name }} {{ surname }}" + variables = mkVariables [("name", "John")] + parsed = parseTemplate @Mustache (InlineRef template) template + let err (MissingVariables "" ["surname"]) = + True + err _ = False + (parsed >>= renderTemplate variables) `shouldThrow` err + + it "renders template with conditionally set variable" $ do + let template = "Foo {{#bar}}{{bar}}{{/bar}}{{^bar}}BAR{{/bar}}" + variables = mempty + parsed = parseTemplate @Mustache (InlineRef template) template + rendered = parsed >>= renderTemplate variables + rendered `shouldBe` Just "Foo BAR" + + it "fails if non-existing variable is used with inverted sections" $ do + let template = "Foo {{bar}}{{^bar}}BAR{{/bar}}" + variables = mkVariables [("xx", "yy")] + parsed = parseTemplate @Mustache (InlineRef template) template + rendered = parsed >>= renderTemplate variables + rendered `shouldBe` Nothing + + describe "rawTemplate" $ do + it "returns raw template text for already parsed template" $ do + let template = "Hello, {{ name }}" + parsed = parseTemplate @Mustache (InlineRef template) template + fmap rawTemplate parsed `shouldBe` Just template diff --git a/test/Headroom/Template/TemplateRefSpec.hs b/test/Headroom/Template/TemplateRefSpec.hs index 414c73f..3e52896 100644 --- a/test/Headroom/Template/TemplateRefSpec.hs +++ b/test/Headroom/Template/TemplateRefSpec.hs @@ -1,77 +1,70 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.Template.TemplateRefSpec - ( spec - ) -where - +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import qualified Data.Aeson as Aeson -import Headroom.Template.TemplateRef -import RIO -import qualified RIO.List as L -import Test.Hspec -import Text.URI.QQ ( uri ) +module Headroom.Template.TemplateRefSpec ( + spec +) where +import qualified Data.Aeson as Aeson +import Headroom.Template.TemplateRef +import RIO +import qualified RIO.List as L +import Test.Hspec +import Text.URI.QQ (uri) spec :: Spec spec = do - - describe "mkTemplateRef" $ do - it "creates valid reference to local Haskell template" $ do - let raw = "/path/to/some/haskell.mustache" - expected = LocalTemplateRef "/path/to/some/haskell.mustache" - mkTemplateRef raw `shouldBe` Just expected - - it "creates valid reference to HTTP Haskell template" $ do - let raw = "http://foo/haskell.mustache" - expected = UriTemplateRef [uri|http://foo/haskell.mustache|] - mkTemplateRef raw `shouldBe` Just expected - - it "throws error if URI is valid but protocol is not supported" $ do - let raw = "foo://foo/haskell.mustache" - mkTemplateRef raw `shouldThrow` \case - (UnsupportedUriProtocol _ _) -> True - _ -> False - - it "throws error if URI is valid but file type is not supported" $ do - let raw = "http://foo/bar.mustache" - mkTemplateRef raw `shouldThrow` \case - (UnrecognizedTemplateName _) -> True - _ -> False - - - describe "renderRef" $ do - it "renders local template reference to human friendly text" $ do - let sample = LocalTemplateRef "/path/to/some/haskell.mustache" - expected = "/path/to/some/haskell.mustache" - renderRef sample `shouldBe` expected - - it "renders URI template reference to human friendly text" $ do - let sample = UriTemplateRef [uri|http://foo/haskell.mustache|] - expected = "http://foo/haskell.mustache" - renderRef sample `shouldBe` expected - - - describe "FromJSON instance for TemplateRef" $ do - it "deserializes TemplateRef from JSON value" $ do - let sample = "\"http://foo/haskell.mustache\"" - expected = UriTemplateRef [uri|http://foo/haskell.mustache|] - Aeson.decode sample `shouldBe` Just expected - - - describe "Ord instance for TemplateRef" $ do - it "should properly order records" $ do - let sample = - [ UriTemplateRef [uri|http://foo/haskell.mustache|] - , LocalTemplateRef "/path/to/some/haskell.mustache" - ] - expected = - [ LocalTemplateRef "/path/to/some/haskell.mustache" - , UriTemplateRef [uri|http://foo/haskell.mustache|] - ] - L.sort sample `shouldBe` expected + describe "mkTemplateRef" $ do + it "creates valid reference to local Haskell template" $ do + let raw = "/path/to/some/haskell.mustache" + expected = LocalTemplateRef "/path/to/some/haskell.mustache" + mkTemplateRef raw `shouldBe` Just expected + + it "creates valid reference to HTTP Haskell template" $ do + let raw = "http://foo/haskell.mustache" + expected = UriTemplateRef [uri|http://foo/haskell.mustache|] + mkTemplateRef raw `shouldBe` Just expected + + it "throws error if URI is valid but protocol is not supported" $ do + let raw = "foo://foo/haskell.mustache" + mkTemplateRef raw `shouldThrow` \case + (UnsupportedUriProtocol _ _) -> True + _ -> False + + it "throws error if URI is valid but file type is not supported" $ do + let raw = "http://foo/bar.mustache" + mkTemplateRef raw `shouldThrow` \case + (UnrecognizedTemplateName _) -> True + _ -> False + + describe "renderRef" $ do + it "renders local template reference to human friendly text" $ do + let sample = LocalTemplateRef "/path/to/some/haskell.mustache" + expected = "/path/to/some/haskell.mustache" + renderRef sample `shouldBe` expected + + it "renders URI template reference to human friendly text" $ do + let sample = UriTemplateRef [uri|http://foo/haskell.mustache|] + expected = "http://foo/haskell.mustache" + renderRef sample `shouldBe` expected + + describe "FromJSON instance for TemplateRef" $ do + it "deserializes TemplateRef from JSON value" $ do + let sample = "\"http://foo/haskell.mustache\"" + expected = UriTemplateRef [uri|http://foo/haskell.mustache|] + Aeson.decode sample `shouldBe` Just expected + + describe "Ord instance for TemplateRef" $ do + it "should properly order records" $ do + let sample = + [ UriTemplateRef [uri|http://foo/haskell.mustache|] + , LocalTemplateRef "/path/to/some/haskell.mustache" + ] + expected = + [ LocalTemplateRef "/path/to/some/haskell.mustache" + , UriTemplateRef [uri|http://foo/haskell.mustache|] + ] + L.sort sample `shouldBe` expected diff --git a/test/Headroom/TypesSpec.hs b/test/Headroom/TypesSpec.hs index d44fdf1..a3c8a95 100644 --- a/test/Headroom/TypesSpec.hs +++ b/test/Headroom/TypesSpec.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Headroom.TypesSpec - ( spec - ) -where +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Variables ( mkVariables ) -import RIO -import Test.Hspec +module Headroom.TypesSpec ( + spec +) where +import Headroom.Variables (mkVariables) +import RIO +import Test.Hspec spec :: Spec spec = do - describe "Semigroup Variables" $ do - it "combines two instances of variables" $ do - let sample1 = mkVariables [("fst", "v1"), ("snd", "v1")] - sample2 = mkVariables [("snd", "v2"), ("trd", "v1")] - expected = mkVariables [("trd", "v1"), ("snd", "v2"), ("fst", "v1")] - (sample1 <> sample2) `shouldBe` expected + describe "Semigroup Variables" $ do + it "combines two instances of variables" $ do + let sample1 = mkVariables [("fst", "v1"), ("snd", "v1")] + sample2 = mkVariables [("snd", "v2"), ("trd", "v1")] + expected = mkVariables [("trd", "v1"), ("snd", "v2"), ("fst", "v1")] + (sample1 <> sample2) `shouldBe` expected diff --git a/test/Headroom/UI/MessageSpec.hs b/test/Headroom/UI/MessageSpec.hs index ab341c9..e93ba03 100644 --- a/test/Headroom/UI/MessageSpec.hs +++ b/test/Headroom/UI/MessageSpec.hs @@ -1,24 +1,22 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.UI.MessageSpec - ( spec - ) -where +module Headroom.UI.MessageSpec ( + spec +) where -import Headroom.UI.Message -import RIO -import Test.Hspec +import Headroom.UI.Message +import RIO +import Test.Hspec spec :: Spec spec = do + describe "Message" $ do + it "properly displays info message" $ do + textDisplay (messageInfo "info message") `shouldBe` "[i] info message" - describe "Message" $ do - it "properly displays info message" $ do - textDisplay (messageInfo "info message") `shouldBe` "[i] info message" - - it "properly displays warn message" $ do - textDisplay (messageWarn "warn message") `shouldBe` "[!] warn message" + it "properly displays warn message" $ do + textDisplay (messageWarn "warn message") `shouldBe` "[!] warn message" - it "properly displays error message" $ do - textDisplay (messageError "error message") `shouldBe` "[x] error message" + it "properly displays error message" $ do + textDisplay (messageError "error message") `shouldBe` "[x] error message" diff --git a/test/Headroom/UI/ProgressSpec.hs b/test/Headroom/UI/ProgressSpec.hs index 42075c4..c35e630 100644 --- a/test/Headroom/UI/ProgressSpec.hs +++ b/test/Headroom/UI/ProgressSpec.hs @@ -1,26 +1,23 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.UI.ProgressSpec - ( spec - ) -where +module Headroom.UI.ProgressSpec ( + spec +) where -import Headroom.UI.Progress -import RIO -import Test.Hspec +import Headroom.UI.Progress +import RIO +import Test.Hspec spec :: Spec spec = do + describe "zipWithProgress" $ do + it "zips progress for given collection" $ do + let col = ["a", "b"] :: [Text] + expected = [(Progress 1 2, "a"), (Progress 2 2, "b")] + zipWithProgress col `shouldBe` expected - describe "zipWithProgress" $ do - it "zips progress for given collection" $ do - let col = ["a", "b"] :: [Text] - expected = [(Progress 1 2, "a"), (Progress 2 2, "b")] - zipWithProgress col `shouldBe` expected - - - describe "Display instance" $ do - it "displays correct output for Progress data type" $ do - textDisplay (Progress 1 1) `shouldBe` "[1 of 1]" - textDisplay (Progress 10 250) `shouldBe` "[ 10 of 250]" + describe "Display instance" $ do + it "displays correct output for Progress data type" $ do + textDisplay (Progress 1 1) `shouldBe` "[1 of 1]" + textDisplay (Progress 10 250) `shouldBe` "[ 10 of 250]" diff --git a/test/Headroom/UI/TableSpec.hs b/test/Headroom/UI/TableSpec.hs index 6bf83f6..6ebe04f 100644 --- a/test/Headroom/UI/TableSpec.hs +++ b/test/Headroom/UI/TableSpec.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -module Headroom.UI.TableSpec - ( spec - ) -where - -import qualified Headroom.Data.Text as T -import Headroom.UI.Table -import RIO -import Test.Hspec +module Headroom.UI.TableSpec ( + spec +) where +import qualified Headroom.Data.Text as T +import Headroom.UI.Table +import RIO +import Test.Hspec spec :: Spec spec = do - describe "Display instance for Table2" $ do - it "prints columns correctly aligned" $ do - let sample = Table2 - [ ("hello" , "world") - , ("super super long first column", "foo") - , ("bar" , "baz") - ] - expected = T.fromLines - [ "hello world" - , "super super long first column foo" - , "bar baz" - ] - textDisplay sample `shouldBe` expected + describe "Display instance for Table2" $ do + it "prints columns correctly aligned" $ do + let sample = + Table2 + [ ("hello", "world") + , ("super super long first column", "foo") + , ("bar", "baz") + ] + expected = + T.fromLines + [ "hello world" + , "super super long first column foo" + , "bar baz" + ] + textDisplay sample `shouldBe` expected diff --git a/test/Headroom/UpdaterSpec.hs b/test/Headroom/UpdaterSpec.hs index 6620332..af50ac9 100644 --- a/test/Headroom/UpdaterSpec.hs +++ b/test/Headroom/UpdaterSpec.hs @@ -1,162 +1,161 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.UpdaterSpec - ( spec - ) -where - -import Data.Aeson ( Value ) -import qualified Data.Aeson as A -import Data.String.Interpolate ( i ) -import Data.Time ( UTCTime(..) ) -import Headroom.Config.Global ( UpdaterConfig(..) ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.IO.KVStore ( KVStore(..) - , inMemoryKVStore - , valueKey - ) -import Headroom.IO.Network ( Network(..) - , NetworkError(..) - ) -import Headroom.Meta ( buildVersion ) -import Headroom.Meta.Version ( printVersionP - , pvp - ) -import Headroom.Updater -import RIO -import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as BL -import RIO.FilePath ( () ) -import RIO.Partial ( fromJust ) -import RIO.Time ( addDays - , getCurrentTime - ) -import Test.Hspec - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Headroom.UpdaterSpec ( + spec +) where + +import Data.Aeson (Value) +import qualified Data.Aeson as A +import Data.String.Interpolate (i) +import Data.Time (UTCTime (..)) +import Headroom.Config.Global (UpdaterConfig (..)) +import Headroom.Data.Has (Has (..)) +import Headroom.Data.Lens ( + suffixLenses + , suffixLensesFor + ) +import Headroom.IO.KVStore ( + KVStore (..) + , inMemoryKVStore + , valueKey + ) +import Headroom.IO.Network ( + Network (..) + , NetworkError (..) + ) +import Headroom.Meta (buildVersion) +import Headroom.Meta.Version ( + printVersionP + , pvp + ) +import Headroom.Updater +import RIO +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import RIO.FilePath (()) +import RIO.Partial (fromJust) +import RIO.Time ( + addDays + , getCurrentTime + ) +import Test.Hspec data TestEnv = TestEnv - { envKVStore :: KVStore (RIO TestEnv) - , envNetwork :: Network (RIO TestEnv) - } + { envKVStore :: KVStore (RIO TestEnv) + , envNetwork :: Network (RIO TestEnv) + } suffixLenses ''TestEnv suffixLensesFor ["nDownloadContent"] ''Network instance Has (KVStore (RIO TestEnv)) TestEnv where - hasLens = envKVStoreL + hasLens = envKVStoreL instance Has (Network (RIO TestEnv)) TestEnv where - hasLens = envNetworkL - + hasLens = envNetworkL spec :: Spec spec = do - let testFile = "test-data" "updater" "github-resp.json" - storeKey = valueKey @UTCTime "updater/last-check-date" - - describe "checkUpdates" $ do - it "returns Nothing if current version is the latest" $ do - store@KVStore {..} <- runRIO env0 inMemoryKVStore - let json = [i|{"name": "#{printVersionP buildVersion}"}|] - env = - env0 - & (envKVStoreL .~ kvStore') - & (envNetworkL . nDownloadContentL .~ nDownloadContent') - nDownloadContent' = const . pure $ json - updaterConfig' = UpdaterConfig True 2 - kvStore' = store - actual <- runRIO env (checkUpdates updaterConfig') - maybeLastCheckDate <- runRIO env $ kvGetValue storeKey - actual `shouldBe` Nothing - maybeLastCheckDate `shouldSatisfy` isJust - - it "returns newer version if current version is outdated" $ do - store@KVStore {..} <- runRIO env0 inMemoryKVStore - let json = [i|{"name": "v999.0.0.0"}|] - env = - env0 - & (envKVStoreL .~ kvStore') - & (envNetworkL . nDownloadContentL .~ nDownloadContent') - nDownloadContent' = const . pure $ json - updaterConfig' = UpdaterConfig True 2 - kvStore' = store - actual <- runRIO env (checkUpdates updaterConfig') - maybeLastCheckDate <- runRIO env $ kvGetValue storeKey - actual `shouldBe` Just [pvp|999.0.0.0|] - maybeLastCheckDate `shouldSatisfy` isJust - - it "doesn't check for updates if still within check interval" $ do - store@KVStore {..} <- runRIO env0 inMemoryKVStore - oneDayAgo <- addDays' (-1) <$> getCurrentTime - let json = [i|{"name": "v999.0.0.0"}|] - env = - env0 - & (envKVStoreL .~ kvStore') - & (envNetworkL . nDownloadContentL .~ nDownloadContent') - nDownloadContent' = const . pure $ json - updaterConfig' = UpdaterConfig True 2 - kvStore' = store - actual <- runRIO env $ do - kvPutValue storeKey oneDayAgo - checkUpdates updaterConfig' - actual `shouldBe` Nothing - - it "returns Nothing if checking for updates is disabled" $ do - store@KVStore {..} <- runRIO env0 inMemoryKVStore - let json = [i|{"name": "v999.0.0.0"}|] - env = - env0 - & (envKVStoreL .~ kvStore') - & (envNetworkL . nDownloadContentL .~ nDownloadContent') - nDownloadContent' = const . pure $ json - updaterConfig' = UpdaterConfig False 2 - kvStore' = store - actual <- runRIO env (checkUpdates updaterConfig') - maybeLastCheckDate <- runRIO env $ kvGetValue storeKey - actual `shouldBe` Nothing - maybeLastCheckDate `shouldBe` Nothing - - - describe "fetchLatestVersion" $ do - it "gets latest version info" $ do - raw <- B.readFile testFile - let env = env0 & (envNetworkL . nDownloadContentL .~ nDownloadContent') - nDownloadContent' = const . pure $ raw - actual <- runRIO env fetchLatestVersion - actual `shouldBe` [pvp|0.4.2.0|] - - it "returns error if version cannot be fetched" $ do - let env = env0 & (envNetworkL . nDownloadContentL .~ nDownloadContent') - nDownloadContent' = \uri -> throwM $ ConnectionFailure uri "error" - runRIO env fetchLatestVersion `shouldThrow` \case - (CannotDetectVersion _) -> True - - - describe "parseLatestVersion" $ do - it "parses latest version from raw JSON input" $ do - raw <- BL.readFile testFile - actual <- parseLatestVersion (fromJust . A.decode @Value $ raw) - actual `shouldBe` [pvp|0.4.2.0|] - + let testFile = "test-data" "updater" "github-resp.json" + storeKey = valueKey @UTCTime "updater/last-check-date" + + describe "checkUpdates" $ do + it "returns Nothing if current version is the latest" $ do + store@KVStore{..} <- runRIO env0 inMemoryKVStore + let json = [i|{"name": "#{printVersionP buildVersion}"}|] + env = + env0 + & (envKVStoreL .~ kvStore') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + nDownloadContent' = const . pure $ json + updaterConfig' = UpdaterConfig True 2 + kvStore' = store + actual <- runRIO env (checkUpdates updaterConfig') + maybeLastCheckDate <- runRIO env $ kvGetValue storeKey + actual `shouldBe` Nothing + maybeLastCheckDate `shouldSatisfy` isJust + + it "returns newer version if current version is outdated" $ do + store@KVStore{..} <- runRIO env0 inMemoryKVStore + let json = [i|{"name": "v999.0.0.0"}|] + env = + env0 + & (envKVStoreL .~ kvStore') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + nDownloadContent' = const . pure $ json + updaterConfig' = UpdaterConfig True 2 + kvStore' = store + actual <- runRIO env (checkUpdates updaterConfig') + maybeLastCheckDate <- runRIO env $ kvGetValue storeKey + actual `shouldBe` Just [pvp|999.0.0.0|] + maybeLastCheckDate `shouldSatisfy` isJust + + it "doesn't check for updates if still within check interval" $ do + store@KVStore{..} <- runRIO env0 inMemoryKVStore + oneDayAgo <- addDays' (-1) <$> getCurrentTime + let json = [i|{"name": "v999.0.0.0"}|] + env = + env0 + & (envKVStoreL .~ kvStore') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + nDownloadContent' = const . pure $ json + updaterConfig' = UpdaterConfig True 2 + kvStore' = store + actual <- runRIO env $ do + kvPutValue storeKey oneDayAgo + checkUpdates updaterConfig' + actual `shouldBe` Nothing + + it "returns Nothing if checking for updates is disabled" $ do + store@KVStore{..} <- runRIO env0 inMemoryKVStore + let json = [i|{"name": "v999.0.0.0"}|] + env = + env0 + & (envKVStoreL .~ kvStore') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + nDownloadContent' = const . pure $ json + updaterConfig' = UpdaterConfig False 2 + kvStore' = store + actual <- runRIO env (checkUpdates updaterConfig') + maybeLastCheckDate <- runRIO env $ kvGetValue storeKey + actual `shouldBe` Nothing + maybeLastCheckDate `shouldBe` Nothing + + describe "fetchLatestVersion" $ do + it "gets latest version info" $ do + raw <- B.readFile testFile + let env = env0 & (envNetworkL . nDownloadContentL .~ nDownloadContent') + nDownloadContent' = const . pure $ raw + actual <- runRIO env fetchLatestVersion + actual `shouldBe` [pvp|0.4.2.0|] + + it "returns error if version cannot be fetched" $ do + let env = env0 & (envNetworkL . nDownloadContentL .~ nDownloadContent') + nDownloadContent' = \uri -> throwM $ ConnectionFailure uri "error" + runRIO env fetchLatestVersion `shouldThrow` \case + (CannotDetectVersion _) -> True + + describe "parseLatestVersion" $ do + it "parses latest version from raw JSON input" $ do + raw <- BL.readFile testFile + actual <- parseLatestVersion (fromJust . A.decode @Value $ raw) + actual `shouldBe` [pvp|0.4.2.0|] env0 :: TestEnv -env0 = TestEnv - { envKVStore = KVStore { kvGetValue = undefined, kvPutValue = undefined } - , envNetwork = Network { nDownloadContent = undefined } - } - +env0 = + TestEnv + { envKVStore = KVStore{kvGetValue = undefined, kvPutValue = undefined} + , envNetwork = Network{nDownloadContent = undefined} + } addDays' :: Integer -> UTCTime -> UTCTime addDays' noOfDays (UTCTime day timeOfDay) = - UTCTime (addDays noOfDays day) timeOfDay + UTCTime (addDays noOfDays day) timeOfDay diff --git a/test/Headroom/VariablesSpec.hs b/test/Headroom/VariablesSpec.hs index da18806..f9f199c 100644 --- a/test/Headroom/VariablesSpec.hs +++ b/test/Headroom/VariablesSpec.hs @@ -1,54 +1,50 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Headroom.VariablesSpec - ( spec - ) -where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -import Headroom.Template.Mustache ( Mustache ) -import Headroom.Types ( CurrentYear(..) ) -import Headroom.Variables -import Headroom.Variables.Types ( Variables(..) ) -import RIO -import qualified RIO.HashMap as HM -import Test.Hspec +module Headroom.VariablesSpec ( + spec +) where +import Headroom.Template.Mustache (Mustache) +import Headroom.Types (CurrentYear (..)) +import Headroom.Variables +import Headroom.Variables.Types (Variables (..)) +import RIO +import qualified RIO.HashMap as HM +import Test.Hspec spec :: Spec spec = do - - describe "mkVariables" $ do - it "constructs new Variables" $ do - let sample = [("key1", "value1")] - expected = Variables $ HM.fromList sample - mkVariables sample `shouldBe` expected - - - describe "parseVariables" $ do - it "parses variables from key=value textual representation" $ do - let sample = ["key1=value1", "key2=value2"] - expected = mkVariables [("key1", "value1"), ("key2", "value2")] - parseVariables sample `shouldBe` Just expected - - - describe "compileVariables" $ do - it "compiles template-like variable values" $ do - let sample1 = mkVariables - [("name", "John Smith"), ("greeting", "Hello, {{ name }}")] - expected = mkVariables - [("name", "John Smith"), ("greeting", "Hello, John Smith")] - compileVariables @Mustache sample1 `shouldReturn` expected - - it "doesn't get stuck in infinite loop on invalid recursive variable" $ do - let sample1 = mkVariables [("greeting", "Hello, {{ greeting }}")] - expected = mkVariables [("greeting", "Hello, Hello, {{ greeting }}")] - compileVariables @Mustache sample1 `shouldReturn` expected - - - describe "dynamicVariables" $ do - it "returns map of all expected dynamic variables" $ do - let year = CurrentYear 2020 - expected = mkVariables [("_current_year", "2020")] - dynamicVariables year `shouldBe` expected + describe "mkVariables" $ do + it "constructs new Variables" $ do + let sample = [("key1", "value1")] + expected = Variables $ HM.fromList sample + mkVariables sample `shouldBe` expected + + describe "parseVariables" $ do + it "parses variables from key=value textual representation" $ do + let sample = ["key1=value1", "key2=value2"] + expected = mkVariables [("key1", "value1"), ("key2", "value2")] + parseVariables sample `shouldBe` Just expected + + describe "compileVariables" $ do + it "compiles template-like variable values" $ do + let sample1 = + mkVariables + [("name", "John Smith"), ("greeting", "Hello, {{ name }}")] + expected = + mkVariables + [("name", "John Smith"), ("greeting", "Hello, John Smith")] + compileVariables @Mustache sample1 `shouldReturn` expected + + it "doesn't get stuck in infinite loop on invalid recursive variable" $ do + let sample1 = mkVariables [("greeting", "Hello, {{ greeting }}")] + expected = mkVariables [("greeting", "Hello, Hello, {{ greeting }}")] + compileVariables @Mustache sample1 `shouldReturn` expected + + describe "dynamicVariables" $ do + it "returns map of all expected dynamic variables" $ do + let year = CurrentYear 2020 + expected = mkVariables [("_current_year", "2020")] + dynamicVariables year `shouldBe` expected