diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.16.3 +# version: 0.18.1 # -# REGENDATA ("0.16.3",["github","--haddock","templatise.cabal"]) +# REGENDATA ("0.18.1",["github","--haddock","templatise.cabal"]) # name: Haskell-CI on: @@ -28,21 +28,76 @@ strategy: matrix: include: + - compiler: ghc-9.8.2 + compilerKind: ghc + compilerVersion: 9.8.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.8.1 + compilerKind: ghc + compilerVersion: 9.8.1 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.6.4 + compilerKind: ghc + compilerVersion: 9.6.4 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.6.3 + compilerKind: ghc + compilerVersion: 9.6.3 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.6.2 compilerKind: ghc compilerVersion: 9.6.2 setup-method: ghcup allow-failure: false + - compiler: ghc-9.6.1 + compilerKind: ghc + compilerVersion: 9.6.1 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.8 + compilerKind: ghc + compilerVersion: 9.4.8 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.7 + compilerKind: ghc + compilerVersion: 9.4.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.6 + compilerKind: ghc + compilerVersion: 9.4.6 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.4.5 compilerKind: ghc compilerVersion: 9.4.5 setup-method: ghcup allow-failure: false - - compiler: ghc-9.2.4 + - compiler: ghc-9.4.4 compilerKind: ghc - compilerVersion: 9.2.4 + compilerVersion: 9.4.4 setup-method: ghcup allow-failure: false + - compiler: ghc-9.4.3 + compilerKind: ghc + compilerVersion: 9.4.3 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.2 + compilerKind: ghc + compilerVersion: 9.4.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.1 + compilerKind: ghc + compilerVersion: 9.4.1 + setup-method: ghcup + allow-failure: false fail-fast: false steps: - name: apt @@ -50,10 +105,10 @@ apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -65,11 +120,13 @@ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,30 @@ # Revision history for template-hs +## unreleased + +## 0.1.3.0 -- 2024-05-25 + +### Added + +* --cabal-name option to specify a Cabal friendly name independent from the + repository or other names. +* Test GHC 9.8.2, 9.8.1, 9.6.4, 9.6.3, 9.6.1, 9.4.8, 9.4.7, 9.4.6, 9.4.4, 9.4.3, + 9.4.2, and 9.4.1 +* Add support for text-2.0.1 +* Add support for Cabal-syntax-3.12.0.0 + +### Changed + +* Throw errors upon empty output from git commands + +### Deprecated + +### Fixed + +### Removed + +### Security + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/bin/initialise/Main.hs b/bin/initialise/Main.hs --- a/bin/initialise/Main.hs +++ b/bin/initialise/Main.hs @@ -1,13 +1,9 @@ module Main (main) where -import qualified Cabal (replace) import qualified Configuration (parser) import qualified Defaults (getDefaults) -import qualified File (replace) -import Initialise (Initialise, defaultInitialiser, runInitialise) -import qualified Licence (replace) +import Initialiser (defaultInitialiser, runInitialiser) import Options.Applicative (execParser, fullDesc, helper, info, progDesc, (<**>)) -import System.FilePath (()) main :: IO () main = do @@ -25,4 +21,4 @@ ) ) - execParser options >>= runInitialise defaultInitialiser + execParser options >>= runInitialiser defaultInitialiser diff --git a/lib/initialise/Cabal.hs b/lib/initialise/Cabal.hs --- a/lib/initialise/Cabal.hs +++ b/lib/initialise/Cabal.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cabal (replace, convert) where @@ -8,7 +10,8 @@ import Configuration (Configuration (..)) import Control.Exception (Exception) import Control.Monad.Catch (throwM) -import Control.Monad.Reader (asks, liftIO) +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 Data.Text (Text, unlines) @@ -28,25 +31,28 @@ import Distribution.Fields.Field (fieldLineAnn) import Distribution.Parsec.Position (Position) import Distribution.SPDX (licenseId) -import Initialise.Types (Initialise) +import Initialiser.Types (Initialiser) import System.Directory.Extra (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) import System.FilePath (replaceBaseName, ()) -import Text.Parsec.Error (ParseError) import Prelude hiding (concat, readFile, unlines, writeFile) +#if __GLASGOW_HASKELL__ < 908 +import Text.Parsec.Error (ParseError) instance Exception ParseError +#endif -replace :: FilePath -> Initialise () +replace :: FilePath -> Initialiser () replace path = do replaceCabal path "lib" `replaceDirectoryWith` replaceLib "test" `replaceDirectoryWith` replaceTest "bin" `replaceDirectoryWith` replaceBin -replaceCabal :: FilePath -> Initialise () +replaceCabal :: FilePath -> Initialiser () replaceCabal path = do -- TODO handle in replaceWith path' <- asks (replaceBaseName path . T.unpack . name) + $logInfo ("replacing cabal " <> T.pack (show path) <> " with " <> T.pack (show path')) -- TODO replaceWith convert contents <- liftIO $ readFile path contents' <- convert contents @@ -54,17 +60,17 @@ -- TODO handle in replaceWith liftIO $ removeFile path -convert :: ByteString -> Initialise Text +convert :: ByteString -> Initialiser Text convert contents = do fs <- either throwM pure (readFields contents) T.pack . showFields (const NoComment) . fromParsecFields <$> mapM convert' fs -convert' :: Field Position -> Initialise (Field Position) +convert' :: Field Position -> Initialiser (Field Position) convert' f@(Field n@(Name _ fName) ls) = do Configuration {..} <- asks id case fName of -- package - "name" -> field (encodeUtf8 name) + "name" -> field (encodeUtf8 cabalName) "version" -> field "0.1.0.0" "license" -> field (BS.pack $ licenseId licence) "copyright" -> field (BS.pack $ unwords ["(c)", show year, T.unpack author]) @@ -109,18 +115,20 @@ token = "initialise" -- TODO Move to Initialise module? -replaceDirectoryWith :: FilePath -> (FilePath -> Initialise ()) -> Initialise () +replaceDirectoryWith :: FilePath -> (FilePath -> Initialiser ()) -> Initialiser () replaceDirectoryWith component r = do - name' <- asks name - path' <- asks (( component T.unpack name') . path) - liftIO $ createDirectoryIfMissing True path' - r path' - liftIO $ removeDirectoryRecursive $ replaceBaseName "initialise" path' + Configuration {..} <- ask + let new = component T.unpack name + let original = component "initialise" + $logInfo ("replacing directory " <> T.pack (show original) <> " with " <> T.pack (show new)) + liftIO $ createDirectoryIfMissing True $ path new + r $ path new + liftIO $ removeDirectoryRecursive $ path original -replaceLib :: FilePath -> Initialise () +replaceLib :: FilePath -> Initialiser () replaceLib _path = pure () -replaceTest :: FilePath -> Initialise () +replaceTest :: FilePath -> Initialiser () replaceTest path = do name' <- asks name -- TODO Template library. @@ -135,7 +143,7 @@ "main = defaultMain $ testGroup \"" <> name' <> "-library\" []" ] -replaceBin :: FilePath -> Initialise () +replaceBin :: FilePath -> Initialiser () replaceBin path = do name' <- asks name -- TODO Template library.(*) diff --git a/lib/initialise/Configuration.hs b/lib/initialise/Configuration.hs --- a/lib/initialise/Configuration.hs +++ b/lib/initialise/Configuration.hs @@ -7,13 +7,17 @@ ) 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 (..), dHomePage, dName) +import Defaults (Defaults (..), dCabalName, dHomePage, dName) import Distribution.SPDX.LicenseId (LicenseId (Unlicense)) import Network.URI (URI, parseURI) import Options.Applicative - ( Parser, + ( HasValue, + Mod, + Parser, auto, help, hidden, @@ -29,71 +33,108 @@ data Configuration = Configuration { name :: Text, + cabalName :: Text, homepage :: URI, author :: Text, maintainer :: Text, licence :: LicenseId, path :: FilePath, - year :: Year + year :: Year, + verbosity :: LogLevel } parser :: Defaults -> Parser Configuration parser ds@(Defaults {..}) = Configuration - <$> strOption - ( long "name" - <> help "Name of the new project." - <> metavar "NAME" - <> value (dName ds) - <> showDefault - ) - <*> option - (maybeReader parseURI) - ( long "homepage" - <> help "Homepage of the new project." - <> metavar "URL" - <> value (dHomePage ds) - <> showDefault - ) - <*> strOption - ( long "author" - <> help "Name of the author of the project." - <> metavar "AUTHOR" - <> value dAuthor - <> showDefault - ) - <*> strOption - ( long "maintainer" - <> help "Email of the maintainer of the project." - <> metavar "MAINTAINER" - <> value dMaintainer - <> showDefault - ) - <*> option - auto - ( long "licence" - <> help "Licence of the project." - <> value Unlicense - <> showDefault - <> metavar "LICENCE" - ) - <*> option - auto - ( long "path" - <> help "Project path. Only used for testing." - <> value dPath - <> showDefault - <> metavar "PATH" - <> hidden - <> internal - ) - <*> option - auto - ( long "year" - <> help "Copyright year. Only used for testing." - <> value dYear - <> showDefault - <> metavar "YEAR" - <> hidden - <> internal - ) + <$> name + <*> cabalName + <*> homepage + <*> author + <*> maintainer + <*> licence + <*> path + <*> year + <*> verbosity + where + 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" + ) + +maybeDefault :: (HasValue f, Show a) => Maybe a -> Mod f a +maybeDefault (Just a) = value a <> showDefault +maybeDefault Nothing = mempty diff --git a/lib/initialise/Defaults.hs b/lib/initialise/Defaults.hs --- a/lib/initialise/Defaults.hs +++ b/lib/initialise/Defaults.hs @@ -6,21 +6,25 @@ Defaults (..), dName, dHomePage, + dCabalName, + isValidPackageName, ) where -import Data.Maybe (fromJust) -import Data.Text (Text, pack, unpack) +import Control.Applicative ((<|>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, replace, stripPrefix, unpack) import Data.Time (LocalTime (localDay), getCurrentTime, getCurrentTimeZone, utcToLocalTime) import Data.Time.Calendar (Year) import Data.Time.Calendar.OrdinalDate (toOrdinalDate) import qualified Git (config) import Network.URI (URI (uriPath), parseURI) import System.Directory.Extra (getCurrentDirectory) -import System.FilePath (dropExtension, takeBaseName) +import System.FilePath (stripExtension, takeFileName) +import Text.Regex.TDFA ((=~)) data Defaults = Defaults - { dOrigin :: URI, + { dOrigin :: Text, dAuthor :: Text, dMaintainer :: Text, dPath :: FilePath, @@ -28,21 +32,39 @@ } deriving (Show, Eq) -dName :: Defaults -> Text -dName Defaults {..} = pack . takeBaseName . uriPath $ dOrigin +dName :: Defaults -> Maybe Text +dName = fmap toName . dHomePage + where + toName = pack . takeFileName . uriPath -dHomePage :: Defaults -> URI +dCabalName :: Defaults -> Maybe Text +dCabalName ds = do + name <- dName ds + if isValidPackageName name then Just name else Nothing + +dHomePage :: Defaults -> Maybe URI dHomePage Defaults {..} = - dOrigin - { uriPath = dropExtension $ uriPath dOrigin - } + stripURIExtension "git" + <$> ( toURI dOrigin + <|> (toURI =<< sshToHttp dOrigin) + ) + where + sshToHttp = fmap (("http://" <>) . replace ":" "/") . stripPrefix "git@" + toURI = parseURI . unpack + stripURIExtension ext uri = + let p = uriPath uri + in uri {uriPath = fromMaybe p (stripExtension ext p)} getDefaults :: IO Defaults getDefaults = do - dOrigin <- fromJust . parseURI . unpack <$> Git.config "remote.origin.url" + dOrigin <- Git.config "remote.origin.url" dAuthor <- Git.config "user.name" dMaintainer <- Git.config "user.email" dPath <- getCurrentDirectory timezone <- getCurrentTimeZone (dYear, _day) <- toOrdinalDate . localDay . utcToLocalTime timezone <$> getCurrentTime pure Defaults {..} + +-- TODO move to a validators module +isValidPackageName :: Text -> Bool +isValidPackageName = (=~ ("^[[:digit:]]*[[:alpha:]][[:alnum:]]*(-[[:digit:]]*[[:alpha:]][[:alnum:]]*)*$" :: String)) diff --git a/lib/initialise/File.hs b/lib/initialise/File.hs --- a/lib/initialise/File.hs +++ b/lib/initialise/File.hs @@ -1,24 +1,31 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} -module File (replace, convert) where +module File + ( replace, + convert, + ) +where import Configuration (Configuration (..)) +import Control.Monad.Logger (logInfo) import Control.Monad.Reader (MonadIO (liftIO), MonadReader (ask)) -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Data.Text as T (replace) import Data.Text.IO (readFile, writeFile) -import Initialise.Types (Initialise) +import Initialiser.Types (Initialiser) import Prelude hiding (readFile, writeFile) -replace :: FilePath -> Initialise () -replace path = do +replace :: FilePath -> Initialiser () +replace p = do + $logInfo ("replacing file " <> pack (show p)) -- TODO replaceWith convert - contents <- liftIO $ readFile path + contents <- liftIO $ readFile p contents' <- convert contents - liftIO $ writeFile path contents' + liftIO $ writeFile p contents' -convert :: Text -> Initialise Text +convert :: Text -> Initialiser Text convert contents = do Configuration {..} <- ask pure diff --git a/lib/initialise/Git.hs b/lib/initialise/Git.hs --- a/lib/initialise/Git.hs +++ b/lib/initialise/Git.hs @@ -1,10 +1,23 @@ -module Git (config, root) where +module Git + ( config, + root, + ) +where +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Text (Text, pack, unpack) import System.Process (readProcess) config :: Text -> IO Text -config key = pack . head . lines <$> readProcess "git" ["config", unpack key] "" +config key = do + output <- nonEmpty . lines <$> readProcess "git" ["config", unpack key] [] + case output of + Just (x :| _) -> pure $ pack x + Nothing -> fail $ "`git config " <> unpack key <> "` returned no output" root :: IO Text -root = pack . head . lines <$> readProcess "git" ["rev-parse", "--show-toplevel"] "" +root = do + output <- nonEmpty . lines <$> readProcess "git" ["rev-parse", "--show-toplevel"] "" + case output of + Just (x :| _) -> pure $ pack x + Nothing -> fail "`git rev-parse --show-toplevel` returned no output" diff --git a/lib/initialise/Initialise.hs b/lib/initialise/Initialise.hs deleted file mode 100644 --- a/lib/initialise/Initialise.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Initialise (Initialise, runInitialise, defaultInitialiser) where - -import Initialise.Initialisers -import Initialise.Types diff --git a/lib/initialise/Initialise/Initialisers.hs b/lib/initialise/Initialise/Initialisers.hs deleted file mode 100644 --- a/lib/initialise/Initialise/Initialisers.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Initialise.Initialisers - ( defaultInitialiser, - ) -where - -import qualified Cabal (replace) -import qualified File (replace) -import Initialise.Types -import qualified Licence (replace) -import System.FilePath (()) - -defaultInitialiser :: Initialise () -defaultInitialiser = do - mapM_ - File.replace - [ ".devcontainer" "devcontainer.json", - ".github" "workflows" "haskell-ci.yml", - "CHANGELOG.md" - ] - Licence.replace "LICENSE" - Cabal.replace "templatise.cabal" - --- TODO README diff --git a/lib/initialise/Initialise/Types.hs b/lib/initialise/Initialise/Types.hs deleted file mode 100644 --- a/lib/initialise/Initialise/Types.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Initialise.Types - ( Initialise, - runInitialise, - ) -where - -import Configuration (Configuration) -import Control.Monad.Reader (ReaderT, runReaderT) - -type Initialise = ReaderT Configuration IO - -runInitialise :: Initialise a -> Configuration -> IO a -runInitialise = runReaderT diff --git a/lib/initialise/Initialiser.hs b/lib/initialise/Initialiser.hs new file mode 100644 --- /dev/null +++ b/lib/initialise/Initialiser.hs @@ -0,0 +1,9 @@ +module Initialiser + ( Initialiser, + runInitialiser, + defaultInitialiser, + ) +where + +import Initialiser.Initialisers +import Initialiser.Types diff --git a/lib/initialise/Initialiser/Initialisers.hs b/lib/initialise/Initialiser/Initialisers.hs new file mode 100644 --- /dev/null +++ b/lib/initialise/Initialiser/Initialisers.hs @@ -0,0 +1,23 @@ +module Initialiser.Initialisers + ( defaultInitialiser, + ) +where + +import qualified Cabal (replace) +import qualified File (replace) +import Initialiser.Types (Initialiser) +import qualified Licence (replace) +import System.FilePath (()) + +defaultInitialiser :: Initialiser () +defaultInitialiser = do + mapM_ + File.replace + [ ".devcontainer" "devcontainer.json", + ".github" "workflows" "haskell-ci.yml", + "CHANGELOG.md" + ] + Licence.replace "LICENSE" + Cabal.replace "templatise.cabal" + +-- TODO README diff --git a/lib/initialise/Initialiser/Types.hs b/lib/initialise/Initialiser/Types.hs new file mode 100644 --- /dev/null +++ b/lib/initialise/Initialiser/Types.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Initialiser.Types + ( Initialiser, + runInitialiser, + ) +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) + +newtype Initialiser a = Initialiser + { run :: LoggingT (ReaderT Configuration IO) a + } + deriving (Applicative, Functor, Monad, MonadIO, MonadLogger, MonadReader Configuration, MonadThrow) + +runInitialiser :: Initialiser a -> Configuration -> 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 @@ -1,22 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} -module Licence (replace) where +module Licence + ( replace, + ) +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 Initialise.Types (Initialise) +import Initialiser.Types (Initialiser) import Network.HTTP.Client (responseBody) import Network.HTTP.Simple (httpLBS, parseRequest) import System.FilePath (()) import Prelude hiding (writeFile) -replace :: FilePath -> Initialise () +replace :: FilePath -> Initialiser () replace p = do Configuration {..} <- ask - unless (licence == Unlicense) $ + unless (licence == Unlicense) $ do + $logInfo ("replacing LICENSE " <> pack (show p)) liftIO (writeFile (path p) =<< contents licence) contents :: LicenseId -> IO ByteString 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.2.0 +version: 0.1.3.0 license: Unlicense license-file: LICENSE copyright: (c) 2023 Alex Brandt @@ -17,18 +17,7 @@ have Haskell, VS Code devcontainers, and various GitHub actions ready to use. category: VSCode -tested-with: - GHC ==9.2.4 - || ==9.2.8 - || ==9.4.5 - || ==9.4.6 - || ==9.4.7 - || ==9.4.8 - || ==9.6.2 - || ==9.6.3 - || ==9.6.4 - || ==9.8.1 - +tested-with: GHC >=9.4 && <9.5 || >=9.6 && <9.7 || >=9.8 && <9.9 extra-source-files: .devcontainer/devcontainer.json .github/workflows/*.yml @@ -49,14 +38,16 @@ build-depends: , base >=4.16.3.0 && <4.20 , bytestring ^>=0.11.3.1 || ^>=0.12.0.2 - , Cabal-syntax ^>=3.8.1.0 || ^>=3.10.1.0 + , Cabal-syntax ^>=3.8.1.0 || ^>=3.10.1.0 || ^>=3.12.0.0 , filepath >=1.4.2.2 && <1.6 + , monad-logger ^>=0.3.40 , mtl ^>=2.2.2 || ^>=2.3.1 , network-uri ^>=2.6.4.1 || ^>=2.7.0.0 , optparse-applicative ^>=0.18.1.0 , process ^>=1.6.13.2 - , text ^>=1.2.5.0 || ^>=2.0.2 || ^>=2.1 - , time ^>=1.11.1.1 || ^>=1.12.2 || ^>=1.13 + , regex-tdfa ^>=1.3.2.2 + , text ^>=1.2.5.0 || ^>=2.0.1 || ^>=2.1 + , time ^>=1.11.1.1 || ^>=1.12.2 || ^>=1.13 || ^>=1.14 library initialise-library import: initialise-common @@ -66,13 +57,13 @@ Defaults File Git - Initialise + Initialiser Licence -- TODO Make Git private. other-modules: - Initialise.Initialisers - Initialise.Types + Initialiser.Initialisers + Initialiser.Types build-depends: , exceptions ^>=0.10.4 @@ -98,6 +89,7 @@ , 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 diff --git a/test/initialise/CabalGolden.hs b/test/initialise/CabalGolden.hs --- a/test/initialise/CabalGolden.hs +++ b/test/initialise/CabalGolden.hs @@ -4,13 +4,14 @@ import qualified Cabal as SUT import Configuration (Configuration (..)) +import Control.Monad.Logger (LogLevel (LevelDebug)) import Control.Monad.Reader (liftIO) import Data.ByteString (readFile) import Data.ByteString.Lazy.Char8 (pack) import Data.Maybe (fromJust) import Data.Text (unpack) import Distribution.SPDX.LicenseId (LicenseId (MIT)) -import Initialise (runInitialise) +import Initialiser (runInitialiser) import Network.URI (parseURI) import System.FilePath (isExtensionOf, normalise, replaceExtension, takeBaseName) import Test.Tasty (TestTree, testGroup) @@ -34,14 +35,16 @@ gold = p `replaceExtension` ".golden.cabal" action = do contents <- liftIO (readFile p) - pack . unpack <$> runInitialise (SUT.convert contents) configuration + 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 + year = 1970, + verbosity = LevelDebug } diff --git a/test/initialise/ConfigurationSpec.hs b/test/initialise/ConfigurationSpec.hs --- a/test/initialise/ConfigurationSpec.hs +++ b/test/initialise/ConfigurationSpec.hs @@ -3,9 +3,8 @@ module ConfigurationSpec (spec) where import qualified Configuration as SUT -import Data.Maybe (fromJust) +import Data.String.Utils (strip) import Defaults (Defaults (..)) -import Network.URI (parseURI) import Options.Applicative ( ParserResult ( CompletionInvoked, @@ -28,12 +27,24 @@ describe "parser" $ do it "should error if homepage isn't a URI" $ parse ["--homepage", "not-a-url"] - `shouldFailWith` ( "option --homepage: cannot parse value `not-a-url'\n\nUsage: [--name NAME] [--homepage URL] [--author AUTHOR] \n [--maintainer MAINTAINER] [--licence LICENCE]", + `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` ( "option --licence: cannot parse value `not-a-licence'\n\nUsage: [--name NAME] [--homepage URL] [--author AUTHOR] \n [--maintainer MAINTAINER] [--licence LICENCE]", + `shouldFailWith` ( strip $ + unlines + ( [ "option --licence: cannot parse value `not-a-licence'", + "" + ] + <> usage + ), ExitFailure 1 ) @@ -52,9 +63,17 @@ defaults :: Defaults defaults = Defaults - { dOrigin = fromJust (parseURI "http://github.com/username/repository.git"), + { 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/DefaultsSpec.hs b/test/initialise/DefaultsSpec.hs --- a/test/initialise/DefaultsSpec.hs +++ b/test/initialise/DefaultsSpec.hs @@ -2,7 +2,6 @@ module DefaultsSpec (spec) where -import Data.Maybe (fromJust) import Data.Time (LocalTime (localDay), getCurrentTime, getCurrentTimeZone, utcToLocalTime) import Data.Time.Calendar.OrdinalDate (toOrdinalDate) import qualified Defaults as SUT @@ -13,11 +12,19 @@ spec :: Spec spec = describe "Defaults" $ do describe "dName" $ do - it "converts origin to project name" $ - SUT.dName defaults `shouldBe` "repository" + it "converts httpOrigin to project name" $ + SUT.dName httpOrigin `shouldBe` Just "repository" + it "converts sshOrigin to project name" $ + SUT.dName sshOrigin `shouldBe` Just "repository" + it "converts twoExtensionsOrigin to project name" $ + SUT.dName twoExtensionsOrigin `shouldBe` Just "repository.two" describe "dHomePage" $ do - it "converts origin to a home page" $ - SUT.dHomePage defaults `shouldBe` fromJust (parseURI "http://github.com/username/repository") + it "converts httpOrigin to a home page" $ + SUT.dHomePage httpOrigin `shouldBe` parseURI "http://github.com/username/repository" + it "converts sshOrigin to a home page" $ + SUT.dHomePage sshOrigin `shouldBe` parseURI "http://github.com/username/repository" + it "converts twoExtensionsOrigin to a home page" $ + SUT.dHomePage twoExtensionsOrigin `shouldBe` parseURI "http://github.com/username/repository.two" describe "getDefaults" $ around withGitRepo $ do it "inspects the current repository" $ \p -> do ds <- SUT.getDefaults @@ -26,17 +33,42 @@ (dYear, _day) <- toOrdinalDate . localDay . utcToLocalTime timezone <$> getCurrentTime ds `shouldBe` SUT.Defaults - { SUT.dOrigin = fromJust (parseURI "https://github.com/sentinel/sentinel.git"), + { SUT.dOrigin = "https://github.com/sentinel/sentinel.git", SUT.dAuthor = "Sentinel", SUT.dMaintainer = "sentinel@example.com", SUT.dPath = p, SUT.dYear = dYear } + describe "isValidPackageName" $ do + it "accepts a valid package name" $ + SUT.isValidPackageName "sentinel" `shouldBe` True + it "rejects an invalid package name" $ + SUT.isValidPackageName "sentinel.ext" `shouldBe` False -defaults :: SUT.Defaults -defaults = +httpOrigin :: SUT.Defaults +httpOrigin = SUT.Defaults - { SUT.dOrigin = fromJust (parseURI "http://github.com/username/repository.git"), + { SUT.dOrigin = "http://github.com/username/repository.git", + SUT.dAuthor = "Forename Surname", + SUT.dMaintainer = "username@example.com", + SUT.dPath = ".", + SUT.dYear = 1970 + } + +sshOrigin :: SUT.Defaults +sshOrigin = + SUT.Defaults + { SUT.dOrigin = "git@github.com:username/repository.git", + SUT.dAuthor = "Forename Surname", + SUT.dMaintainer = "username@example.com", + SUT.dPath = ".", + SUT.dYear = 1970 + } + +twoExtensionsOrigin :: SUT.Defaults +twoExtensionsOrigin = + SUT.Defaults + { SUT.dOrigin = "http://github.com/username/repository.two.git", SUT.dAuthor = "Forename Surname", SUT.dMaintainer = "username@example.com", SUT.dPath = ".", diff --git a/test/initialise/FileGolden.hs b/test/initialise/FileGolden.hs --- a/test/initialise/FileGolden.hs +++ b/test/initialise/FileGolden.hs @@ -3,6 +3,7 @@ module FileGolden (golden) where import Configuration (Configuration (..)) +import Control.Monad.Logger (LogLevel (LevelDebug)) import Control.Monad.Reader (liftIO) import Data.Maybe (fromJust) import Data.Text.IO (readFile) @@ -10,7 +11,7 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Distribution.SPDX.LicenseId (LicenseId (MIT)) import qualified File as SUT -import Initialise (runInitialise) +import Initialiser (runInitialiser) import Network.URI (parseURI) import System.FilePath (isExtensionOf, normalise, replaceExtension, takeBaseName, takeExtension) import Test.Tasty (TestTree, testGroup) @@ -43,14 +44,16 @@ gold = p `replaceExtension` ".golden" ++ takeExtension p action = do contents <- liftIO (readFile p) - encodeUtf8 . fromStrict <$> runInitialise (SUT.convert contents) configuration + 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 + year = 1970, + verbosity = LevelDebug } diff --git a/test/initialise/InitialiseSpec.hs b/test/initialise/InitialiseSpec.hs --- a/test/initialise/InitialiseSpec.hs +++ b/test/initialise/InitialiseSpec.hs @@ -3,11 +3,12 @@ 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 Hooks (withProjectCopy) -import qualified Initialise as SUT +import qualified Initialiser as SUT import Network.URI (parseURI) import System.Directory (doesFileExist) import System.FilePath (()) @@ -21,15 +22,17 @@ 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 + year = 1970, + verbosity = LevelDebug } - SUT.runInitialise SUT.defaultInitialiser configuration + SUT.runInitialiser SUT.defaultInitialiser configuration doesFileExist (p "templatise.cabal") `shouldReturn` False doesFileExist (p "sentinel.cabal") `shouldReturn` True