diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ ## unreleased +### 0.1.7.0 -- 2024-09-28 + +### Added + +- Support for Cabal-syntax-3.14.0.0 + ## 0.1.6.0 -- 2024-08-18 ### Added diff --git a/bin/initialise/Main.hs b/bin/initialise/Main.hs --- a/bin/initialise/Main.hs +++ b/bin/initialise/Main.hs @@ -1,24 +1,9 @@ module Main (main) where -import qualified Configuration (parser) import qualified Defaults (getDefaults) import Initialiser (defaultInitialiser, runInitialiser) -import Options.Applicative (execParser, fullDesc, helper, info, progDesc, (<**>)) +import qualified Options (parserInfo) +import Options.Applicative (execParser) main :: IO () -main = do - defaults <- Defaults.getDefaults - - let options = - info - (Configuration.parser defaults <**> helper) - ( fullDesc - <> progDesc - ( unlines - [ "Initialise a new project using the current checked out repository.", - "WARNING: THIS WILL MODIFY THE CURRENT CONTENTS OF YOUR CHECKED OUT REPOSITORY!" - ] - ) - ) - - execParser options >>= runInitialiser defaultInitialiser +main = Defaults.getDefaults >>= execParser . Options.parserInfo >>= runInitialiser defaultInitialiser diff --git a/lib/initialise/Cabal.hs b/lib/initialise/Cabal.hs --- a/lib/initialise/Cabal.hs +++ b/lib/initialise/Cabal.hs @@ -7,12 +7,12 @@ module Cabal (replace, convert) where -import Configuration (Configuration (..)) -import Control.Monad.Catch (throwM) +import Control.Monad.Catch (Exception, throwM) import Control.Monad.Logger (logInfo) import Control.Monad.Reader (MonadReader (ask), asks, liftIO) import Data.ByteString (ByteString, append, breakSubstring, concat, readFile, stripPrefix) -import qualified Data.ByteString.Char8 as BS (pack) +import qualified Data.ByteString.Char8 as BS (pack, unpack) +import Data.List.NonEmpty (head, nonEmpty) import Data.Text (Text, unlines) import qualified Data.Text as T (pack, unpack) import Data.Text.Encoding (encodeUtf8) @@ -30,17 +30,22 @@ import Distribution.Fields.Field (fieldLineAnn) import Distribution.Parsec.Position (Position) import Distribution.SPDX (licenseId) +import qualified Environment (T (..)) import Initialiser.Types (Initialiser) import System.Directory.Extra (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) import System.FilePath (replaceBaseName, ()) -import Prelude hiding (concat, readFile, unlines, writeFile) +import Prelude hiding (concat, head, readFile, unlines, writeFile) #if __GLASGOW_HASKELL__ < 908 -import Control.Exception (Exception) import Text.Parsec.Error (ParseError) instance Exception ParseError #endif +newtype MissingAnnotationException = MissingAnnotationException Text + deriving (Show) + +instance Exception MissingAnnotationException + replace :: FilePath -> Initialiser () replace path = do replaceCabal path @@ -51,7 +56,7 @@ replaceCabal :: FilePath -> Initialiser () replaceCabal path = do -- TODO handle in replaceWith - path' <- asks (replaceBaseName path . T.unpack . name) + path' <- asks (replaceBaseName path . T.unpack . Environment.name) $logInfo ("replacing cabal " <> T.pack (show path) <> " with " <> T.pack (show path')) -- TODO replaceWith convert contents <- liftIO $ readFile path @@ -67,7 +72,11 @@ convert' :: Field Position -> Initialiser (Field Position) convert' f@(Field n@(Name _ fName) ls) = do - Configuration {..} <- asks id + Environment.T {..} <- asks id + annotation <- case nonEmpty ls of + (Just ls') -> pure $ fieldLineAnn (head ls') + Nothing -> throwM $ MissingAnnotationException $ "field " <> T.pack (BS.unpack fName) <> " has no annotation" + let field s = pure $ Field n [FieldLine annotation s] case fName of -- package "name" -> field (encodeUtf8 cabalName) @@ -89,11 +98,8 @@ -- source-repository "location" -> field $ BS.pack $ show homepage _ -> pure f - where - field s = pure $ Field n [FieldLine annotation s] - annotation = fieldLineAnn . head $ ls convert' (Section n arguments fs) = do - Configuration {..} <- asks id + Environment.T {..} <- asks id fs' <- mapM convert' fs pure $ Section n (map (convertSectionArgument name) arguments) fs' @@ -117,7 +123,7 @@ -- TODO Move to Initialise module? replaceDirectoryWith :: FilePath -> (FilePath -> Initialiser ()) -> Initialiser () replaceDirectoryWith component r = do - Configuration {..} <- ask + Environment.T {..} <- ask let new = component T.unpack name let original = component "initialise" $logInfo ("replacing directory " <> T.pack (show original) <> " with " <> T.pack (show new)) @@ -130,7 +136,7 @@ replaceTest :: FilePath -> Initialiser () replaceTest path = do - name' <- asks name + name' <- asks Environment.name -- TODO Template library. liftIO $ writeFile (path "Main.hs") $ @@ -145,7 +151,7 @@ replaceBin :: FilePath -> Initialiser () replaceBin path = do - name' <- asks name + name' <- asks Environment.name -- TODO Template library.(*) liftIO $ writeFile (path "Main.hs") $ diff --git a/lib/initialise/Configuration.hs b/lib/initialise/Configuration.hs deleted file mode 100644 --- a/lib/initialise/Configuration.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Configuration - ( Configuration (..), - parser, - ) -where - -import Control.Monad.Logger (LogLevel) -import Control.Monad.Logger.CallStack (LogLevel (LevelWarn)) -import Data.Text (Text) -import Data.Time.Calendar (Year) -import Defaults (Defaults (..), dCabalName, dHomePage, dName) -import Distribution.SPDX.LicenseId (LicenseId (Unlicense)) -import Network.URI (URI, parseURI) -import Options.Applicative - ( Parser, - auto, - help, - hidden, - internal, - long, - metavar, - option, - showDefault, - strOption, - value, - ) -import Options.Applicative.Builder (maybeReader) - -data Configuration = Configuration - { name :: Text, - cabalName :: Text, - homepage :: URI, - author :: Text, - maintainer :: Text, - licence :: LicenseId, - path :: FilePath, - year :: Year, - verbosity :: LogLevel - } - -parser :: Defaults -> Parser Configuration -parser ds@(Defaults {..}) = do - name <- - strOption - ( long "name" - <> help "Name of the new project." - <> metavar - "NAME" - <> maybeDefault (dName ds) - ) - cabalName <- - strOption - ( long "cabal-name" - <> help "Name to use in cabal." - <> metavar "CABAL_NAME" - <> maybeDefault (dCabalName ds) - ) - homepage <- - option - (maybeReader parseURI) - ( long "homepage" - <> help - "Homepage of the new project." - <> metavar "URL" - <> maybeDefault (dHomePage ds) - ) - author <- - strOption - ( long "author" - <> help "Name of the author of the project." - <> metavar "AUTHOR" - <> value dAuthor - <> showDefault - ) - maintainer <- - strOption - ( long "maintainer" - <> help - "Email of the maintainer of the project." - <> metavar "MAINTAINER" - <> value dMaintainer - <> showDefault - ) - licence <- - option - auto - ( long "licence" - <> help "Licence of the project." - <> value Unlicense - <> showDefault - <> metavar "LICENCE" - ) - path <- - option - auto - ( long "path" - <> help "Project path. Only used for testing." - <> value dPath - <> showDefault - <> metavar "PATH" - <> hidden - <> internal - ) - year <- - option - auto - ( long "year" - <> help "Copyright year. Only used for testing." - <> value dYear - <> showDefault - <> metavar "YEAR" - <> hidden - <> internal - ) - verbosity <- - option - auto - ( long "verbosity" - <> help - "Verbosity of information printed to stderr." - <> value LevelWarn - <> showDefault - <> metavar "VERBOSITY" - ) - pure Configuration {..} - where - -- maybeDefault :: (HasValue f, Show a) => Maybe a -> Mod f a - maybeDefault (Just a) = value a <> showDefault - maybeDefault Nothing = mempty diff --git a/lib/initialise/Environment.hs b/lib/initialise/Environment.hs new file mode 100644 --- /dev/null +++ b/lib/initialise/Environment.hs @@ -0,0 +1,20 @@ +module Environment (T (..)) where + +import Control.Monad.Logger (LogLevel) +import Data.Text (Text) +import Data.Time.Calendar (Year) +import Distribution.SPDX.LicenseId (LicenseId) +import Network.URI (URI) + +data T = T + { name :: Text, + cabalName :: Text, + homepage :: URI, + author :: Text, + maintainer :: Text, + licence :: LicenseId, + path :: FilePath, + year :: Year, + verbosity :: LogLevel + } + deriving (Show) diff --git a/lib/initialise/File.hs b/lib/initialise/File.hs --- a/lib/initialise/File.hs +++ b/lib/initialise/File.hs @@ -8,12 +8,12 @@ ) where -import Configuration (Configuration (..)) import Control.Monad.Logger (logInfo) import Control.Monad.Reader (MonadIO (liftIO), MonadReader (ask)) import Data.Text (Text, pack) import qualified Data.Text as T (replace) import Data.Text.IO (readFile, writeFile) +import qualified Environment (T (..)) import Initialiser.Types (Initialiser) import Prelude hiding (readFile, writeFile) @@ -27,7 +27,7 @@ convert :: Text -> Initialiser Text convert contents = do - Configuration {..} <- ask + Environment.T {..} <- ask pure . T.replace "templatise" name . T.replace "template-hs" name diff --git a/lib/initialise/Initialiser/Types.hs b/lib/initialise/Initialiser/Types.hs --- a/lib/initialise/Initialiser/Types.hs +++ b/lib/initialise/Initialiser/Types.hs @@ -6,16 +6,16 @@ ) where -import Configuration (Configuration) import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (LoggingT, MonadLogger, runStderrLoggingT) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) +import qualified Environment (T) newtype Initialiser a = Initialiser - { run :: LoggingT (ReaderT Configuration IO) a + { run :: LoggingT (ReaderT Environment.T IO) a } - deriving (Applicative, Functor, Monad, MonadIO, MonadLogger, MonadReader Configuration, MonadThrow) + deriving (Applicative, Functor, Monad, MonadIO, MonadLogger, MonadReader Environment.T, MonadThrow) -runInitialiser :: Initialiser a -> Configuration -> IO a +runInitialiser :: Initialiser a -> Environment.T -> IO a runInitialiser initialiser = runReaderT (runStderrLoggingT $ run initialiser) diff --git a/lib/initialise/Licence.hs b/lib/initialise/Licence.hs --- a/lib/initialise/Licence.hs +++ b/lib/initialise/Licence.hs @@ -7,13 +7,13 @@ ) where -import Configuration (Configuration (..)) import Control.Monad (unless) import Control.Monad.Logger (logInfo) import Control.Monad.Reader (ask, liftIO) import Data.ByteString.Lazy (ByteString, writeFile) import Data.Text (pack) import Distribution.SPDX.LicenseId (LicenseId (Unlicense), licenseId) +import qualified Environment (T (..)) import Initialiser.Types (Initialiser) import Network.HTTP.Client (responseBody) import Network.HTTP.Simple (httpLBS, parseRequest) @@ -22,7 +22,7 @@ replace :: FilePath -> Initialiser () replace p = do - Configuration {..} <- ask + Environment.T {..} <- ask unless (licence == Unlicense) $ do $logInfo ("replacing LICENSE " <> pack (show p)) liftIO (writeFile (path p) =<< contents licence) diff --git a/lib/initialise/Options.hs b/lib/initialise/Options.hs new file mode 100644 --- /dev/null +++ b/lib/initialise/Options.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Options (parserInfo) where + +import Control.Monad.Logger.CallStack (LogLevel (LevelWarn)) +import Defaults (Defaults (..), dCabalName, dHomePage, dName) +import Distribution.SPDX.LicenseId (LicenseId (Unlicense)) +import qualified Environment (T (..)) +import Network.URI (parseURI) +import Options.Applicative + ( HasValue, + Mod, + Parser, + ParserInfo, + auto, + fullDesc, + help, + helper, + hidden, + info, + internal, + long, + metavar, + option, + progDesc, + showDefault, + strOption, + value, + (<**>), + ) +import Options.Applicative.Builder (maybeReader) + +parserInfo :: Defaults -> ParserInfo Environment.T +parserInfo ds = + info + (parser ds <**> helper) + ( fullDesc + <> progDesc + ( unlines + [ "Initialise a new project using the current checked out repository.", + "WARNING: THIS WILL MODIFY THE CURRENT CONTENTS OF YOUR CHECKED OUT REPOSITORY!" + ] + ) + ) + +parser :: Defaults -> Parser Environment.T +parser ds@(Defaults {..}) = do + name <- + strOption + ( long "name" + <> help "Name of the new project." + <> metavar + "NAME" + <> maybeDefault (dName ds) + ) + cabalName <- + strOption + ( long "cabal-name" + <> help "Name to use in cabal." + <> metavar "CABAL_NAME" + <> maybeDefault (dCabalName ds) + ) + homepage <- + option + (maybeReader parseURI) + ( long "homepage" + <> help + "Homepage of the new project." + <> metavar "URL" + <> maybeDefault (dHomePage ds) + ) + author <- + strOption + ( long "author" + <> help "Name of the author of the project." + <> metavar "AUTHOR" + <> value dAuthor + <> showDefault + ) + maintainer <- + strOption + ( long "maintainer" + <> help + "Email of the maintainer of the project." + <> metavar "MAINTAINER" + <> value dMaintainer + <> showDefault + ) + licence <- + option + auto + ( long "licence" + <> help "Licence of the project." + <> value Unlicense + <> showDefault + <> metavar "LICENCE" + ) + path <- + option + auto + ( long "path" + <> help "Project path. Only used for testing." + <> value dPath + <> showDefault + <> metavar "PATH" + <> hidden + <> internal + ) + year <- + option + auto + ( long "year" + <> help "Copyright year. Only used for testing." + <> value dYear + <> showDefault + <> metavar "YEAR" + <> hidden + <> internal + ) + verbosity <- + option + auto + ( long "verbosity" + <> help + "Verbosity of information printed to stderr." + <> value LevelWarn + <> showDefault + <> metavar "VERBOSITY" + ) + pure Environment.T {..} + +maybeDefault :: (HasValue f, Show a) => Maybe a -> Mod f a +maybeDefault (Just a) = value a <> showDefault +maybeDefault Nothing = mempty diff --git a/templatise.cabal b/templatise.cabal --- a/templatise.cabal +++ b/templatise.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: templatise -version: 0.1.6.0 +version: 0.1.7.0 license: Unlicense license-file: LICENSE copyright: (c) 2023 Alex Brandt @@ -37,9 +37,9 @@ common initialise-common build-depends: - , base ^>=4.16.3.0 || ^>=4.17 || ^>=4.18 || ^>=4.19 || ^>=4.20 + , base ^>=4.16.3.0 || ^>=4.17 || ^>=4.18 || ^>=4.19 || ^>=4.20 , bytestring ^>=0.11.3.1 || ^>=0.12.0.2 - , Cabal-syntax ^>=3.8.1.0 || ^>=3.10.1.0 || ^>=3.12.0.0 + , Cabal-syntax ^>=3.8.1.0 || ^>=3.10.1.0 || ^>=3.12.0.0 || ^>=3.14.0.0 , filepath >=1.4.2.2 && <1.6 , monad-logger ^>=0.3.40 , mtl ^>=2.2.2 || ^>=2.3.1 @@ -58,12 +58,13 @@ import: initialise-common exposed-modules: Cabal - Configuration Defaults + Environment File Git Initialiser Licence + Options -- TODO Make Git private. other-modules: @@ -97,7 +98,6 @@ , directory ^>=1.3.6.2 , hspec ^>=2.11.4 , initialise-library - , MissingH ^>=1.6.0.1 , tasty ^>=1.4.3 || ^>=1.5 , tasty-golden ^>=2.3.5 , tasty-hspec ^>=1.2.0.4 @@ -105,12 +105,12 @@ other-modules: CabalGolden - ConfigurationSpec DefaultsSpec FileGolden GitSpec Hooks InitialiseSpec + OptionsSpec hs-source-dirs: test/initialise diff --git a/test/initialise/CabalGolden.hs b/test/initialise/CabalGolden.hs --- a/test/initialise/CabalGolden.hs +++ b/test/initialise/CabalGolden.hs @@ -3,7 +3,6 @@ module CabalGolden (golden) where import qualified Cabal as SUT -import Configuration (Configuration (..)) import Control.Monad.Logger (LogLevel (LevelDebug)) import Control.Monad.Reader (liftIO) import Data.ByteString (readFile) @@ -11,6 +10,7 @@ import Data.Maybe (fromJust) import Data.Text (unpack) import Distribution.SPDX.LicenseId (LicenseId (MIT)) +import qualified Environment (T (..)) import Initialiser (runInitialiser) import Network.URI (parseURI) import System.FilePath (isExtensionOf, normalise, replaceExtension, takeBaseName) @@ -35,16 +35,16 @@ gold = p `replaceExtension` ".golden.cabal" action = do contents <- liftIO (readFile p) - pack . unpack <$> runInitialiser (SUT.convert contents) configuration - configuration = - Configuration - { name = "sentinel", - cabalName = "sentinel", - homepage = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), - author = "Sentinel", - maintainer = "sentinel@example.com", - licence = MIT, - path = ".", - year = 1970, - verbosity = LevelDebug + pack . unpack <$> runInitialiser (SUT.convert contents) environment + environment = + Environment.T + { Environment.name = "sentinel", + Environment.cabalName = "sentinel", + Environment.homepage = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), + Environment.author = "Sentinel", + Environment.maintainer = "sentinel@example.com", + Environment.licence = MIT, + Environment.path = ".", + Environment.year = 1970, + Environment.verbosity = LevelDebug } diff --git a/test/initialise/ConfigurationSpec.hs b/test/initialise/ConfigurationSpec.hs deleted file mode 100644 --- a/test/initialise/ConfigurationSpec.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ConfigurationSpec (spec) where - -import qualified Configuration as SUT -import Data.String.Utils (strip) -import Defaults (Defaults (..)) -import Options.Applicative - ( ParserResult - ( CompletionInvoked, - Failure, - Success - ), - defaultPrefs, - execParserPure, - helper, - info, - renderFailure, - (<**>), - ) -import System.Exit (ExitCode (ExitFailure)) -import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldBe) - -spec :: Spec -spec = - describe "Configuration" $ do - describe "parser" $ do - it "should error if homepage isn't a URI" $ - parse ["--homepage", "not-a-url"] - `shouldFailWith` ( strip $ - unlines - ( [ "option --homepage: cannot parse value `not-a-url'", - "" - ] - <> usage - ), - ExitFailure 1 - ) - it "should error if licence isn't an SPDX licence ID" $ do - parse ["--licence", "not-a-licence"] - `shouldFailWith` ( strip $ - unlines - ( [ "option --licence: cannot parse value `not-a-licence'", - "" - ] - <> usage - ), - ExitFailure 1 - ) - -parse :: [String] -> ParserResult SUT.Configuration -parse = - execParserPure - defaultPrefs - ( info (SUT.parser defaults <**> helper) mempty - ) - -shouldFailWith :: ParserResult SUT.Configuration -> (String, ExitCode) -> Expectation -shouldFailWith (Success _) _ = expectationFailure "Expected Failure but got Success" -shouldFailWith (CompletionInvoked _) _ = expectationFailure "Expected Failure but got CompletionInvoked" -shouldFailWith (Failure f) rhs = renderFailure f "" `shouldBe` rhs - -defaults :: Defaults -defaults = - Defaults - { dOrigin = "http://github.com/username/repository.git", - dAuthor = "Forename Surname", - dMaintainer = "username@example.com", - dPath = ".", - dYear = 1970 - } - --- TODO ask the parser for the usage string. -usage :: [String] -usage = - [ "Usage: [--name NAME] [--cabal-name CABAL_NAME] [--homepage URL] ", - " [--author AUTHOR] [--maintainer MAINTAINER] [--licence LICENCE] ", - " [--verbosity VERBOSITY]" - ] diff --git a/test/initialise/FileGolden.hs b/test/initialise/FileGolden.hs --- a/test/initialise/FileGolden.hs +++ b/test/initialise/FileGolden.hs @@ -2,7 +2,6 @@ module FileGolden (golden) where -import Configuration (Configuration (..)) import Control.Monad.Logger (LogLevel (LevelDebug)) import Control.Monad.Reader (liftIO) import Data.Maybe (fromJust) @@ -10,6 +9,7 @@ import Data.Text.Lazy (fromStrict) import Data.Text.Lazy.Encoding (encodeUtf8) import Distribution.SPDX.LicenseId (LicenseId (MIT)) +import qualified Environment (T (..)) import qualified File as SUT import Initialiser (runInitialiser) import Network.URI (parseURI) @@ -46,14 +46,14 @@ contents <- liftIO (readFile p) encodeUtf8 . fromStrict <$> runInitialiser (SUT.convert contents) configuration configuration = - Configuration - { name = "sentinel", - cabalName = "sentinel", - homepage = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), - author = "Sentinel", - maintainer = "sentinel@example.com", - licence = MIT, - path = ".", - year = 1970, - verbosity = LevelDebug + Environment.T + { Environment.name = "sentinel", + Environment.cabalName = "sentinel", + Environment.homepage = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), + Environment.author = "Sentinel", + Environment.maintainer = "sentinel@example.com", + Environment.licence = MIT, + Environment.path = ".", + Environment.year = 1970, + Environment.verbosity = LevelDebug } diff --git a/test/initialise/InitialiseSpec.hs b/test/initialise/InitialiseSpec.hs --- a/test/initialise/InitialiseSpec.hs +++ b/test/initialise/InitialiseSpec.hs @@ -2,11 +2,11 @@ module InitialiseSpec (spec) where -import Configuration (Configuration (..)) import Control.Monad.Logger (LogLevel (LevelDebug)) import Data.Maybe (fromJust) import Data.Text (Text, pack) import Distribution.SPDX (LicenseId (MIT)) +import qualified Environment (T (..)) import Hooks (withProjectCopy) import qualified Initialiser as SUT import Network.URI (parseURI) @@ -20,16 +20,16 @@ describe "defaultInitialiser" $ do runIO $ withProjectCopy $ \p -> do let configuration = - Configuration - { name = "sentinel", - cabalName = "sentinel", - homepage = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), - author = "Sentinel", - maintainer = "sentinel@example.com", - licence = MIT, - path = p, - year = 1970, - verbosity = LevelDebug + Environment.T + { Environment.name = "sentinel", + Environment.cabalName = "sentinel", + Environment.homepage = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), + Environment.author = "Sentinel", + Environment.maintainer = "sentinel@example.com", + Environment.licence = MIT, + Environment.path = p, + Environment.year = 1970, + Environment.verbosity = LevelDebug } SUT.runInitialiser SUT.defaultInitialiser configuration diff --git a/test/initialise/Main.hs b/test/initialise/Main.hs --- a/test/initialise/Main.hs +++ b/test/initialise/Main.hs @@ -1,11 +1,11 @@ module Main (main) where import qualified CabalGolden (golden) -import qualified ConfigurationSpec (spec) import qualified DefaultsSpec (spec) import qualified FileGolden (golden) import qualified GitSpec (spec) import qualified InitialiseSpec (spec) +import qualified OptionsSpec (spec) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.Hspec (testSpecs) @@ -15,7 +15,7 @@ concat <$> mapM testSpecs - [ ConfigurationSpec.spec, + [ OptionsSpec.spec, DefaultsSpec.spec, GitSpec.spec, InitialiseSpec.spec diff --git a/test/initialise/OptionsSpec.hs b/test/initialise/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/initialise/OptionsSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module OptionsSpec (spec) where + +import Data.Text (Text, isInfixOf, pack) +import Defaults (Defaults (..)) +import qualified Environment (T) +import qualified Options as SUT +import Options.Applicative + ( ParserResult + ( CompletionInvoked, + Failure, + Success + ), + defaultPrefs, + execParserPure, + renderFailure, + ) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import Test.Hspec (Spec, describe, it, shouldSatisfy) + +spec :: Spec +spec = + describe "Options" $ do + describe "parserInfo" $ do + it "should error if homepage isn't a URI" $ + parse ["--homepage", "not-a-url"] + `shouldSatisfy` failWith "option --homepage: cannot parse value `not-a-url'" + it "should error if licence isn't an SPDX licence ID" $ do + parse ["--licence", "not-a-licence"] + `shouldSatisfy` failWith "option --licence: cannot parse value `not-a-licence'" + +failWith :: Text -> ParserResult a -> Bool +failWith _ (Success _) = False +failWith _ (CompletionInvoked _) = False +failWith m (Failure f) = case renderFailure f "" of + (_, ExitSuccess) -> False + (m', ExitFailure _) -> m `isInfixOf` pack m' + +parse :: [String] -> ParserResult Environment.T +parse = + execParserPure defaultPrefs (SUT.parserInfo defaults) + +defaults :: Defaults +defaults = + Defaults + { dOrigin = "http://github.com/username/repository.git", + dAuthor = "Forename Surname", + dMaintainer = "username@example.com", + dPath = ".", + dYear = 1970 + }