{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-| Module : Headroom.Configuration.Types Description : Data types for /Headroom/ configuration Copyright : (c) 2019-2020 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental Portability : POSIX This module contains data types representing /Headroom/ configuration options. Related logic is available in "Headroom.Configuration" module. Data types related to /Headroom/ configuration uses the pattern, but instead of defining separate data type for each /phase/ (/partial/ or /complete/ configuration), the /phase/ is expressed by the 'Phase' data type and related /closed type family/. -} module Headroom.Configuration.Types ( -- * Error Types ConfigurationError(..) , ConfigurationKey(..) -- * Type Families , Phase(..) , (:::) -- * Data Types -- ** Top Level Configuration , Configuration(..) , CtConfiguration , PtConfiguration , HeadersConfig(..) , CtHeadersConfig , PtHeadersConfig , HeaderConfig(..) , CtHeaderConfig , PtHeaderConfig -- ** Header Functions , CtUpdateCopyrightConfig , PtUpdateCopyrightConfig , UpdateCopyrightConfig(..) , CtHeaderFnConfig , PtHeaderFnConfig , HeaderFnConfig(..) , CtHeaderFnConfigs , PtHeaderFnConfigs , HeaderFnConfigs(..) -- ** Additional Data Types , HeaderSyntax(..) , GenMode(..) , LicenseType(..) , RunMode(..) , TemplateSource(..) ) where import Control.Exception ( throw ) import Data.Aeson ( FromJSON(..) , Value(String) , genericParseJSON , withObject , (.!=) , (.:?) ) import Data.Monoid ( Last(..) ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) import Headroom.Data.Regex ( Regex(..) ) import Headroom.FileType.Types ( FileType ) import Headroom.Serialization ( aesonOptions ) import Headroom.Types ( fromHeadroomError , toHeadroomError ) import Headroom.Variables.Types ( Variables(..) ) import RIO import qualified RIO.Text as T ------------------------------------ Phase ----------------------------------- -- | Data type representing state of given configuration data type. data Phase = Partial -- ^ partial configuration, could be combined with another or validated to -- produce the complete configuration | Complete -- ^ complete configuration, result of combining and validation of partial -- configuration -- | /Closed type family/ used to express the phase of given data type. type family (p :: Phase) ::: a where 'Partial ::: a = Last a 'Complete ::: a = a -------------------------------- HeaderSyntax -------------------------------- -- | Syntax of the license header comment. data HeaderSyntax = BlockComment Text Text -- ^ block (multi-line) comment syntax (e.g. @/* */@) | LineComment Text -- ^ single line comment syntax (e.g. @//@) deriving (Eq, Show) -- | Internal representation of the block style of 'HeaderSyntax'. data BlockComment' = BlockComment' { bcStartsWith :: Text -- ^ starting pattern (e.g. @/*@) , bcEndsWith :: Text -- ^ ending pattern (e.g. @*/@) } deriving (Eq, Generic, Show) instance FromJSON BlockComment' where parseJSON = genericParseJSON aesonOptions -- | Internal representation of the line style of 'HeaderSyntax'. newtype LineComment' = LineComment' { lcPrefixedBy :: Text -- ^ prefix of the comment line (e.g. @//@) } deriving (Eq, Generic, Show) instance FromJSON LineComment' where parseJSON = genericParseJSON aesonOptions --------------------------------- LicenseType -------------------------------- -- | Supported type of open source license. data LicenseType = Apache2 -- ^ support for /Apache-2.0/ license | BSD3 -- ^ support for /BSD-3-Clause/ license | GPL2 -- ^ support for /GNU GPL2/ license | GPL3 -- ^ support for /GNU GPL3/ license | MIT -- ^ support for /MIT/ license | MPL2 -- ^ support for /MPL2/ license deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) ----------------------------------- RunMode ---------------------------------- -- | Represents what action should the @run@ command perform. data RunMode = Add -- ^ /add mode/ for @run@ command | Check -- ^ /check mode/ for @run@ command | Drop -- ^ /drop mode/ for @run@ command | Replace -- ^ /replace mode/ for @run@ command deriving (Eq, Show) instance FromJSON RunMode where parseJSON = \case String s -> case T.toLower s of "add" -> pure Add "check" -> pure Check "drop" -> pure Drop "replace" -> pure Replace _ -> error $ "Unknown run mode: " <> T.unpack s other -> error $ "Invalid value for run mode: " <> show other ----------------------------------- GenMode ---------------------------------- -- | Represents what action should the @gen@ command perform. data GenMode = GenConfigFile -- ^ generate /YAML/ config file stub | GenLicense (LicenseType, FileType) -- ^ generate license header template deriving (Eq, Show) ------------------------------- TemplateSource ------------------------------- -- | Source of license templates data TemplateSource = TemplateFiles [FilePath] -- ^ templates are stored as local files | BuiltInTemplates LicenseType -- ^ use built-in templates for selected license deriving (Eq, Show) ---------------------------- UpdateCopyrightConfig --------------------------- -- | Main configuration for the "Headroom.HeaderFn.UpdateCopyright" -- /license header function/. data UpdateCopyrightConfig (p :: Phase) = UpdateCopyrightConfig { uccSelectedAuthors :: p ::: Maybe (NonEmpty Text) -- ^ if specified, years will be updated only in copyright statements of -- given authors } -- | Alias for complete variant of 'UpdateCopyrightConfig'. type CtUpdateCopyrightConfig = UpdateCopyrightConfig 'Complete -- | Alias for partial variant of 'UpdateCopyrightConfig'. type PtUpdateCopyrightConfig = UpdateCopyrightConfig 'Partial deriving instance Eq CtUpdateCopyrightConfig deriving instance Eq PtUpdateCopyrightConfig deriving instance Show CtUpdateCopyrightConfig deriving instance Show PtUpdateCopyrightConfig instance FromJSON PtUpdateCopyrightConfig where parseJSON = withObject "PtUpdateCopyrightConfig" $ \obj -> do uccSelectedAuthors <- Last <$> obj .:? "selected-authors-only" pure UpdateCopyrightConfig { .. } instance Semigroup PtUpdateCopyrightConfig where x <> y = UpdateCopyrightConfig { uccSelectedAuthors = uccSelectedAuthors x <> uccSelectedAuthors y } instance Monoid PtUpdateCopyrightConfig where mempty = UpdateCopyrightConfig mempty ------------------------------- HeaderFnConfig ------------------------------- -- | Configuration for selected /license header function/. data HeaderFnConfig (p :: Phase) c = HeaderFnConfig { hfcEnabled :: p ::: Bool -- ^ whether this function is enabled or not , hfcConfig :: c p -- ^ custom configuration of the /license header function/ } -- | Alias for complete variant of 'HeaderFnConfig'. type CtHeaderFnConfig c = HeaderFnConfig 'Complete c -- | Alias for partial variant of 'HeaderFnConfig'. type PtHeaderFnConfig c = HeaderFnConfig 'Partial c deriving instance (Eq (c 'Complete)) => Eq (CtHeaderFnConfig c) deriving instance (Eq (c 'Partial)) => Eq (PtHeaderFnConfig c) deriving instance (Show (c 'Complete)) => Show (CtHeaderFnConfig c) deriving instance (Show (c 'Partial)) => Show (PtHeaderFnConfig c) instance Semigroup (c 'Partial) => Semigroup (PtHeaderFnConfig c) where x <> y = HeaderFnConfig { hfcEnabled = hfcEnabled x <> hfcEnabled y , hfcConfig = hfcConfig x <> hfcConfig y } instance Monoid (c 'Partial) => Monoid (PtHeaderFnConfig c) where mempty = HeaderFnConfig mempty mempty instance (FromJSON (c 'Partial), Monoid (c 'Partial)) => FromJSON (PtHeaderFnConfig c) where parseJSON = withObject "PtHeaderFnConfig" $ \obj -> do hfcEnabled <- Last <$> obj .:? "enabled" hfcConfig <- obj .:? "config" .!= mempty pure HeaderFnConfig { .. } ------------------------------- HeaderFnConfigs ------------------------------ -- | Configuration of all known /license header functions/. data HeaderFnConfigs (p :: Phase) = HeaderFnConfigs { hfcsUpdateCopyright :: HeaderFnConfig p UpdateCopyrightConfig -- ^ configuration for the "Headroom.HeaderFn.UpdateCopyright" -- /license header function/ } -- | Alias for complete variant of 'HeaderFnConfigs'. type CtHeaderFnConfigs = HeaderFnConfigs 'Complete -- | Alias for partial variant of 'HeaderFnConfigs'. type PtHeaderFnConfigs = HeaderFnConfigs 'Partial deriving instance Eq CtHeaderFnConfigs deriving instance Eq PtHeaderFnConfigs deriving instance Show CtHeaderFnConfigs deriving instance Show PtHeaderFnConfigs instance Semigroup PtHeaderFnConfigs where x <> y = HeaderFnConfigs { hfcsUpdateCopyright = hfcsUpdateCopyright x <> hfcsUpdateCopyright y } instance Monoid PtHeaderFnConfigs where mempty = HeaderFnConfigs mempty instance FromJSON PtHeaderFnConfigs where parseJSON = withObject "PtHeaderFnConfigs" $ \obj -> do hfcsUpdateCopyright <- obj .:? "update-copyright" .!= mempty pure HeaderFnConfigs { .. } -------------------------------- Configuration ------------------------------- -- | Application configuration. data Configuration (p :: Phase) = Configuration { cRunMode :: p ::: RunMode -- ^ mode of the @run@ command , cSourcePaths :: p ::: [FilePath] -- ^ paths to source code files , cExcludedPaths :: p ::: [Regex] -- ^ excluded source paths , cTemplateSource :: p ::: TemplateSource -- ^ source of license templates , cVariables :: Variables -- ^ variable values for templates , cLicenseHeaders :: HeadersConfig p -- ^ configuration of license headers , cHeaderFnConfigs :: HeaderFnConfigs p -- ^ configuration of license header functions } -- | Alias for complete variant of 'Configuration'. type CtConfiguration = Configuration 'Complete -- | Alias for partial variant of 'Configuration'. type PtConfiguration = Configuration 'Partial deriving instance Eq CtConfiguration deriving instance Eq PtConfiguration deriving instance Show CtConfiguration deriving instance Show PtConfiguration instance FromJSON PtConfiguration where parseJSON = withObject "PtConfiguration" $ \obj -> do cRunMode <- Last <$> obj .:? "run-mode" cSourcePaths <- Last <$> obj .:? "source-paths" cExcludedPaths <- Last <$> obj .:? "excluded-paths" cTemplateSource <- Last <$> get TemplateFiles (obj .:? "template-paths") cVariables <- fmap Variables (obj .:? "variables" .!= mempty) cLicenseHeaders <- obj .:? "license-headers" .!= mempty cHeaderFnConfigs <- obj .:? "post-process" .!= mempty pure Configuration { .. } where get = fmap . fmap instance Semigroup PtConfiguration where x <> y = Configuration { cRunMode = cRunMode x <> cRunMode y , cSourcePaths = cSourcePaths x <> cSourcePaths y , cExcludedPaths = cExcludedPaths x <> cExcludedPaths y , cTemplateSource = cTemplateSource x <> cTemplateSource y , cVariables = cVariables x <> cVariables y , cLicenseHeaders = cLicenseHeaders x <> cLicenseHeaders y , cHeaderFnConfigs = cHeaderFnConfigs x <> cHeaderFnConfigs y } instance Monoid PtConfiguration where mempty = Configuration mempty mempty mempty mempty mempty mempty mempty -------------------------------- HeaderConfig -------------------------------- -- | Configuration for specific license header. data HeaderConfig (p :: Phase) = HeaderConfig { hcFileExtensions :: p ::: [Text] -- ^ list of file extensions (without dot) , hcMarginAfter :: p ::: Int -- ^ number of empty lines to put after header , hcMarginBefore :: p ::: Int -- ^ number of empty lines to put before header , hcPutAfter :: p ::: [Regex] -- ^ /regexp/ patterns after which to put the header , hcPutBefore :: p ::: [Regex] -- ^ /regexp/ patterns before which to put the header , hcHeaderSyntax :: p ::: HeaderSyntax -- ^ syntax of the license header comment } -- | Alias for complete variant of 'HeaderConfig'. type CtHeaderConfig = HeaderConfig 'Complete -- | Alias for partial variant of 'HeaderConfig'. type PtHeaderConfig = HeaderConfig 'Partial deriving instance Eq CtHeaderConfig deriving instance Eq PtHeaderConfig deriving instance Show CtHeaderConfig deriving instance Show PtHeaderConfig instance FromJSON PtHeaderConfig where parseJSON = withObject "PartialHeaderConfig" $ \obj -> do hcFileExtensions <- Last <$> obj .:? "file-extensions" hcMarginAfter <- Last <$> obj .:? "margin-after" hcMarginBefore <- Last <$> obj .:? "margin-before" hcPutAfter <- Last <$> obj .:? "put-after" hcPutBefore <- Last <$> obj .:? "put-before" blockComment <- obj .:? "block-comment" lineComment <- obj .:? "line-comment" hcHeaderSyntax <- pure . Last $ headerSyntax blockComment lineComment pure HeaderConfig { .. } where headerSyntax (Just (BlockComment' s e)) Nothing = Just $ BlockComment s e headerSyntax Nothing (Just (LineComment' p)) = Just $ LineComment p headerSyntax Nothing Nothing = Nothing headerSyntax _ _ = throw MixedHeaderSyntax instance Monoid PtHeaderConfig where mempty = HeaderConfig mempty mempty mempty mempty mempty mempty instance Semigroup PtHeaderConfig where x <> y = HeaderConfig { hcFileExtensions = hcFileExtensions x <> hcFileExtensions y , hcMarginAfter = hcMarginAfter x <> hcMarginAfter y , hcMarginBefore = hcMarginBefore x <> hcMarginBefore y , hcPutAfter = hcPutAfter x <> hcPutAfter y , hcPutBefore = hcPutBefore x <> hcPutBefore y , hcHeaderSyntax = hcHeaderSyntax x <> hcHeaderSyntax y } -------------------------------- HeadersConfig ------------------------------- -- | Group of 'HeaderConfig' configurations for supported file types. data HeadersConfig (p :: Phase) = HeadersConfig { hscC :: HeaderConfig p -- ^ configuration for /C/ programming language , hscCpp :: HeaderConfig p -- ^ configuration for /C++/ programming language , hscCss :: HeaderConfig p -- ^ configuration for /CSS/ , hscHaskell :: HeaderConfig p -- ^ configuration for /Haskell/ programming language , hscHtml :: HeaderConfig p -- ^ configuration for /HTML/ , hscJava :: HeaderConfig p -- ^ configuration for /Java/ programming language , hscJs :: HeaderConfig p -- ^ configuration for /JavaScript/ programming language , hscPureScript :: HeaderConfig p -- ^ configuration for /PureScript/ programming language , hscRust :: HeaderConfig p -- ^ configuration for /Rust/ programming language , hscScala :: HeaderConfig p -- ^ configuration for /Scala/ programming language , hscShell :: HeaderConfig p -- ^ configuration for /Shell/ } -- | Alias for complete variant of 'HeadersConfig'. type CtHeadersConfig = HeadersConfig 'Complete -- | Alias for partial variant of 'HeadersConfig'. type PtHeadersConfig = HeadersConfig 'Partial deriving instance Eq CtHeadersConfig deriving instance Eq PtHeadersConfig deriving instance Show CtHeadersConfig deriving instance Show PtHeadersConfig instance FromJSON PtHeadersConfig where parseJSON = withObject "PartialHeadersConfig" $ \obj -> do hscC <- obj .:? "c" .!= mempty hscCpp <- obj .:? "cpp" .!= mempty hscCss <- obj .:? "css" .!= mempty hscHaskell <- obj .:? "haskell" .!= mempty hscHtml <- obj .:? "html" .!= mempty hscJava <- obj .:? "java" .!= mempty hscJs <- obj .:? "js" .!= mempty hscPureScript <- obj .:? "purescript" .!= mempty hscRust <- obj .:? "rust" .!= mempty hscScala <- obj .:? "scala" .!= mempty hscShell <- obj .:? "shell" .!= mempty pure HeadersConfig { .. } instance Semigroup PtHeadersConfig where x <> y = HeadersConfig { hscC = hscC x <> hscC y , hscCpp = hscCpp x <> hscCpp y , hscCss = hscCss x <> hscCss y , hscHaskell = hscHaskell x <> hscHaskell y , hscHtml = hscHtml x <> hscHtml y , hscJava = hscJava x <> hscJava y , hscJs = hscJs x <> hscJs y , hscPureScript = hscPureScript x <> hscPureScript y , hscRust = hscRust x <> hscRust y , hscScala = hscScala x <> hscScala y , hscShell = hscShell x <> hscShell y } instance Monoid PtHeadersConfig where mempty = HeadersConfig mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty --------------------------------- Error Types -------------------------------- -- | Represents single key in the configuration. data ConfigurationKey = CkFileExtensions FileType -- ^ no configuration for @file-extensions@ | CkHeaderSyntax FileType -- ^ no configuration for header syntax | CkMarginAfter FileType -- ^ no configuration for @margin-after@ | CkMarginBefore FileType -- ^ no configuration for @margin-before@ | CkPutAfter FileType -- ^ no configuration for @put-after@ | CkPutBefore FileType -- ^ no configuration for @put-before@ | CkRunMode -- ^ no configuration for @run-mode@ | CkSourcePaths -- ^ no configuration for @source-paths@ | CkExcludedPaths -- ^ no configuration for @excluded-paths@ | CkTemplateSource -- ^ no configuration for template source | CkVariables -- ^ no configuration for @variables@ | CkEnabled -- ^ no configuration for @enabled@ deriving (Eq, Show) -- | Exception specific to the "Headroom.Configuration" module. data ConfigurationError = MissingConfiguration ConfigurationKey -- ^ some of the required configuration keys has not been specified | MixedHeaderSyntax -- ^ illegal configuration for 'HeaderSyntax' deriving (Eq, Show, Typeable) instance Exception ConfigurationError where displayException = displayException' toException = toHeadroomError fromException = fromHeadroomError displayException' :: ConfigurationError -> String displayException' = T.unpack . \case MissingConfiguration key -> case key of CkFileExtensions fileType -> missingConfig (withFT "file-extensions" fileType) (Just "file-extensions") Nothing CkHeaderSyntax fileType -> missingConfig (withFT "comment-syntax" fileType) (Just "block-comment|line-comment") Nothing CkMarginAfter fileType -> missingConfig (withFT "margin-after" fileType) (Just "margin-after") Nothing CkMarginBefore fileType -> missingConfig (withFT "margin-before" fileType) (Just "margin-before") Nothing CkPutAfter fileType -> missingConfig (withFT "put-after" fileType) (Just "put-after") Nothing CkPutBefore fileType -> missingConfig (withFT "put-before" fileType) (Just "put-before") Nothing CkRunMode -> missingConfig "mode of the run command" (Just "run-mode") (Just "(-a|--add-headers)|(-c|--check-header)|(-d|--drop-header)|(-r|--replace-headers)" ) CkSourcePaths -> missingConfig "paths to source code files" (Just "source-paths") (Just "-s|--source-path") CkExcludedPaths -> missingConfig "excluded paths" (Just "excluded-paths") (Just "-e|--excluded-path") CkTemplateSource -> missingConfig "template files source" (Just "template-paths") (Just "(-t|--template-path)|--builtin-templates") CkVariables -> missingConfig "template variables" (Just "variables") (Just "-v|--variable") CkEnabled -> missingConfig "enabled" (Just "enabled") Nothing MixedHeaderSyntax -> mixedHeaderSyntax where withFT msg fileType = msg <> " (" <> T.pack (show fileType) <> ")" mixedHeaderSyntax = mconcat [ "Invalid configuration, combining 'block-comment' with 'line-comment' " , "is not allowed. Either use 'block-comment' to define multi-line " , "comment header, or 'line-comment' to define header composed of " , "multiple single-line comments." ] missingConfig :: Text -> Maybe Text -> Maybe Text -> Text missingConfig desc yaml cli = mconcat [ "Missing configuration for '" , desc , "' (" , options , "). See official documentation for more details." ] where cliText = fmap (\c -> "command line option '" <> c <> "'") cli yamlText = fmap (\y -> "YAML option '" <> y <> "'") yaml options = T.intercalate " or " . catMaybes $ [cliText, yamlText]