diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ # Changelog All notable changes to this project will be documented in this file. +## 0.4.2.0 (released 2021-07-01) +- [#42] Add option to exclude source paths ignored by VCS +- [#66] Allow loading templates from HTTP(S) resource +- Bump _LTS Haskell_ to `18.0` + ## 0.4.1.0 (released 2021-03-14) - [#69] Improve console output - [#71] Add support for _Go_ language diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -51,5 +51,5 @@ cgoGenMode <- parseGenMode c commandGen CommandGenOptions { .. } Init cioLicenseType cioSourcePaths -> commandInit CommandInitOptions { .. } - Run croSourcePaths croExcludedPaths croTemplateSource croVariables croRunMode croDebug croDryRun + Run croSourcePaths croExcludedPaths croExcludeIgnoredPaths croBuiltInTemplates croTemplateRefs croVariables croRunMode croDebug croDryRun -> commandRun CommandRunOptions { .. } diff --git a/embedded/config-file.yaml b/embedded/config-file.yaml --- a/embedded/config-file.yaml +++ b/embedded/config-file.yaml @@ -29,6 +29,11 @@ ## for more than one path). excluded-paths: [] +## If set to 'true', Headroom tries to detect whether any VCS (like GIT) is used +## for current project and if yes, it loads rules for ignored files and excludes +## all source paths that matches these rules. +exclude-ignored-paths: false + ## Paths to template files (either files or directories), ## same as '-t|--template-path=PATH' command line argument (can be used multiple ## times for more than one path). diff --git a/embedded/default-config.yaml b/embedded/default-config.yaml --- a/embedded/default-config.yaml +++ b/embedded/default-config.yaml @@ -32,6 +32,11 @@ ## for more than one path). excluded-paths: [] +## If set to 'true', Headroom tries to detect whether any VCS (like GIT) is used +## for current project and if yes, it loads rules for ignored files and excludes +## all source paths that matches these rules. +exclude-ignored-paths: false + ## Paths to template files (either files or directories), ## same as '-t|--template-path=PATH' command line argument (can be used multiple ## times for more than one path). @@ -247,12 +252,12 @@ line-comment: prefixed-by: ^# -## Configuration for post-processing license header functions. These functions +## Configuration for post-processing functions. These functions ## allows to modify/enhance already rendered license headers, e.g. update years ## in copyright statements, etc. Each function can be enabled/disabled using the ## 'enabled' key and eventually customized using the 'config' key. post-process: - ## License header function that updates years in copyright statements in + ## Post-processing function that updates years in copyright statements in ## rendered license header. If you need to update copyright year only for ## selected author(s), define them in 'selected-authors-only' key, otherwise ## ommit/comment out this key completely and all copyright statements will be diff --git a/headroom.cabal b/headroom.cabal --- a/headroom.cabal +++ b/headroom.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: bc01e405c33597c1c0babea2ec25e31272b14935d2f13583270a27fd70c62400 +-- hash: 65abf7f836c076afc90aa5cf7190e8d0cabee4309c39c66ebd00b9da3a773b92 name: headroom -version: 0.4.1.0 +version: 0.4.2.0 synopsis: License Header Manager description: Would you like to have nice, up-to-date license/copyright headers in your source code files but hate to manage them by hand? Then Headroom is the right tool for you! Now you can define your license header as Mustache template, put all the variables (such as author's name, year, etc.) into the YAML config file and Headroom will take care to add such license headers to all your source code files. category: Utils @@ -150,6 +150,7 @@ Headroom.Data.Has Headroom.Data.Lens Headroom.Data.Regex + Headroom.Data.Serialization Headroom.Data.Text Headroom.Embedded Headroom.Embedded.TH @@ -169,24 +170,26 @@ Headroom.FileSupport.Shell Headroom.FileSupport.TemplateData Headroom.FileSupport.Types - Headroom.FileSystem Headroom.FileType Headroom.FileType.Types Headroom.Header Headroom.Header.Sanitize Headroom.Header.Types - Headroom.HeaderFn - Headroom.HeaderFn.Types - Headroom.HeaderFn.UpdateCopyright + Headroom.IO.FileSystem + Headroom.IO.Network Headroom.Meta Headroom.Meta.Version - Headroom.Serialization + Headroom.PostProcess + Headroom.PostProcess.Types + Headroom.PostProcess.UpdateCopyright Headroom.SourceCode Headroom.Template Headroom.Template.Mustache + Headroom.Template.TemplateRef Headroom.Types Headroom.UI Headroom.UI.Progress + Headroom.UI.Table Headroom.Variables Headroom.Variables.Types other-modules: @@ -200,19 +203,25 @@ aeson , base >=4.7 && <5 , either + , extra , file-embed , generic-data + , http-client + , http-types , microlens , microlens-th + , modern-uri , mtl , mustache , optparse-applicative , pcre-heavy , pcre-light + , req , rio , string-interpolate , template-haskell , time + , vcs-ignore , yaml default-language: Haskell2010 @@ -258,6 +267,7 @@ Headroom.Data.CoerceSpec Headroom.Data.EnumExtraSpec Headroom.Data.RegexSpec + Headroom.Data.SerializationSpec Headroom.Data.TextSpec Headroom.FileSupport.CPPSpec Headroom.FileSupport.CSpec @@ -273,19 +283,20 @@ Headroom.FileSupport.ScalaSpec Headroom.FileSupport.ShellSpec Headroom.FileSupportSpec - Headroom.FileSystemSpec Headroom.FileTypeSpec Headroom.Header.SanitizeSpec - Headroom.HeaderFn.TypesSpec - Headroom.HeaderFn.UpdateCopyrightSpec - Headroom.HeaderFnSpec Headroom.HeaderSpec + Headroom.IO.FileSystemSpec Headroom.Meta.VersionSpec - Headroom.SerializationSpec + Headroom.PostProcess.TypesSpec + Headroom.PostProcess.UpdateCopyrightSpec + Headroom.PostProcessSpec Headroom.SourceCodeSpec Headroom.Template.MustacheSpec + Headroom.Template.TemplateRefSpec Headroom.TypesSpec Headroom.UI.ProgressSpec + Headroom.UI.TableSpec Headroom.VariablesSpec Paths_headroom hs-source-dirs: @@ -299,6 +310,7 @@ , base >=4.7 && <5 , headroom , hspec + , modern-uri , mtl , optparse-applicative , pcre-light diff --git a/src/Headroom/Command.hs b/src/Headroom/Command.hs --- a/src/Headroom/Command.hs +++ b/src/Headroom/Command.hs @@ -23,11 +23,11 @@ import Headroom.Command.Readers ( licenseReader , licenseTypeReader , regexReader + , templateRefReader ) import Headroom.Command.Types ( Command(..) ) import Headroom.Configuration.Types ( LicenseType , RunMode(..) - , TemplateSource(..) ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) import Headroom.Meta ( buildVersion @@ -97,22 +97,23 @@ "path to exclude from source code file paths" ) ) + <*> switch + ( long "exclude-ignored-paths" + <> help "exclude paths ignored by used VCS" + ) <*> optional - ( BuiltInTemplates - <$> option - licenseTypeReader - (long "builtin-templates" <> metavar "TYPE" <> help - ("use built-in templates for license type, available options: " - <> T.unpack (T.toLower (allValuesToText @LicenseType)) - ) - ) - <|> TemplateFiles - <$> some - (strOption - (long "template-path" <> short 't' <> metavar "PATH" <> help - "path to license template file/directory" - ) - ) + (option + licenseTypeReader + (long "builtin-templates" <> metavar "licenseType" <> help + "use built-in templates of selected license type" + ) + ) + <*> many + (option + templateRefReader + (long "template-path" <> short 't' <> metavar "PATH" <> help + "path to template, can be either local file or directory or URL" + ) ) <*> many (strOption diff --git a/src/Headroom/Command/Init.hs b/src/Headroom/Command/Init.hs --- a/src/Headroom/Command/Init.hs +++ b/src/Headroom/Command/Init.hs @@ -54,13 +54,13 @@ , defaultConfig , licenseTemplate ) -import Headroom.FileSystem ( FileSystem(..) +import Headroom.FileType ( fileTypeByExt ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.IO.FileSystem ( FileSystem(..) , fileExtension , findFiles , mkFileSystem ) -import Headroom.FileType ( fileTypeByExt ) -import Headroom.FileType.Types ( FileType(..) ) import Headroom.Meta ( TemplateType , buildVersion , configFileName diff --git a/src/Headroom/Command/Readers.hs b/src/Headroom/Command/Readers.hs --- a/src/Headroom/Command/Readers.hs +++ b/src/Headroom/Command/Readers.hs @@ -19,6 +19,7 @@ ( licenseReader , licenseTypeReader , regexReader + , templateRefReader , parseLicense ) where @@ -30,6 +31,9 @@ , compile ) import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template.TemplateRef ( TemplateRef(..) + , mkTemplateRef + ) import Options.Applicative import RIO import qualified RIO.Text as T @@ -66,6 +70,13 @@ regexReader :: ReadM Regex regexReader = 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 diff --git a/src/Headroom/Command/Run.hs b/src/Headroom/Command/Run.hs --- a/src/Headroom/Command/Run.hs +++ b/src/Headroom/Command/Run.hs @@ -1,13 +1,19 @@ +{-# 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 @@ -24,14 +30,17 @@ module Headroom.Command.Run ( commandRun - , loadBuiltInTemplates - , loadTemplateFiles + , 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 ) @@ -39,6 +48,10 @@ , localDay , utcToLocalTime ) +import Data.VCS.Ignore ( Git + , Repo(..) + , findRepo + ) import Headroom.Command.Types ( CommandRunOptions(..) ) import Headroom.Command.Utils ( bootstrap ) import Headroom.Configuration ( loadConfiguration @@ -47,13 +60,11 @@ ) import Headroom.Configuration.Types ( Configuration(..) , CtConfiguration - , CtHeaderFnConfigs + , CtPostProcessConfigs , HeaderConfig(..) , HeaderSyntax(..) - , LicenseType(..) , PtConfiguration , RunMode(..) - , TemplateSource(..) ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) import Headroom.Data.Has ( Has(..) ) @@ -66,11 +77,6 @@ import Headroom.FileSupport ( analyzeSourceCode , fileSupport ) -import Headroom.FileSystem ( FileSystem(..) - , excludePaths - , fileExtension - , mkFileSystem - ) import Headroom.FileType ( fileTypeByExt ) import Headroom.FileType.Types ( FileType(..) ) import Headroom.Header ( addHeader @@ -83,21 +89,33 @@ import Headroom.Header.Types ( HeaderInfo(..) , HeaderTemplate(..) ) -import Headroom.HeaderFn ( mkConfiguredEnv - , postProcessHeader +import Headroom.IO.FileSystem ( FileSystem(..) + , excludePaths + , fileExtension + , mkFileSystem ) +import Headroom.IO.Network ( Network(..) + , mkNetwork + ) import Headroom.Meta ( TemplateType , configFileName , productInfo ) +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 @@ -105,46 +123,38 @@ 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 ["cHeaderFnConfigs"] ''Configuration +suffixLensesFor ["cPostProcessConfigs"] ''Configuration -- | 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 } -- | Initial /RIO/ startup environment for the /Run/ command. data StartupEnv = StartupEnv - { envLogFunc :: LogFunc - -- ^ logging function - , envRunOptions :: CommandRunOptions - -- ^ options + { envLogFunc :: LogFunc -- ^ logging function + , envRunOptions :: CommandRunOptions -- ^ options } suffixLenses ''StartupEnv -- | Full /RIO/ environment for the /Run/ command. data Env = Env - { envEnv :: StartupEnv - -- ^ startup /RIO/ environment - , envConfiguration :: CtConfiguration - -- ^ application configuration - , envCurrentYear :: CurrentYear - -- ^ current year - , envFileSystem :: FileSystem (RIO Env) - -- ^ file system operations + { envEnv :: StartupEnv -- ^ startup /RIO/ environment + , envConfiguration :: CtConfiguration -- ^ application configuration + , envCurrentYear :: CurrentYear -- ^ current year + , envNetwork :: Network (RIO Env) -- ^ network operations + , envFileSystem :: FileSystem (RIO Env) -- ^ file system operations } suffixLenses ''Env @@ -152,8 +162,8 @@ instance Has CtConfiguration Env where hasLens = envConfigurationL -instance Has CtHeaderFnConfigs Env where - hasLens = envConfigurationL . cHeaderFnConfigsL +instance Has CtPostProcessConfigs Env where + hasLens = envConfigurationL . cPostProcessConfigsL instance Has StartupEnv StartupEnv where hasLens = id @@ -176,6 +186,9 @@ instance Has CurrentYear Env where hasLens = envCurrentYearL +instance Has (Network (RIO Env)) Env where + hasLens = envNetworkL + instance Has (FileSystem (RIO Env)) Env where hasLens = envFileSystemL @@ -183,6 +196,7 @@ env' :: CommandRunOptions -> LogFunc -> IO Env env' opts logFunc = do let envEnv = StartupEnv { envLogFunc = logFunc, envRunOptions = opts } + envNetwork = mkNetwork envFileSystem = mkFileSystem envConfiguration <- runRIO envEnv finalConfiguration envCurrentYear <- currentYear @@ -190,10 +204,8 @@ -- | Handler for /Run/ command. -commandRun :: CommandRunOptions - -- ^ /Run/ command options - -> IO () - -- ^ execution result +commandRun :: CommandRunOptions -- ^ /Run/ command options + -> IO () -- ^ execution result commandRun opts = bootstrap (env' opts) (croDebug opts) $ do CommandRunOptions {..} <- viewL Configuration {..} <- viewL @CtConfiguration @@ -203,7 +215,7 @@ templates <- loadTemplates sourceFiles <- findSourceFiles (M.keys templates) _ <- logInfo "-----" - (total, processed) <- processSourceFiles templates sourceFiles + (total, processed) <- processSourceFiles @TemplateType templates sourceFiles endTS <- liftIO getPOSIXTime when (processed > 0) $ logStickyDone "-----" logStickyDone $ mconcat @@ -238,20 +250,44 @@ logDebug $ "Using source paths: " <> displayShow cSourcePaths files <- mconcat <$> mapM (fsFindFilesByTypes cLicenseHeaders fileTypes) cSourcePaths - let files' = excludePaths cExcludedPaths files - -- Found - logInfo $ mconcat - [ "Found " - , display $ length files' - , " files to process (excluded " - , display $ length files - length files' - , ")" - ] - pure files' + notIgnored <- excludePaths cExcludedPaths <$> excludeIgnored files + logInfo [iii| + Found #{length notIgnored} files to process + (excluded #{length files - length notIgnored}) + |] + pure notIgnored -processSourceFiles :: ( Has CtConfiguration env - , Has CtHeaderFnConfigs env +excludeIgnored :: ( Has CtConfiguration env + , Has (FileSystem (RIO env)) env + , HasLogFunc env + ) + => [FilePath] + -> RIO env [FilePath] +excludeIgnored paths = do + Configuration {..} <- viewL @CtConfiguration + FileSystem {..} <- viewL + currentDir <- fsGetCurrentDirectory + maybeRepo <- ifM (pure cExcludeIgnoredPaths) + (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 + 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 CtConfiguration env + , Has CtPostProcessConfigs env , Has CommandRunOptions env , Has CurrentYear env , HasLogFunc env @@ -264,18 +300,20 @@ year <- viewL let dVars = dynamicVariables year withTemplate = mapMaybe (template cLicenseHeaders) paths - cVars <- compileVariables (dVars <> cVariables) + cVars <- compileVariables @a (dVars <> cVariables) 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 cVars dVars pr ht p + process cVars dVars (pr, (ht, p)) = processSourceFile @a cVars dVars pr ht p -processSourceFile :: ( Has CommandRunOptions env +processSourceFile :: forall a env + . ( Template a + , Has CommandRunOptions env , Has CtConfiguration env - , Has CtHeaderFnConfigs env + , Has CtPostProcessConfigs env , Has CurrentYear env , HasLogFunc env ) @@ -295,7 +333,7 @@ variables = dVars <> cVars <> hiVariables syntax = hcHeaderSyntax hiHeaderConfig header' <- renderTemplate variables htTemplate - header <- postProcessHeader' syntax variables header' + header <- postProcessHeader' @a syntax variables header' RunAction {..} <- chooseAction headerInfo header let result = raFunc source changed = raProcessed && (source /= result) @@ -343,62 +381,68 @@ justify = T.justifyLeft 30 ' ' --- | Loads templates from the given paths. -loadTemplateFiles :: (Has (FileSystem (RIO env)) env, HasLogFunc env) - => [FilePath] - -- ^ paths to template files - -> RIO env (Map FileType TemplateType) - -- ^ map of file types and templates -loadTemplateFiles paths' = do - FileSystem {..} <- viewL - paths <- mconcat <$> mapM (`fsFindFilesByExts` extensions) paths' - logDebug $ "Using template paths: " <> displayShow paths - withTypes <- catMaybes <$> mapM (\p -> fmap (, p) <$> typeOfTemplate p) paths - parsed <- mapM - (\(t, p) -> - (t, ) <$> (fsLoadFile p >>= parseTemplate (Just $ T.pack p) . T.strip) - ) - withTypes - logInfo $ mconcat ["Found ", display $ length parsed, " license templates"] - pure $ M.fromList parsed - where extensions = toList $ templateExtensions @TemplateType - - --- | Loads built-in templates, stored in "Headroom.Embedded", for the given --- 'LicenseType'. -loadBuiltInTemplates :: (HasLogFunc env) - => LicenseType - -- ^ license type for which to selected templates - -> RIO env (Map FileType TemplateType) - -- ^ map of file types and templates -loadBuiltInTemplates licenseType = do - logInfo $ "Using built-in templates for license: " <> displayShow licenseType - parsed <- mapM (\(t, r) -> (t, ) <$> parseTemplate Nothing r) rawTemplates - pure $ M.fromList parsed +-- | 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 + , Has (Network (RIO env)) env + , Has (FileSystem (RIO env)) env + , HasLogFunc env + ) + => [TemplateRef] -- ^ template references + -> RIO env (Map FileType a) -- ^ map of templates +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 - rawTemplates = fmap (\ft -> (ft, template ft)) (allValues @FileType) - template = licenseTemplate licenseType + 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 -> 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 rs = + mapMaybe (L.headMaybe . L.sort) . L.groupBy (\x y -> fst x == fst y) $ rs loadTemplates :: ( Has CtConfiguration env , Has (FileSystem (RIO env)) env + , Has (Network (RIO env)) env , HasLogFunc env ) => RIO env (Map FileType HeaderTemplate) loadTemplates = do Configuration {..} <- viewL @CtConfiguration - templates <- case cTemplateSource of - TemplateFiles paths -> loadTemplateFiles paths - BuiltInTemplates licenseType -> loadBuiltInTemplates licenseType + let allRefs = builtInRefs cBuiltInTemplates <> cTemplateRefs + templates <- loadTemplateRefs @TemplateType allRefs + logInfo . display . stats . M.toList $ templates pure $ M.mapWithKey (extractHeaderTemplate cLicenseHeaders) 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 + => FilePath -- ^ path to the template file + -> RIO env (Maybe FileType) -- ^ detected template type typeOfTemplate path = do let fileType = textToEnum . T.pack . takeBaseName $ path when (isNothing fileType) @@ -448,14 +492,17 @@ optionsToConfiguration = do CommandRunOptions {..} <- viewL variables <- parseVariables croVariables - pure Configuration { cRunMode = maybe mempty pure croRunMode - , cSourcePaths = ifNot null croSourcePaths - , cExcludedPaths = ifNot null croExcludedPaths - , cTemplateSource = maybe mempty pure croTemplateSource - , cVariables = variables - , cLicenseHeaders = mempty - , cHeaderFnConfigs = mempty - } + pure Configuration + { cRunMode = maybe mempty pure croRunMode + , cSourcePaths = ifNot null croSourcePaths + , cExcludedPaths = ifNot null croExcludedPaths + , cExcludeIgnoredPaths = ifNot (== False) croExcludeIgnoredPaths + , cBuiltInTemplates = pure croBuiltInTemplates + , cTemplateRefs = croTemplateRefs + , cVariables = variables + , cLicenseHeaders = mempty + , cPostProcessConfigs = mempty + } where ifNot cond value = if cond value then mempty else pure value @@ -472,18 +519,18 @@ -- configuration. Currently the main points are to: -- -- 1. sanitize possibly corrupted comment syntax ('sanitizeSyntax') --- 2. apply /license header functions/ ('postProcessHeader') -postProcessHeader' :: (Has CtHeaderFnConfigs env, Has CurrentYear env) - => HeaderSyntax - -- ^ syntax of the license header comments - -> Variables - -- ^ template variables - -> Text - -- ^ rendered /license header/ to post-process - -> RIO env Text - -- ^ post-processed /license header/ +-- 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' syntax vars rawHeader = do - configs <- viewL @CtHeaderFnConfigs + configs <- viewL @CtPostProcessConfigs year <- viewL - cEnv <- mkConfiguredEnv year vars configs + 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 --- a/src/Headroom/Command/Types.hs +++ b/src/Headroom/Command/Types.hs @@ -24,55 +24,44 @@ import Headroom.Configuration.Types ( GenMode , LicenseType , RunMode - , TemplateSource ) import Headroom.Data.Regex ( Regex ) import Headroom.FileType.Types ( FileType ) +import Headroom.Template.TemplateRef ( TemplateRef ) import RIO -- | Application command. data Command - = Run [FilePath] [Regex] (Maybe TemplateSource) [Text] (Maybe RunMode) Bool Bool - -- ^ @run@ command - | Gen Bool (Maybe (LicenseType, FileType)) - -- ^ @gen@ command - | Init LicenseType [FilePath] - -- ^ @init@ command + = 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) -- | Options for the @gen@ command. newtype CommandGenOptions = CommandGenOptions - { cgoGenMode :: GenMode - -- ^ selected mode + { 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 + { cioSourcePaths :: [FilePath] -- ^ paths to source code files + , cioLicenseType :: LicenseType -- ^ license type } deriving Show -- | Options for the @run@ command. data CommandRunOptions = CommandRunOptions - { croRunMode :: Maybe RunMode - -- ^ used /Run/ command mode - , croSourcePaths :: [FilePath] - -- ^ source code file paths - , croExcludedPaths :: [Regex] - -- ^ source paths to exclude - , croTemplateSource :: Maybe TemplateSource - -- ^ source of license templates - , croVariables :: [Text] - -- ^ raw variables - , croDebug :: Bool - -- ^ whether to run in debug mode - , croDryRun :: Bool - -- ^ whether to perform dry run + { 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 --- a/src/Headroom/Command/Utils.hs +++ b/src/Headroom/Command/Utils.hs @@ -19,6 +19,7 @@ import RIO + -- | Bootstraps /RIO/ application using provided environment data and flag -- whether to run in debug mode. bootstrap :: (LogFunc -> IO env) @@ -29,10 +30,9 @@ -- ^ /RIO/ application to execute -> IO a -- ^ execution result -bootstrap getEnv isDebug logic = do - logOptions <- logOptionsHandle stderr isDebug - let logOptions' = setLogUseLoc False logOptions - withLogFunc logOptions' $ \logFunc -> do - env <- liftIO $ getEnv logFunc +bootstrap enfFn isDebug logic = do + defLogOptions <- logOptionsHandle stderr isDebug + withLogFunc (setLogUseLoc False defLogOptions) $ \logFunc -> do + env <- liftIO $ enfFn logFunc runRIO env logic diff --git a/src/Headroom/Configuration.hs b/src/Headroom/Configuration.hs --- a/src/Headroom/Configuration.hs +++ b/src/Headroom/Configuration.hs @@ -38,20 +38,20 @@ , ConfigurationKey(..) , CtConfiguration , CtHeaderConfig - , CtHeaderFnConfig - , CtHeaderFnConfigs , CtHeadersConfig + , CtPostProcessConfig + , CtPostProcessConfigs , CtUpdateCopyrightConfig , HeaderConfig(..) - , HeaderFnConfig(..) - , HeaderFnConfigs(..) , HeadersConfig(..) , Phase(..) + , PostProcessConfig(..) + , PostProcessConfigs(..) , PtConfiguration , PtHeaderConfig - , PtHeaderFnConfig - , PtHeaderFnConfigs , PtHeadersConfig + , PtPostProcessConfig + , PtPostProcessConfigs , PtUpdateCopyrightConfig , UpdateCopyrightConfig(..) ) @@ -64,8 +64,8 @@ import qualified RIO.ByteString as B -suffixLenses ''HeaderFnConfig -suffixLenses ''HeaderFnConfigs +suffixLenses ''PostProcessConfig +suffixLenses ''PostProcessConfigs suffixLenses ''UpdateCopyrightConfig @@ -95,13 +95,16 @@ -> m CtConfiguration -- ^ full 'CtConfiguration' makeConfiguration pt = do - cRunMode <- lastOrError CkRunMode (cRunMode pt) - cSourcePaths <- lastOrError CkSourcePaths (cSourcePaths pt) - cExcludedPaths <- lastOrError CkExcludedPaths (cExcludedPaths pt) - cTemplateSource <- lastOrError CkTemplateSource (cTemplateSource pt) - cLicenseHeaders <- makeHeadersConfig (cLicenseHeaders pt) - cHeaderFnConfigs <- makeHeaderFnConfigs (cHeaderFnConfigs pt) - cVariables <- pure $ cVariables pt + cRunMode <- lastOrError CkRunMode (cRunMode pt) + cSourcePaths <- lastOrError CkSourcePaths (cSourcePaths pt) + cExcludedPaths <- lastOrError CkExcludedPaths (cExcludedPaths pt) + cExcludeIgnoredPaths <- lastOrError CkExcludeIgnoredPaths + (cExcludeIgnoredPaths pt) + cBuiltInTemplates <- lastOrError CkBuiltInTemplates (cBuiltInTemplates pt) + cTemplateRefs <- pure $ cTemplateRefs pt + cLicenseHeaders <- makeHeadersConfig (cLicenseHeaders pt) + cPostProcessConfigs <- makePostProcessConfigs (cPostProcessConfigs pt) + cVariables <- pure $ cVariables pt pure Configuration { .. } @@ -152,21 +155,23 @@ ------------------------------ PRIVATE FUNCTIONS ----------------------------- -makeHeaderFnConfigs :: MonadThrow m => PtHeaderFnConfigs -> m CtHeaderFnConfigs -makeHeaderFnConfigs pt = do - hfcsUpdateCopyright <- makeHeaderFnConfig (pt ^. hfcsUpdateCopyrightL) - makeUpdateCopyrightConfig - pure HeaderFnConfigs { .. } +makePostProcessConfigs :: MonadThrow m + => PtPostProcessConfigs + -> m CtPostProcessConfigs +makePostProcessConfigs pt = do + ppcsUpdateCopyright <- makePostProcessConfig (pt ^. ppcsUpdateCopyrightL) + makeUpdateCopyrightConfig + pure PostProcessConfigs { .. } -makeHeaderFnConfig :: MonadThrow m - => PtHeaderFnConfig c - -> (c 'Partial -> m (c 'Complete)) - -> m (CtHeaderFnConfig c) -makeHeaderFnConfig pt fn = do - hfcEnabled <- lastOrError CkEnabled (pt ^. hfcEnabledL) - hfcConfig <- fn $ pt ^. hfcConfigL - pure HeaderFnConfig { .. } +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 diff --git a/src/Headroom/Configuration/Enrich.hs b/src/Headroom/Configuration/Enrich.hs --- a/src/Headroom/Configuration/Enrich.hs +++ b/src/Headroom/Configuration/Enrich.hs @@ -30,7 +30,7 @@ where import Data.Aeson ( ToJSON(..) ) -import Headroom.Serialization ( prettyPrintYAML ) +import Headroom.Data.Serialization ( prettyPrintYAML ) import RIO import qualified RIO.Map as M import qualified RIO.Text as T diff --git a/src/Headroom/Configuration/Types.hs b/src/Headroom/Configuration/Types.hs --- a/src/Headroom/Configuration/Types.hs +++ b/src/Headroom/Configuration/Types.hs @@ -56,18 +56,17 @@ , CtUpdateCopyrightConfig , PtUpdateCopyrightConfig , UpdateCopyrightConfig(..) - , CtHeaderFnConfig - , PtHeaderFnConfig - , HeaderFnConfig(..) - , CtHeaderFnConfigs - , PtHeaderFnConfigs - , HeaderFnConfigs(..) + , CtPostProcessConfig + , PtPostProcessConfig + , PostProcessConfig(..) + , CtPostProcessConfigs + , PtPostProcessConfigs + , PostProcessConfigs(..) -- ** Additional Data Types , HeaderSyntax(..) , GenMode(..) , LicenseType(..) , RunMode(..) - , TemplateSource(..) ) where @@ -84,12 +83,13 @@ , iii ) import Generic.Data ( Generically(..) ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) import Headroom.Data.Regex ( Regex(..) ) +import Headroom.Data.Serialization ( aesonOptions ) import Headroom.FileType.Types ( FileType ) import Headroom.Meta ( webDocConfigCurr ) -import Headroom.Serialization ( aesonOptions ) -import Headroom.Types ( fromHeadroomError +import Headroom.Template.TemplateRef ( TemplateRef ) +import Headroom.Types ( LicenseType(..) + , fromHeadroomError , toHeadroomError ) import Headroom.Variables.Types ( Variables(..) ) @@ -148,24 +148,6 @@ parseJSON = genericParseJSON aesonOptions ---------------------------------- LicenseType -------------------------------- - --- | Supported type of open source license. -data LicenseType - = Apache2 - -- ^ support for /Apache-2.0/ license - | BSD3 - -- ^ support for /BSD-3-Clause/ license - | GPL2 - -- ^ support for /GNU GPL2/ license - | GPL3 - -- ^ support for /GNU GPL3/ license - | MIT - -- ^ support for /MIT/ license - | MPL2 - -- ^ support for /MPL2/ license - deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - ----------------------------------- RunMode ---------------------------------- -- | Represents what action should the @run@ command perform. @@ -202,21 +184,10 @@ deriving (Eq, Show) -------------------------------- TemplateSource ------------------------------- - --- | Source of license templates -data TemplateSource - = TemplateFiles [FilePath] - -- ^ templates are stored as local files - | BuiltInTemplates LicenseType - -- ^ use built-in templates for selected license - deriving (Eq, Show) - - ---------------------------- UpdateCopyrightConfig --------------------------- --- | Main configuration for the "Headroom.HeaderFn.UpdateCopyright" --- /license header function/. +-- | 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 @@ -245,91 +216,92 @@ uccSelectedAuthors <- Last <$> obj .:? "selected-authors-only" pure UpdateCopyrightConfig { .. } -------------------------------- HeaderFnConfig ------------------------------- +------------------------------- PostProcessConfig ------------------------------- --- | Configuration for selected /license header function/. -data HeaderFnConfig (p :: Phase) c = HeaderFnConfig - { hfcEnabled :: p ::: Bool - -- ^ whether this function is enabled or not - , hfcConfig :: c p - -- ^ custom configuration of the /license header function/ +-- | 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/ } --- | Alias for complete variant of 'HeaderFnConfig'. -type CtHeaderFnConfig c = HeaderFnConfig 'Complete c +-- | Alias for complete variant of 'PostProcessConfig'. +type CtPostProcessConfig c = PostProcessConfig 'Complete c --- | Alias for partial variant of 'HeaderFnConfig'. -type PtHeaderFnConfig c = HeaderFnConfig 'Partial c +-- | Alias for partial variant of 'PostProcessConfig'. +type PtPostProcessConfig c = PostProcessConfig 'Partial c -deriving instance (Eq (c 'Complete)) => Eq (CtHeaderFnConfig c) -deriving instance (Eq (c 'Partial)) => Eq (PtHeaderFnConfig c) -deriving instance (Show (c 'Complete)) => Show (CtHeaderFnConfig c) -deriving instance (Show (c 'Partial)) => Show (PtHeaderFnConfig c) -deriving instance Generic (PtHeaderFnConfig 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 (PtHeaderFnConfig c)) - instance Semigroup (c 'Partial) => Semigroup (PtHeaderFnConfig c) -deriving via (Generically (PtHeaderFnConfig c)) - instance Monoid (c 'Partial) => Monoid (PtHeaderFnConfig 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 (PtHeaderFnConfig c) where - parseJSON = withObject "PtHeaderFnConfig" $ \obj -> do - hfcEnabled <- Last <$> obj .:? "enabled" - hfcConfig <- obj .:? "config" .!= mempty - pure HeaderFnConfig { .. } +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 { .. } -------------------------------- HeaderFnConfigs ------------------------------ +------------------------------- PostProcessConfigs ------------------------------ --- | Configuration of all known /license header functions/. -data HeaderFnConfigs (p :: Phase) = HeaderFnConfigs - { hfcsUpdateCopyright :: HeaderFnConfig p UpdateCopyrightConfig - -- ^ configuration for the "Headroom.HeaderFn.UpdateCopyright" - -- /license header function/ +-- | Configuration of all known /post-processors/. +data PostProcessConfigs (p :: Phase) = PostProcessConfigs + { ppcsUpdateCopyright :: PostProcessConfig p UpdateCopyrightConfig + -- ^ configuration for the "Headroom.PostProcess.UpdateCopyright" } --- | Alias for complete variant of 'HeaderFnConfigs'. -type CtHeaderFnConfigs = HeaderFnConfigs 'Complete +-- | Alias for complete variant of 'PostProcessConfigs'. +type CtPostProcessConfigs = PostProcessConfigs 'Complete --- | Alias for partial variant of 'HeaderFnConfigs'. -type PtHeaderFnConfigs = HeaderFnConfigs 'Partial +-- | Alias for partial variant of 'PostProcessConfigs'. +type PtPostProcessConfigs = PostProcessConfigs 'Partial -deriving instance Eq CtHeaderFnConfigs -deriving instance Eq PtHeaderFnConfigs -deriving instance Show CtHeaderFnConfigs -deriving instance Show PtHeaderFnConfigs -deriving instance Generic PtHeaderFnConfigs +deriving instance Eq CtPostProcessConfigs +deriving instance Eq PtPostProcessConfigs +deriving instance Show CtPostProcessConfigs +deriving instance Show PtPostProcessConfigs +deriving instance Generic PtPostProcessConfigs -deriving via (Generically PtHeaderFnConfigs) - instance Semigroup PtHeaderFnConfigs -deriving via (Generically PtHeaderFnConfigs) - instance Monoid PtHeaderFnConfigs +deriving via (Generically PtPostProcessConfigs) + instance Semigroup PtPostProcessConfigs +deriving via (Generically PtPostProcessConfigs) + instance Monoid PtPostProcessConfigs -instance FromJSON PtHeaderFnConfigs where - parseJSON = withObject "PtHeaderFnConfigs" $ \obj -> do - hfcsUpdateCopyright <- obj .:? "update-copyright" .!= mempty - pure HeaderFnConfigs { .. } +instance FromJSON PtPostProcessConfigs where + parseJSON = withObject "PtPostProcessConfigs" $ \obj -> do + ppcsUpdateCopyright <- obj .:? "update-copyright" .!= mempty + pure PostProcessConfigs { .. } -------------------------------- Configuration ------------------------------- -- | Application configuration. data Configuration (p :: Phase) = Configuration - { cRunMode :: p ::: RunMode + { cRunMode :: p ::: RunMode -- ^ mode of the @run@ command - , cSourcePaths :: p ::: [FilePath] + , cSourcePaths :: p ::: [FilePath] -- ^ paths to source code files - , cExcludedPaths :: p ::: [Regex] + , cExcludedPaths :: p ::: [Regex] -- ^ excluded source paths - , cTemplateSource :: p ::: TemplateSource - -- ^ source of license templates - , cVariables :: Variables + , cExcludeIgnoredPaths :: p ::: Bool + -- ^ whether to exclude paths ignored by VCS + , cBuiltInTemplates :: p ::: Maybe LicenseType + -- ^ used built-in templates + , cTemplateRefs :: [TemplateRef] + -- ^ template references + , cVariables :: Variables -- ^ variable values for templates - , cLicenseHeaders :: HeadersConfig p + , cLicenseHeaders :: HeadersConfig p -- ^ configuration of license headers - , cHeaderFnConfigs :: HeaderFnConfigs p - -- ^ configuration of license header functions + , cPostProcessConfigs :: PostProcessConfigs p + -- ^ configuration of post-processors } -- | Alias for complete variant of 'Configuration'. @@ -352,15 +324,16 @@ instance FromJSON PtConfiguration where parseJSON = withObject "PtConfiguration" $ \obj -> do - cRunMode <- Last <$> obj .:? "run-mode" - cSourcePaths <- Last <$> obj .:? "source-paths" - cExcludedPaths <- Last <$> obj .:? "excluded-paths" - cTemplateSource <- Last <$> get TemplateFiles (obj .:? "template-paths") - cVariables <- fmap Variables (obj .:? "variables" .!= mempty) - cLicenseHeaders <- obj .:? "license-headers" .!= mempty - cHeaderFnConfigs <- obj .:? "post-process" .!= mempty + cRunMode <- Last <$> obj .:? "run-mode" + cSourcePaths <- Last <$> obj .:? "source-paths" + cExcludedPaths <- Last <$> obj .:? "excluded-paths" + cExcludeIgnoredPaths <- Last <$> obj .:? "exclude-ignored-paths" + cBuiltInTemplates <- Last <$> obj .:? "builtin-templates" + cTemplateRefs <- obj .:? "template-paths" .!= mempty + cVariables <- Variables <$> obj .:? "variables" .!= mempty + cLicenseHeaders <- obj .:? "license-headers" .!= mempty + cPostProcessConfigs <- obj .:? "post-process" .!= mempty pure Configuration { .. } - where get = fmap . fmap -------------------------------- HeaderConfig -------------------------------- @@ -511,8 +484,10 @@ -- ^ no configuration for @source-paths@ | CkExcludedPaths -- ^ no configuration for @excluded-paths@ - | CkTemplateSource - -- ^ no configuration for template source + | CkExcludeIgnoredPaths + -- ^ no configuration for @exclude-ignored-paths@ + | CkBuiltInTemplates + -- ^ no configuration for built in templates | CkVariables -- ^ no configuration for @variables@ | CkEnabled @@ -577,9 +552,12 @@ CkExcludedPaths -> missingConfig "excluded paths" (Just "excluded-paths") (Just "-e|--excluded-path") - CkTemplateSource -> missingConfig - "template files source" - (Just "template-paths") + 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") diff --git a/src/Headroom/Data/EnumExtra.hs b/src/Headroom/Data/EnumExtra.hs --- a/src/Headroom/Data/EnumExtra.hs +++ b/src/Headroom/Data/EnumExtra.hs @@ -16,7 +16,10 @@ from/to textual representation, etc. -} -module Headroom.Data.EnumExtra where +module Headroom.Data.EnumExtra + ( EnumExtra(..) + ) +where import RIO import qualified RIO.List as L diff --git a/src/Headroom/Data/Serialization.hs b/src/Headroom/Data/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Data/Serialization.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.Data.Serialization +Description : Various functions for data (de)serialization +Copyright : (c) 2019-2021 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 +-- without the prefix and with words formated in /symbol case/ +-- (example: record field @uUserName@, /JSON/ field @user-name@). +aesonOptions :: Options +aesonOptions = + defaultOptions { fieldLabelModifier = symbolCase '-' . dropFieldPrefix } + + +-- | Drops prefix from camel-case text. +-- +-- >>> dropFieldPrefix "xxHelloWorld" +-- "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 + [] -> [] + + +-- | 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 sym = \case + [] -> [] + (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 = decodeUtf8Lenient . YP.encodePretty prettyConfig + where prettyConfig = YP.setConfCompare compare YP.defConfig diff --git a/src/Headroom/FileSystem.hs b/src/Headroom/FileSystem.hs deleted file mode 100644 --- a/src/Headroom/FileSystem.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -Module : Headroom.FileSystem -Description : Operations related to files and file system -Copyright : (c) 2019-2021 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.FileSystem - ( -- * Type Aliases - CreateDirectoryFn - , DoesFileExistFn - , FindFilesFn - , FindFilesByExtsFn - , FindFilesByTypesFn - , GetCurrentDirectoryFn - , ListFilesFn - , LoadFileFn - -- * Polymorphic Record - , FileSystem(..) - , mkFileSystem - -- * Traversing the File System - , findFiles - , findFilesByExts - , findFilesByTypes - , listFiles - , loadFile - -- * Working with Files Metadata - , fileExtension - -- * Other - , excludePaths - ) -where - -import Headroom.Configuration.Types ( CtHeadersConfig ) -import Headroom.Data.Regex ( Regex - , match - ) -import Headroom.FileType ( listExtensions ) -import Headroom.FileType.Types ( FileType ) -import RIO -import RIO.Directory ( createDirectory - , doesDirectoryExist - , doesFileExist - , getCurrentDirectory - , getDirectoryContents - ) -import RIO.FilePath ( isExtensionOf - , takeExtension - , () - ) -import qualified RIO.List as L -import qualified RIO.Text as T - - --------------------------------- 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 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 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 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 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 of a function that obtains the current working directory as an --- absolute path. -type GetCurrentDirectoryFn 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 of a function that loads file content in UTF8 encoding. -type LoadFileFn m - = FilePath - -- ^ file path - -> m Text - -- ^ file content - ------------------------------ POLYMORPHIC RECORD ----------------------------- - --- | /Polymorphic record/ composed of file system /IO/ function types, allowing --- to abstract over concrete implementation. Whenever you need to use effectful --- functions from this module, consider using this record instead of using them --- directly, as it allows you to use different records for production code and --- 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. - , 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 UTF8 encoding. - } - - --- | Creates new 'FileSystem' that performs actual disk /IO/ operations. -mkFileSystem :: MonadIO m => FileSystem m -mkFileSystem = FileSystem { fsCreateDirectory = createDirectory - , fsDoesFileExist = doesFileExist - , fsFindFiles = findFiles - , fsFindFilesByExts = findFilesByExts - , fsFindFilesByTypes = findFilesByTypes - , fsGetCurrentDirectory = getCurrentDirectory - , fsListFiles = listFiles - , fsLoadFile = loadFile - } - - ------------------------------- PUBLIC FUNCTIONS ------------------------------ - --- | Recursively finds files on given path whose filename matches the predicate. -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) - - --- | Recursively find files on given path by their file types. -findFilesByTypes :: MonadIO m => FindFilesByTypesFn m -findFilesByTypes headersConfig types path = - 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 - - --- | 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 (takeExtension -> '.' : xs) = Just $ T.pack xs -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. --- --- >>> :set -XQuasiQuotes --- >>> 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 paths = L.filter excluded paths - where excluded item = all (\p -> isNothing $ match p (T.pack item)) patterns diff --git a/src/Headroom/Header.hs b/src/Headroom/Header.hs --- a/src/Headroom/Header.hs +++ b/src/Headroom/Header.hs @@ -36,7 +36,6 @@ where import Headroom.Configuration.Types ( CtHeaderConfig - , CtHeaderConfig , CtHeadersConfig , HeaderConfig(..) , HeaderConfig(..) @@ -72,7 +71,6 @@ import RIO import qualified RIO.List as L import qualified RIO.Text as T - suffixLensesFor ["hcHeaderSyntax"] ''HeaderConfig diff --git a/src/Headroom/HeaderFn.hs b/src/Headroom/HeaderFn.hs deleted file mode 100644 --- a/src/Headroom/HeaderFn.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Headroom.HeaderFn -Description : Support for /license header functions/ -Copyright : (c) 2019-2021 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -/License header functions/ are basically functions that allows to post-process -already rendered /license headers/. This is useful to perform some additional -operations such as some sort of text alignment, update some parts of the header, -etc. --} - -module Headroom.HeaderFn - ( runHeaderFn - , configuredHeaderFn - , postProcessHeader - -- * Environment Data Types - , ConfiguredEnv(..) - , mkConfiguredEnv - ) -where - -import Headroom.Configuration.Types ( CtHeaderFnConfigs - , HeaderFnConfig(..) - , HeaderFnConfigs(..) - , UpdateCopyrightConfig(..) - ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.HeaderFn.Types ( HeaderFn(..) ) -import Headroom.HeaderFn.UpdateCopyright ( SelectedAuthors(..) - , UpdateCopyrightMode(..) - , updateCopyright - ) -import Headroom.Meta ( TemplateType ) -import Headroom.Template ( Template(..) ) -import Headroom.Types ( CurrentYear(..) ) -import Headroom.Variables.Types ( Variables(..) ) -import Lens.Micro ( traverseOf ) -import RIO - - -suffixLenses ''HeaderFnConfigs -suffixLenses ''UpdateCopyrightConfig -suffixLensesFor ["hfcConfig"] ''HeaderFnConfig - - --- | Runs the /license header function/ using the given /environment/ and text --- of rendered /license header/ as input. -runHeaderFn :: HeaderFn env - -- ^ /license header function/ to run - -> env - -- ^ environment value - -> Text - -- ^ text of rendered /license header/ - -> Text - -- ^ processed text of /license header/ -runHeaderFn (HeaderFn fn) env input = runReader (fn input) env - - --- | Composition of various /license header functions/, which environment is --- based on /YAML/ configuration and which can be enabled/disabled to fit --- end user's needs. -configuredHeaderFn :: (Has CurrentYear env, Has UpdateCopyrightMode env) - => CtHeaderFnConfigs - -- ^ configuration of /license header functions/ - -> HeaderFn env - -- ^ composed /license header function/ -configuredHeaderFn HeaderFnConfigs {..} = mconcat - [ifEnabled hfcsUpdateCopyright updateCopyright] - where - ifEnabled HeaderFnConfig {..} fn | hfcEnabled = fn - | otherwise = mempty - - --- | Takes already rendered /license header/ and post-process it based on the --- given configuration. -postProcessHeader :: ConfiguredEnv - -- ^ configuration used to define post-processing behaviour - -> Text - -- ^ rendered text of /license header/ - -> Text - -- ^ post-processed text of /license header/ -postProcessHeader env = runHeaderFn (configuredHeaderFn configs) env - where configs = ceHeaderFnConfigs env - - --- | Environemnt data type for the composed /license header function/ --- ('configuredHeaderFn'). -data ConfiguredEnv = ConfiguredEnv - { ceCurrentYear :: !CurrentYear - -- ^ current year - , ceHeaderFnConfigs :: !CtHeaderFnConfigs - -- ^ configuration of /license header functions/ - , ceUpdateCopyrightMode :: !UpdateCopyrightMode - -- ^ mode used by the 'updateCopyright' /license header function/ - } - deriving (Eq, Show) - -suffixLensesFor ["ceCurrentYear", "ceUpdateCopyrightMode"] ''ConfiguredEnv - -instance Has CurrentYear ConfiguredEnv where - hasLens = ceCurrentYearL - -instance Has UpdateCopyrightMode ConfiguredEnv where - hasLens = ceUpdateCopyrightModeL - - --- | Constructor function for 'ConfiguredEnv' data type. This function takes --- 'Variables' as argument, because it performs template compilation on --- selected fields of 'CtHeaderFnConfigs'. -mkConfiguredEnv :: (MonadThrow m) - => CurrentYear - -- ^ current year - -> Variables - -- ^ template variables - -> CtHeaderFnConfigs - -- ^ configuration of /license header functions/ - -> m ConfiguredEnv - -- ^ environment data type -mkConfiguredEnv ceCurrentYear vars configs = do - ceHeaderFnConfigs <- compileTemplates vars configs - let ceUpdateCopyrightMode = mode ceHeaderFnConfigs - pure ConfiguredEnv { .. } - where - authorsL = hfcsUpdateCopyrightL . hfcConfigL . uccSelectedAuthorsL - mode configs' = maybe UpdateAllAuthors - (UpdateSelectedAuthors . SelectedAuthors) - (configs' ^. authorsL) - - ------------------------------- PRIVATE FUNCTIONS ----------------------------- - -compileTemplates :: (MonadThrow m) - => Variables - -> CtHeaderFnConfigs - -> m CtHeaderFnConfigs -compileTemplates vars configs = configs & traverseOf authorsL compileAuthors' - where - authorsL = hfcsUpdateCopyrightL . hfcConfigL . uccSelectedAuthorsL - compileAuthors' = mapM . mapM $ compileAuthor - compileAuthor author = do - parsed <- parseTemplate @TemplateType (Just $ "author " <> author) author - renderTemplate vars parsed - - - - diff --git a/src/Headroom/HeaderFn/Types.hs b/src/Headroom/HeaderFn/Types.hs deleted file mode 100644 --- a/src/Headroom/HeaderFn/Types.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -{-| -Module : Headroom.HeaderFn.Types -Description : Data types for /license header functions/ -Copyright : (c) 2019-2021 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types and /type class/ instances for the -/license header functions/. --} - -module Headroom.HeaderFn.Types - ( HeaderFn(..) - ) -where - -import RIO - - --- | Definition of /license header function/, i.e. function, that is applied to --- already rendered /license header/, performs some logic and returns modified --- text of /license header/. Given that the /reader monad/ and 'ReaderT' --- transformer is used, any configuration is provided using the @env@ --- environment. When combined with the "Headroom.Data.Has" monad, it provides --- powerful way how to combine different /license header function/ and --- environments. --- --- = Structure of License Header Function Type --- --- @ --- __Text -> Reader env Text__ --- │ │ │ --- └─ rendered text of license header --- │ │ --- └─ environment holding possible configuration --- │ --- └─ modified license header text --- @ -newtype HeaderFn env = HeaderFn (Text -> Reader env Text) - -instance Semigroup (HeaderFn env) where - HeaderFn fnX <> HeaderFn fnY = HeaderFn $ fnX >=> fnY - -instance Monoid (HeaderFn env) where - mempty = HeaderFn $ \input -> pure input diff --git a/src/Headroom/HeaderFn/UpdateCopyright.hs b/src/Headroom/HeaderFn/UpdateCopyright.hs deleted file mode 100644 --- a/src/Headroom/HeaderFn/UpdateCopyright.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Headroom.HeaderFn.UpdateCopyright -Description : /License Header function/ for updating years in copyrights -Copyright : (c) 2019-2021 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides functionality for updating years in copyright statements -in already rendered /license headers/. --} - -module Headroom.HeaderFn.UpdateCopyright - ( -- * Data Types - SelectedAuthors(..) - , UpdateCopyrightMode(..) - -- * Header Functions - , updateCopyright - -- * Helper Functions - , updateYears - ) -where - -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Regex ( re - , replace - ) -import Headroom.Data.Text ( mapLines - , read - ) -import Headroom.HeaderFn.Types ( HeaderFn(..) ) -import Headroom.Types ( CurrentYear(..) ) -import RIO -import qualified RIO.NonEmpty as NE -import qualified RIO.Text as T - - ---------------------------------- DATA TYPES --------------------------------- - - --- | Non-empty list of authors for which to update years in their copyrights. -newtype SelectedAuthors = SelectedAuthors (NonEmpty Text) deriving (Eq, Show) - - --- | Mode that changes behaviour of the 'updateCopyright' function. -data UpdateCopyrightMode - = UpdateAllAuthors - -- ^ updates years in copyrights for all authors - | UpdateSelectedAuthors SelectedAuthors - -- ^ updates years in copyrights only for selected authors - deriving (Eq, Show) - - ------------------------------- PUBLIC FUNCTIONS ------------------------------ - - --- | /License header function/ that updates years and year ranges in any --- present copyright statements. --- --- = Reader Environment Parameters --- ['CurrentYear'] value of the current year --- ['UpdateCopyrightMode'] mode specifying the behaviour of the updater -updateCopyright :: (Has CurrentYear env, Has UpdateCopyrightMode env) - => HeaderFn env -updateCopyright = HeaderFn $ \input -> do - currentYear <- viewL - mode <- viewL - pure $ mapLines (update mode currentYear) input - where - update mode year line | shouldUpdate mode line = updateYears year line - | otherwise = line - shouldUpdate UpdateAllAuthors _ = True - shouldUpdate (UpdateSelectedAuthors (SelectedAuthors authors)) input = - any (`T.isInfixOf` input) (NE.toList authors) - - --- | Updates years and years ranges in given text. --- --- >>> updateYears (CurrentYear 2020) "Copyright (c) 2020" --- "Copyright (c) 2020" --- --- >>> updateYears (CurrentYear 2020) "Copyright (c) 2019" --- "Copyright (c) 2019-2020" --- --- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2020" --- "Copyright (c) 2018-2020" --- --- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2019" --- "Copyright (c) 2018-2020" -updateYears :: CurrentYear - -- ^ current year - -> Text - -- ^ text to update - -> Text - -- ^ text with updated years -updateYears (CurrentYear year) = processYear . processRange - where - processYear = replace [re|(?!\d{4}-)(?) + ) +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 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 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 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 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 of a function that obtains the current working directory as an +-- absolute path. +type GetCurrentDirectoryFn 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 of a function that loads file content in UTF8 encoding. +type LoadFileFn m + = FilePath + -- ^ file path + -> m Text + -- ^ file content + +----------------------------- POLYMORPHIC RECORD ----------------------------- + +-- | /Polymorphic record/ composed of file system /IO/ function types, allowing +-- to abstract over concrete implementation. Whenever you need to use effectful +-- functions from this module, consider using this record instead of using them +-- directly, as it allows you to use different records for production code and +-- 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. + , 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 UTF8 encoding. + } + + +-- | Creates new 'FileSystem' that performs actual disk /IO/ operations. +mkFileSystem :: MonadIO m => FileSystem m +mkFileSystem = FileSystem { fsCreateDirectory = createDirectory + , fsDoesFileExist = doesFileExist + , fsFindFiles = findFiles + , fsFindFilesByExts = findFilesByExts + , fsFindFilesByTypes = findFilesByTypes + , fsGetCurrentDirectory = getCurrentDirectory + , fsListFiles = listFiles + , fsLoadFile = loadFile + } + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Recursively finds files on given path whose filename matches the predicate. +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) + + +-- | Recursively find files on given path by their file types. +findFilesByTypes :: MonadIO m => FindFilesByTypesFn m +findFilesByTypes headersConfig types path = + 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 + + +-- | 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 (takeExtension -> '.' : xs) = Just $ T.pack xs +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. +-- +-- >>> :set -XQuasiQuotes +-- >>> 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 paths = L.filter excluded paths + where excluded item = all (\p -> isNothing $ match p (T.pack item)) patterns diff --git a/src/Headroom/IO/Network.hs b/src/Headroom/IO/Network.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/IO/Network.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Headroom.IO.Network +Description : Network related IO operations +Copyright : (c) 2019-2021 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 + ) +where + +import Data.String.Interpolate ( i ) +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 + , req + , responseBody + , runReq + , useURI + ) +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 Text -- ^ downloaded content + + +----------------------------- POLYMORPHIC RECORD ----------------------------- + +-- | Polymorphic record of functions performing network IO operations. +data Network m = Network + { nDownloadContent :: DownloadContentFn m -- ^ downloads remote content + } + + +-- | Constructs new 'Network' that performs real network /IO/ operations. +mkNetwork :: MonadIO m => Network m +mkNetwork = Network { nDownloadContent = downloadContent } + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Downloads content of remote resource as 'Text'. Note that only @http@ and +-- @https@ is supported at this moment. +downloadContent :: MonadIO m + => URI -- ^ /URI/ of remote resource + -> m Text -- ^ downloaded content +downloadContent uri = runReq defaultHttpConfig $ do + response <- httpGet uri + case T.decodeUtf8' $ responseBody response of + Left err -> throwM $ InvalidResponse uri (T.pack $ displayException err) + Right body -> pure body + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +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 mempty + + +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) + _ -> throwM ex + _ -> throwM ex + +--------------------------------- ERROR TYPES -------------------------------- + +-- | Error related to network operations. +data NetworkError + = ConnectionFailure URI Text -- ^ connection failure + | InvalidResponse URI Text -- ^ error during obtaining response + | InvalidStatus URI Int Text -- ^ invalid response status + | InvalidURL URI -- ^ given /URI/ is not valid + deriving (Eq, Show) + + +instance Exception NetworkError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + + +displayException' :: NetworkError -> String +displayException' = \case + ConnectionFailure uri ex -> [i|Error connecting to #{URI.render uri}: #{ex}|] + InvalidResponse uri reason -> + [i|Cannot decode response for '#{URI.render uri}': #{reason}|] + 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/PostProcess.hs b/src/Headroom/PostProcess.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/PostProcess.hs @@ -0,0 +1,170 @@ +{-# 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-2021 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.Configuration.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 + + +-- | 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 (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 + + +-- | Takes already rendered /license header/ and post-process it based on the +-- given configuration. +postProcessHeader :: ConfiguredEnv + -- ^ configuration used to define post-processing behaviour + -> Text + -- ^ rendered text of /license header/ + -> Text + -- ^ post-processed text of /license header/ +postProcessHeader env = + postProcess (configuredPostProcess (cePostProcessConfigs env)) env + + +-- | 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) + +suffixLensesFor ["ceCurrentYear", "ceUpdateCopyrightMode"] ''ConfiguredEnv + +instance Has CurrentYear ConfiguredEnv where + hasLens = ceCurrentYearL + +instance Has UpdateCopyrightMode ConfiguredEnv where + hasLens = ceUpdateCopyrightModeL + + +-- | Constructor function for 'ConfiguredEnv' data type. This function takes +-- 'Variables' as argument, because it performs template compilation on +-- selected fields of '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 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) + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +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 + + + + diff --git a/src/Headroom/PostProcess/Types.hs b/src/Headroom/PostProcess/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/PostProcess/Types.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.PostProcess.Types +Description : Data types for /post-processing/ +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types and /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 +-- text of /license header/. Given that the /reader monad/ and 'ReaderT' +-- transformer is used, any configuration is provided using the @env@ +-- environment. When combined with the "Headroom.Data.Has" monad, it provides +-- powerful way how to combine different /post-processors/ and +-- environments. +-- +-- = Structure of post-processor +-- +-- @ +-- __Text -> Reader env Text__ +-- │ │ │ +-- └─ rendered text of license header +-- │ │ +-- └─ environment holding possible configuration +-- │ +-- └─ modified license header text +-- @ +newtype PostProcess env = PostProcess (Text -> Reader env Text) + +instance Semigroup (PostProcess env) where + PostProcess fnX <> PostProcess fnY = PostProcess $ fnX >=> fnY + +instance Monoid (PostProcess env) where + mempty = PostProcess $ \input -> pure input diff --git a/src/Headroom/PostProcess/UpdateCopyright.hs b/src/Headroom/PostProcess/UpdateCopyright.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/PostProcess/UpdateCopyright.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module : Headroom.PostProcess.UpdateCopyright +Description : /Post-processor/ for updating years in copyrights +Copyright : (c) 2019-2021 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 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) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + + +-- | /Post-processor/ that updates years and year ranges in any +-- present copyright statements. +-- +-- = Reader Environment Parameters +-- ['CurrentYear'] value of the current year +-- ['UpdateCopyrightMode'] mode specifying the behaviour of the updater +updateCopyright :: (Has CurrentYear env, Has UpdateCopyrightMode env) + => 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) + + +-- | Updates years and years ranges in given text. +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2020" +-- "Copyright (c) 2020" +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2019" +-- "Copyright (c) 2019-2020" +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2020" +-- "Copyright (c) 2018-2020" +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2019" +-- "Copyright (c) 2018-2020" +updateYears :: CurrentYear -- ^ current year + -> Text -- ^ text to update + -> Text -- ^ text with updated years +updateYears (CurrentYear year) = processYear . processRange + where + processYear = replace [re|(?!\d{4}-)(?>> dropFieldPrefix "xxHelloWorld" --- "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 - [] -> [] - - --- | 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 sym = \case - [] -> [] - (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 = decodeUtf8Lenient . YP.encodePretty prettyConfig - where prettyConfig = YP.setConfCompare compare YP.defConfig diff --git a/src/Headroom/Template.hs b/src/Headroom/Template.hs --- a/src/Headroom/Template.hs +++ b/src/Headroom/Template.hs @@ -29,6 +29,7 @@ where import Data.String.Interpolate ( iii ) +import Headroom.Template.TemplateRef ( TemplateRef(..) ) import Headroom.Types ( fromHeadroomError , toHeadroomError ) @@ -47,8 +48,8 @@ -- | Parses template from given raw text. parseTemplate :: MonadThrow m - => Maybe Text - -- ^ name of the template (optional) + => TemplateRef + -- ^ reference to template source -> Text -- ^ raw template text -> m a @@ -73,21 +74,27 @@ -- ^ 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 + + ------------------------------ PUBLIC FUNCTIONS ------------------------------ -- | Returns empty template of selected type. emptyTemplate :: (MonadThrow m, Template a) => m a -emptyTemplate = parseTemplate Nothing T.empty +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 + = MissingVariables Text [Text] -- ^ missing variable values + | ParseError Text -- ^ error parsing raw template text deriving (Eq, Show, Typeable) diff --git a/src/Headroom/Template/Mustache.hs b/src/Headroom/Template/Mustache.hs --- a/src/Headroom/Template/Mustache.hs +++ b/src/Headroom/Template/Mustache.hs @@ -24,6 +24,9 @@ import Headroom.Template ( Template(..) , TemplateError(..) ) +import Headroom.Template.TemplateRef ( TemplateRef + , renderRef + ) import Headroom.Variables.Types ( Variables(..) ) import RIO import qualified RIO.Text as T @@ -35,6 +38,7 @@ data Mustache = Mustache { mCompiledTemplate :: MU.Template , mRawTemplate :: Text + , mTemplateRef :: TemplateRef } deriving Show @@ -48,17 +52,18 @@ parseTemplate = parseTemplate' renderTemplate = renderTemplate' rawTemplate = mRawTemplate + templateRef = mTemplateRef -parseTemplate' :: MonadThrow m => Maybe Text -> Text -> m Mustache -parseTemplate' name raw = case MU.compileTemplate templateName raw of - Left err -> throwM . ParseError $ tshow err - Right res -> pure $ Mustache res raw - where templateName = T.unpack . fromMaybe T.empty $ name +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 renderTemplate' :: MonadThrow m => Variables -> Mustache -> m Text -renderTemplate' (Variables variables) (Mustache t@(MU.Template name _ _) _) = +renderTemplate' (Variables variables) (Mustache t@(MU.Template name _ _) _ _) = case MU.checkedSubstitute t variables of ([], rendered) -> pure rendered (errs, rendered) -> diff --git a/src/Headroom/Template/TemplateRef.hs b/src/Headroom/Template/TemplateRef.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Template/TemplateRef.hs @@ -0,0 +1,139 @@ +{-# 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-2021 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) + + +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 + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Creates a 'TemplateRef' from given text. If the raw text appears to be +-- valid URL with either @http@ or @https@ as protocol, it considers it as +-- 'UriTemplateRef', otherwise it creates 'LocalTemplateRef'. +-- +-- >>> mkTemplateRef "/path/to/haskell.mustache" :: Maybe TemplateRef +-- Just (LocalTemplateRef "/path/to/haskell.mustache") +-- +-- >>> 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 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 + + +------------------------------ 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||] + + +--------------------------------- 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) + + +instance Exception TemplateRefError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + + +displayException' :: TemplateRefError -> String +displayException' = \case + 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| + 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 --- a/src/Headroom/Types.hs +++ b/src/Headroom/Types.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} {-| @@ -23,11 +24,17 @@ , 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. @@ -42,19 +49,15 @@ -- | Wraps given exception into 'HeadroomError'. toHeadroomError :: Exception e - => e - -- ^ exception to wrap - -> SomeException - -- ^ wrapped exception + => e -- ^ exception to wrap + -> SomeException -- ^ wrapped exception toHeadroomError = toException . HeadroomError -- | Unwraps given exception from 'HeadroomError'. fromHeadroomError :: Exception e - => SomeException - -- ^ exception to unwrap - -> Maybe e - -- ^ unwrapped exception + => SomeException -- ^ exception to unwrap + -> Maybe e -- ^ unwrapped exception fromHeadroomError e = do HeadroomError he <- fromException e cast he @@ -62,7 +65,24 @@ -- | Wraps the value of current year. newtype CurrentYear = CurrentYear - { unCurrentYear :: Integer - -- ^ value of current year + { 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) + +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 diff --git a/src/Headroom/UI/Table.hs b/src/Headroom/UI/Table.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/UI/Table.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.UI.Table +Description : UI components for rendering tables +Copyright : (c) 2019-2021 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 + + +-- | 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 diff --git a/src/Headroom/Variables.hs b/src/Headroom/Variables.hs --- a/src/Headroom/Variables.hs +++ b/src/Headroom/Variables.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Headroom.Variables @@ -29,8 +31,8 @@ where import Data.String.Interpolate ( iii ) -import Headroom.Meta ( TemplateType ) import Headroom.Template ( Template(..) ) +import Headroom.Template.TemplateRef ( TemplateRef(..) ) import Headroom.Types ( CurrentYear(..) , fromHeadroomError , toHeadroomError @@ -84,11 +86,14 @@ -- Note that recursive variable reference and/or cyclic references are not -- supported. -- --- >>> let compiled = compileVariables $ mkVariables [("name", "John"), ("msg", "Hello, {{ name }}")] +-- >>> :set -XTypeApplications +-- >>> import Headroom.Template.Mustache (Mustache) +-- >>> let compiled = compileVariables @Mustache $ mkVariables [("name", "John"), ("msg", "Hello, {{ name }}")] -- >>> let expected = mkVariables [("name", "John"), ("msg", "Hello, John")] -- >>> compiled == Just expected -- True -compileVariables :: (MonadThrow m) +compileVariables :: forall a m + . (Template a, MonadThrow m) => Variables -- ^ input variables to compile -> m Variables @@ -98,7 +103,7 @@ pure $ mkVariables compiled where compileVariable (key, value) = do - parsed <- parseTemplate @TemplateType (Just $ "variable " <> key) value + parsed <- parseTemplate @a (InlineRef value) value rendered <- renderTemplate variables parsed pure (key, rendered) diff --git a/test/Headroom/Command/InitSpec.hs b/test/Headroom/Command/InitSpec.hs --- a/test/Headroom/Command/InitSpec.hs +++ b/test/Headroom/Command/InitSpec.hs @@ -17,8 +17,8 @@ import Headroom.Data.Lens ( suffixLenses , suffixLensesFor ) -import Headroom.FileSystem ( FileSystem(..) ) import Headroom.FileType.Types ( FileType(..) ) +import Headroom.IO.FileSystem ( FileSystem(..) ) import RIO import RIO.FilePath ( () ) import qualified RIO.List as L diff --git a/test/Headroom/Command/RunSpec.hs b/test/Headroom/Command/RunSpec.hs --- a/test/Headroom/Command/RunSpec.hs +++ b/test/Headroom/Command/RunSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,6 +10,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Headroom.Command.RunSpec ( spec @@ -16,11 +18,10 @@ where import Headroom.Command.Run -import Headroom.Configuration.Types ( CtHeaderFnConfigs - , HeaderFnConfig(..) - , HeaderFnConfigs(..) +import Headroom.Configuration.Types ( CtPostProcessConfigs , HeaderSyntax(..) - , LicenseType(..) + , PostProcessConfig(..) + , PostProcessConfigs(..) , UpdateCopyrightConfig(..) ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) @@ -30,10 +31,13 @@ ) import Headroom.Data.Regex ( re ) import Headroom.Data.Text ( fromLines ) -import Headroom.FileSystem ( FileSystem(..) ) 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 ) @@ -44,23 +48,26 @@ 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) - , envHeaderFnConfigs :: CtHeaderFnConfigs + { 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 -instance Has CtHeaderFnConfigs TestEnv where - hasLens = envHeaderFnConfigsL +instance Has CtPostProcessConfigs TestEnv where + hasLens = envPostProcessConfigsL instance Has CurrentYear TestEnv where hasLens = envCurrentYearL @@ -68,27 +75,40 @@ instance Has (FileSystem (RIO TestEnv)) TestEnv where hasLens = envFileSystemL +instance Has (Network (RIO TestEnv)) TestEnv where + hasLens = envNetworkL + spec :: Spec spec = do - describe "loadBuiltInTemplates" $ do - it "should load correct number of built-in templates" $ do - M.size <$> runRIO env (loadBuiltInTemplates BSD3) `shouldReturn` 12 - - describe "loadTemplateFiles" $ do - it "should load templates from given paths" $ do + describe "loadTemplateRefs" $ do + it "should load templates from given references" $ do let env' = env & (envFileSystemL . fsFindFilesByExtsL .~ fsFindFilesByExts') & (envFileSystemL . fsLoadFileL .~ fsLoadFile') - fsFindFilesByExts' "test-dir" _ = pure ["haskell.mustache"] - fsFindFilesByExts' _ _ = throwString "INVALID CONDITION" - fsLoadFile' "haskell.mustache" = pure "template content" - fsLoadFile' _ = throwString "INVALID CONDITION" - templates <- runRIO env' $ loadTemplateFiles ["test-dir"] - M.size templates `shouldBe` 1 + & (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 @@ -115,7 +135,8 @@ ] vars = mkVariables [("sndAuthor", "2nd Author")] syntax = LineComment [re|^--|] (Just "--") - runRIO env (postProcessHeader' syntax vars sample) `shouldReturn` expected + runRIO env (postProcessHeader' @Mustache syntax vars sample) + `shouldReturn` expected env :: TestEnv @@ -132,10 +153,11 @@ , fsListFiles = undefined , fsLoadFile = undefined } - envHeaderFnConfigs = HeaderFnConfigs - { hfcsUpdateCopyright = HeaderFnConfig - { hfcEnabled = True - , hfcConfig = UpdateCopyrightConfig + envNetwork = Network { nDownloadContent = undefined } + envPostProcessConfigs = PostProcessConfigs + { ppcsUpdateCopyright = PostProcessConfig + { ppcEnabled = True + , ppcConfig = UpdateCopyrightConfig { uccSelectedAuthors = Just $ "{{ sndAuthor }}" :| [] } diff --git a/test/Headroom/Data/SerializationSpec.hs b/test/Headroom/Data/SerializationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Data/SerializationSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +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 diff --git a/test/Headroom/FileSupport/Haskell/HaddockSpec.hs b/test/Headroom/FileSupport/Haskell/HaddockSpec.hs --- a/test/Headroom/FileSupport/Haskell/HaddockSpec.hs +++ b/test/Headroom/FileSupport/Haskell/HaddockSpec.hs @@ -21,10 +21,11 @@ import Headroom.FileSupport.TemplateData ( HaddockOffsets(..) , TemplateData(..) ) -import Headroom.FileSystem ( loadFile ) 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 @@ -36,7 +37,9 @@ describe "extractOffsets" $ do it "extract offsets for selected fields of module header" $ do - template <- parseTemplate @Mustache Nothing $ licenseTemplate BSD3 Haskell + template <- + parseTemplate @Mustache (BuiltInRef BSD3 Haskell) + $ licenseTemplate BSD3 Haskell let syntax = BlockComment [re|^{-\||] [re|(?) ) @@ -63,7 +64,8 @@ describe "fsExtractTemplateData" $ do it "provides correct custom data for Haskell" $ do - template <- parseTemplate @Mustache Nothing (licenseTemplate BSD3 Haskell) + template <- parseTemplate @Mustache (BuiltInRef BSD3 Haskell) + (licenseTemplate BSD3 Haskell) let o = Just 14 td = HaskellTemplateData' HaddockOffsets { hoCopyright = o } expected = HaskellTemplateData td diff --git a/test/Headroom/FileSupport/JavaSpec.hs b/test/Headroom/FileSupport/JavaSpec.hs --- a/test/Headroom/FileSupport/JavaSpec.hs +++ b/test/Headroom/FileSupport/JavaSpec.hs @@ -20,9 +20,9 @@ import Headroom.FileSupport.Types ( FileSupport(..) , SyntaxAnalysis(..) ) -import Headroom.FileSystem ( loadFile ) 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 ) diff --git a/test/Headroom/FileSupport/PureScriptSpec.hs b/test/Headroom/FileSupport/PureScriptSpec.hs --- a/test/Headroom/FileSupport/PureScriptSpec.hs +++ b/test/Headroom/FileSupport/PureScriptSpec.hs @@ -20,9 +20,9 @@ import Headroom.FileSupport.Types ( FileSupport(..) , SyntaxAnalysis(..) ) -import Headroom.FileSystem ( loadFile ) 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 ) diff --git a/test/Headroom/FileSupportSpec.hs b/test/Headroom/FileSupportSpec.hs --- a/test/Headroom/FileSupportSpec.hs +++ b/test/Headroom/FileSupportSpec.hs @@ -7,8 +7,8 @@ where import Headroom.FileSupport -import Headroom.FileSystem ( loadFile ) import Headroom.FileType.Types ( FileType(..) ) +import Headroom.IO.FileSystem ( loadFile ) import Headroom.SourceCode ( LineType(..) , SourceCode(..) ) diff --git a/test/Headroom/FileSystemSpec.hs b/test/Headroom/FileSystemSpec.hs deleted file mode 100644 --- a/test/Headroom/FileSystemSpec.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Headroom.FileSystemSpec - ( spec - ) -where - -import Headroom.Data.Regex ( re ) -import Headroom.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 "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 - - - 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 diff --git a/test/Headroom/HeaderFn/TypesSpec.hs b/test/Headroom/HeaderFn/TypesSpec.hs deleted file mode 100644 --- a/test/Headroom/HeaderFn/TypesSpec.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -module Headroom.HeaderFn.TypesSpec - ( spec - ) -where - -import Headroom.Data.Has ( Has(..) ) -import Headroom.HeaderFn ( runHeaderFn ) -import Headroom.HeaderFn.Types -import RIO -import Test.Hspec - - -spec :: Spec -spec = do - - describe "Semigroup HeaderFn" $ do - it "combines two values together" $ do - let fooEnv = FooEnv "_FOO_ENV" - barEnv = BarEnv "_BAR_ENV" - combinedEnv = CombinedEnv fooEnv barEnv - input = "input" - combinedFn = fooFn <> barFn - expected = "input_FOO_ENV_BAR_ENV" - runHeaderFn combinedFn combinedEnv input `shouldBe` expected - - - describe "Monoid HeaderFn" $ do - it "does nothing with the input" $ do - let input = "input" - testEnv = undefined - testFn = mempty - runHeaderFn testFn testEnv input `shouldBe` input - - -------------------------------- Test Data Types ------------------------------ - - -data FooEnv = FooEnv - { feValue :: Text - } - -data BarEnv = BarEnv - { beValue :: Text - } - -data CombinedEnv = CombinedEnv - { ceFooEnv :: FooEnv - , ceBarEnv :: BarEnv - } - - -instance Has FooEnv FooEnv where - hasLens = id - -instance Has FooEnv CombinedEnv where - hasLens = lens ceFooEnv (\x y -> x { ceFooEnv = y }) - -instance Has BarEnv CombinedEnv where - hasLens = lens ceBarEnv (\x y -> x { ceBarEnv = y }) - - -fooFn :: (Has FooEnv env) => HeaderFn env -fooFn = HeaderFn $ \input -> do - FooEnv {..} <- viewL - pure $ input <> feValue - -barFn :: (Has BarEnv env) => HeaderFn env -barFn = HeaderFn $ \input -> do - BarEnv {..} <- viewL - pure $ input <> beValue diff --git a/test/Headroom/HeaderFn/UpdateCopyrightSpec.hs b/test/Headroom/HeaderFn/UpdateCopyrightSpec.hs deleted file mode 100644 --- a/test/Headroom/HeaderFn/UpdateCopyrightSpec.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -module Headroom.HeaderFn.UpdateCopyrightSpec - ( spec - ) -where - -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Text ( fromLines ) -import Headroom.HeaderFn ( runHeaderFn ) -import Headroom.HeaderFn.UpdateCopyright -import Headroom.Types ( CurrentYear(..) ) -import RIO -import Test.Hspec - - -spec :: Spec -spec = do - let currYear = CurrentYear 2020 - - - describe "updateCopyright" $ do - it "updates all authors when such mode selected" $ do - let - sample = fromLines - [ "Copyright (c) 2019 1st Author" - , "Copyright (c) 2017-2019 2nd Author" - ] - expected = fromLines - [ "Copyright (c) 2019-2020 1st Author" - , "Copyright (c) 2017-2020 2nd Author" - ] - testEnv = TestEnv currYear UpdateAllAuthors - runHeaderFn updateCopyright testEnv sample `shouldBe` expected - - it "updates only selected authors in such mode" $ do - let sample = fromLines - [ "Copyright (c) 2019 1st Author" - , "Copyright (c) 2017-2019 2nd Author" - ] - expected = fromLines - [ "Copyright (c) 2019 1st Author" - , "Copyright (c) 2017-2020 2nd Author" - ] - mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] - testEnv = TestEnv currYear mode - runHeaderFn updateCopyright testEnv sample `shouldBe` expected - - - describe "updateYears" $ do - it "does nothing on up-to-date year" $ do - let sample = "Copyright (c) 2020" - updateYears currYear sample `shouldBe` sample - - it "does nothing on up-to-date year range" $ do - let sample = "Copyright (c) 2018-2020" - updateYears currYear sample `shouldBe` sample - - it "updates outdated year" $ do - let sample = "Copyright (c) 2019" - expected = "Copyright (c) 2019-2020" - updateYears currYear sample `shouldBe` expected - - it "updates outdated year range" $ do - let sample = "Copyright (c) 2017-2019" - expected = "Copyright (c) 2017-2020" - updateYears currYear sample `shouldBe` expected - - it "updates complex multi-line text" $ do - let sample = fromLines - [ "Copyright (c) 2019" - , "Copyright (c) 2020" - , "Copyright (c) 2019-2020" - , "Copyright (c) 2017-2019" - ] - expected = fromLines - [ "Copyright (c) 2019-2020" - , "Copyright (c) 2020" - , "Copyright (c) 2019-2020" - , "Copyright (c) 2017-2020" - ] - updateYears currYear sample `shouldBe` expected - - -------------------------------- TEST DATA TYPES ------------------------------ - - -data TestEnv = TestEnv - { teCurrentYear :: CurrentYear - , teMode :: UpdateCopyrightMode - } - deriving (Eq, Show) - -instance Has CurrentYear TestEnv where - hasLens = lens teCurrentYear (\x y -> x { teCurrentYear = y }) - -instance Has UpdateCopyrightMode TestEnv where - hasLens = lens teMode (\x y -> x { teMode = y }) - diff --git a/test/Headroom/HeaderFnSpec.hs b/test/Headroom/HeaderFnSpec.hs deleted file mode 100644 --- a/test/Headroom/HeaderFnSpec.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -module Headroom.HeaderFnSpec - ( spec - ) -where - -import Headroom.Configuration.Types ( HeaderFnConfig(..) - , HeaderFnConfigs(..) - , UpdateCopyrightConfig(..) - ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Text ( fromLines ) -import Headroom.HeaderFn -import Headroom.HeaderFn.Types -import Headroom.HeaderFn.UpdateCopyright -import Headroom.Types ( CurrentYear(..) ) -import Headroom.Variables ( mkVariables ) -import RIO -import Test.Hspec - - -spec :: Spec -spec = do - let currentYear = CurrentYear 2020 - mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] - vars = mkVariables [("sndAuthor", "2nd Author")] - configs a = HeaderFnConfigs - { hfcsUpdateCopyright = HeaderFnConfig - { hfcEnabled = True - , hfcConfig = UpdateCopyrightConfig - { uccSelectedAuthors = Just - $ a - :| [] - } - } - } - configuredEnv a = ConfiguredEnv { ceCurrentYear = currentYear - , ceHeaderFnConfigs = configs a - , ceUpdateCopyrightMode = mode - } - - - describe "runHeaderFn" $ do - it "executes the function for given environment" $ do - let testEnv = TestEnv "ENV" - input = "input" - expected = "input_ENV" - runHeaderFn testFn testEnv input `shouldBe` expected - - - describe "postProcessHeader" $ do - it "post-processes given license header using given configuration" $ do - let header = fromLines - [ "License header" - , "Copyright (c) 2019 1st Author" - , "Copyright (c) 2018-2019 2nd Author" - ] - expected = fromLines - [ "License header" - , "Copyright (c) 2019 1st Author" - , "Copyright (c) 2018-2020 2nd Author" - ] - env = configuredEnv "2nd Author" - postProcessHeader env header `shouldBe` expected - - - describe "mkConfiguredEnv" $ do - it "makes ConfiguredEnv from input parameters" $ do - let configsIn = configs "{{ sndAuthor }}" - envOut = configuredEnv "2nd Author" - mkConfiguredEnv currentYear vars configsIn `shouldBe` Just envOut - -------------------------------- Test Data Types ------------------------------ - -newtype TestEnv = TestEnv Text - -instance Has TestEnv TestEnv where - hasLens = id - -testFn :: (Has TestEnv env) => HeaderFn env -testFn = HeaderFn $ \input -> do - TestEnv text <- viewL - pure $ input <> "_" <> text diff --git a/test/Headroom/HeaderSpec.hs b/test/Headroom/HeaderSpec.hs --- a/test/Headroom/HeaderSpec.hs +++ b/test/Headroom/HeaderSpec.hs @@ -23,10 +23,10 @@ import Headroom.FileSupport ( analyzeSourceCode , fileSupport ) -import Headroom.FileSystem ( loadFile ) import Headroom.FileType.Types ( FileType(..) ) import Headroom.Header import Headroom.Header.Types ( HeaderInfo(..) ) +import Headroom.IO.FileSystem ( loadFile ) import Headroom.SourceCode ( LineType(..) , SourceCode(..) ) diff --git a/test/Headroom/IO/FileSystemSpec.hs b/test/Headroom/IO/FileSystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/IO/FileSystemSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +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 "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 + + + 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 diff --git a/test/Headroom/PostProcess/TypesSpec.hs b/test/Headroom/PostProcess/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/PostProcess/TypesSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +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 + + +------------------------------- Test Data Types ------------------------------ + + +data FooEnv = FooEnv + { feValue :: Text + } + +data BarEnv = BarEnv + { beValue :: Text + } + +data CombinedEnv = CombinedEnv + { ceFooEnv :: FooEnv + , ceBarEnv :: BarEnv + } + + +instance Has FooEnv FooEnv where + hasLens = id + +instance Has FooEnv CombinedEnv where + hasLens = lens ceFooEnv (\x y -> x { ceFooEnv = y }) + +instance Has BarEnv CombinedEnv where + hasLens = lens ceBarEnv (\x y -> x { ceBarEnv = y }) + + +fooFn :: (Has FooEnv env) => PostProcess env +fooFn = PostProcess $ \input -> do + FooEnv {..} <- viewL + pure $ input <> feValue + +barFn :: (Has BarEnv env) => PostProcess env +barFn = PostProcess $ \input -> do + BarEnv {..} <- viewL + pure $ input <> beValue diff --git a/test/Headroom/PostProcess/UpdateCopyrightSpec.hs b/test/Headroom/PostProcess/UpdateCopyrightSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/PostProcess/UpdateCopyrightSpec.hs @@ -0,0 +1,103 @@ +{-# 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 + + +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 on up-to-date year range" $ do + let sample = "Copyright (c) 2018-2020" + updateYears currYear sample `shouldBe` sample + + it "updates outdated year" $ do + let sample = "Copyright (c) 2019" + expected = "Copyright (c) 2019-2020" + updateYears currYear sample `shouldBe` expected + + it "updates outdated year range" $ do + let sample = "Copyright (c) 2017-2019" + expected = "Copyright (c) 2017-2020" + updateYears currYear sample `shouldBe` expected + + it "updates complex multi-line text" $ do + let sample = fromLines + [ "Copyright (c) 2019" + , "Copyright (c) 2020" + , "Copyright (c) 2019-2020" + , "Copyright (c) 2017-2019" + ] + expected = fromLines + [ "Copyright (c) 2019-2020" + , "Copyright (c) 2020" + , "Copyright (c) 2019-2020" + , "Copyright (c) 2017-2020" + ] + updateYears currYear sample `shouldBe` expected + + +------------------------------- TEST DATA TYPES ------------------------------ + + +data TestEnv = TestEnv + { teCurrentYear :: CurrentYear + , teMode :: UpdateCopyrightMode + } + deriving (Eq, Show) + +instance Has CurrentYear TestEnv where + hasLens = lens teCurrentYear (\x y -> x { teCurrentYear = y }) + +instance Has UpdateCopyrightMode TestEnv where + hasLens = lens teMode (\x y -> x { teMode = y }) + diff --git a/test/Headroom/PostProcessSpec.hs b/test/Headroom/PostProcessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/PostProcessSpec.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Headroom.PostProcessSpec + ( spec + ) +where + +import Headroom.Configuration.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 + + + 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 + +------------------------------- Test Data Types ------------------------------ + +newtype TestEnv = TestEnv Text + +instance Has TestEnv TestEnv where + hasLens = id + +testFn :: (Has TestEnv env) => PostProcess env +testFn = PostProcess $ \input -> do + TestEnv text <- viewL + pure $ input <> "_" <> text diff --git a/test/Headroom/SerializationSpec.hs b/test/Headroom/SerializationSpec.hs deleted file mode 100644 --- a/test/Headroom/SerializationSpec.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Headroom.SerializationSpec - ( spec - ) -where - -import Headroom.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 diff --git a/test/Headroom/Template/MustacheSpec.hs b/test/Headroom/Template/MustacheSpec.hs --- a/test/Headroom/Template/MustacheSpec.hs +++ b/test/Headroom/Template/MustacheSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + module Headroom.Template.MustacheSpec ( spec ) @@ -9,6 +10,7 @@ import Headroom.Template import Headroom.Template.Mustache +import Headroom.Template.TemplateRef ( TemplateRef(..) ) import Headroom.Variables ( mkVariables ) import RIO import Test.Hspec @@ -19,7 +21,7 @@ describe "parseTemplate" $ do it "parses Mustache template from raw text" $ do let template = "Hello, {{ name }}" - parsed = parseTemplate @Mustache (Just "template") template + parsed = parseTemplate @Mustache (InlineRef template) template parsed `shouldSatisfy` isJust @@ -27,29 +29,31 @@ it "renders template with given variables" $ do let template = "Hello, {{ name }}" variables = mkVariables [("name", "John")] - parsed = parseTemplate @Mustache (Just "template") template + 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 (Just "test") template - let err (MissingVariables "test" ["surname"]) = True - err _ = False + 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 (Just "template") template + 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 (Just "template") template + parsed = parseTemplate @Mustache (InlineRef template) template rendered = parsed >>= renderTemplate variables rendered `shouldBe` Nothing @@ -57,5 +61,5 @@ describe "rawTemplate" $ do it "returns raw template text for already parsed template" $ do let template = "Hello, {{ name }}" - parsed = parseTemplate @Mustache (Just "template") template + 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 new file mode 100644 --- /dev/null +++ b/test/Headroom/Template/TemplateRefSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +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 diff --git a/test/Headroom/UI/ProgressSpec.hs b/test/Headroom/UI/ProgressSpec.hs --- a/test/Headroom/UI/ProgressSpec.hs +++ b/test/Headroom/UI/ProgressSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} + module Headroom.UI.ProgressSpec ( spec ) @@ -11,13 +12,15 @@ 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 "show" $ do + + 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 new file mode 100644 --- /dev/null +++ b/test/Headroom/UI/TableSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +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 diff --git a/test/Headroom/VariablesSpec.hs b/test/Headroom/VariablesSpec.hs --- a/test/Headroom/VariablesSpec.hs +++ b/test/Headroom/VariablesSpec.hs @@ -1,10 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + module Headroom.VariablesSpec ( spec ) where +import Headroom.Template.Mustache ( Mustache ) import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables import Headroom.Variables.Types ( Variables(..) ) @@ -36,12 +39,12 @@ [("name", "John Smith"), ("greeting", "Hello, {{ name }}")] expected = mkVariables [("name", "John Smith"), ("greeting", "Hello, John Smith")] - compileVariables sample1 `shouldReturn` expected + 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 sample1 `shouldReturn` expected + compileVariables @Mustache sample1 `shouldReturn` expected describe "dynamicVariables" $ do