diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,121 @@ +# `queue-sheet-haskell` Changelog + +This project follows the [Haskell package versioning policy][PVP], with +versions in `A.B.C.D` format. `A` may be incremented arbitrarily for +non-technical reasons, but [semantic versioning][SemVer] is otherwise +followed, where `A.B` is the major version, `C` is the minor version, and `D` +is the patch version. Initial development uses versions `0.0.0.D`, for which +every version is considered breaking. + +[PVP]: +[SemVer]: + +The format of this changelog is based on [Keep a Changelog][KaC], with the +following conventions: + +* Level-two heading `Unreleased` is used to track changes that have not been + released. +* Other level-two headings specify the release in `A.B.C.D (YYYY-MM-DD)` + format, with newer versions above older versions. +* Level-three headings are used to categorize changes as follows: + 1. Breaking + 2. Non-Breaking +* Changes are listed in arbitrary order and present tense. + +[KaC]: + +## 0.7.0.2 (2022-03-02) + +### Non-Breaking + +* Bump `text` dependency version upper bound +* Bump `optparse-applicative` dependency version upper bound + +## 0.7.0.1 (2021-10-10) + +### Non-Breaking + +* Add dependency bounds + +## 0.7.0.0 (2021-06-25) + +### Breaking + +* Fix `--help` when using `optparse-applicative` `0.16` + +### Non-Breaking + +* Use TTC 1.1.0.1 +* Refactor Nix configuration + +## 0.6.0.0 (2021-05-27) + +### Breaking + +* Add support for `optparse-applicative` `0.16` + +### Non-Breaking + +* Add `.deb` and `.rpm` packaging +* Add Cabal support to `Makefile` +* Add Cabal tests to GitHub Actions +* Add [stan](https://hackage.haskell.org/package/stan) static analysis + +## 0.5.0.1 (2020-11-23) + +### Non-Breaking + +* Use GitHub Actions instead of Travis CI + +## 0.5.0.0 (2020-11-08) + +### Breaking + +* Add simplified CSV support for tags and items + +### Non-Breaking + +* Rename Git default branch to `main` + +## 0.4.0.0 (2020-09-12) + +### Breaking + +* Add item support for tags + +## 0.3.0.0 (2020-08-23) + +### Breaking + +* Add default section support +* Add top-level queues array support +* Add import support +* Add user-defined tag support +* Remove split property +* Change templates to use snake-case properties + +## 0.2.0.0 (2020-08-11) + +### Breaking + +* Add URL support + +## 0.1.0.0 (2020-07-25) + +### Breaking + +* Configure sections and queues in a single YAML file + +### Non-Breaking + +* Add a template option +* Add an output option +* Refactor `Makefile`, add `STACK_NIX_PATH` support +* Add `test-all` command to `Makefile` +* Add Nix configuration + +## 0.0.1.0 (2020-01-22) + +### Breaking + +* Initial public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2020-2022 Travis Cardwell + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,117 @@ +# Queue Sheet + +[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) +[![GitHub CI](https://github.com/ExtremaIS/queue-sheet-haskell/workflows/CI/badge.svg?branch=main)](https://github.com/ExtremaIS/queue-sheet-haskell/actions) +[![Hackage](https://img.shields.io/hackage/v/queue-sheet.svg)](https://hackage.haskell.org/package/queue-sheet) +[![Stackage LTS](https://stackage.org/package/queue-sheet/badge/lts)](https://stackage.org/package/queue-sheet) +[![Stackage Nightly](https://stackage.org/package/queue-sheet/badge/nightly)](https://stackage.org/nightly/package/queue-sheet) + +* [Overview](#overview) +* [CLI](#cli) + * [Requirements](#requirements) + * [Installation](#installation) + * [`.deb` Package Installation](#deb-package-installation) + * [`.rpm` Package Installation](#rpm-package-installation) + * [Installation From Hackage](#installation-from-hackage) + * [Installation From Stackage](#installation-from-stackage) + * [Usage](#usage) +* [Project](#project) + * [Links](#links) + * [Tags](#tags) + * [Contribution](#contribution) + * [License](#license) + +## Overview + +Queue Sheet is a utility that builds PDFs of lists. Printed PDFs can be used +to track progress when offline. + +Use Queue Sheet to track: + +* podcasts +* research papers +* conference videos +* university lectures + +## CLI + +### Requirements + +Queue Sheet has only been tested on Linux. It *might* work on Windows and +macOS. + +Queue Sheet uses [XeTeX](https://tug.org/xetex/) to build PDFs. It is usually +installed as part of [TeX Live](https://www.tug.org/texlive/). The LaTeX +packages used depend entirely on the contents of the template. + +### Installation + +#### `.deb` Package Installation + +Check the [Releases][] page for `.deb` packages. + +[Releases]: + +#### `.rpm` Package Installation + +Check the [Releases][] page for `.rpm` packages. + +#### Installation From Hackage + +Install Queue Sheet from [Hackage][] using [Cabal][] as follows: + +``` +$ cabal v2-install queue-sheet +``` + +[Hackage]: +[Cabal]: + +#### Installation From Stackage + +Install Queue Sheet from [Stackage][] using [Stack][] as follows: + +``` +$ stack install queue-sheet +``` + +[Stackage]: +[Stack]: + +### Usage + +See the [`queue-sheet` man page](doc/queue-sheet.1.md) for usage information. + +See the [examples](examples) directory for example queue files, templates, and +built output. + +## Project + +Queue Sheet was written quickly to solve a particular pain point. There are +no plans to put the package on Hackage. + +### Links + +* Hackage: +* Stackage: +* GitHub: +* GitHub Actions CI: + +### Tags + +All releases are tagged in the `main` branch. Release tags are signed using +the +[`security@extrema.is` GPG key](http://keys.gnupg.net/pks/lookup?op=vindex&fingerprint=on&search=0x1D484E4B4705FADF). + +### Contribution + +Issues and feature requests are tracked on GitHub: + + +Issues may also be submitted via email to . + +### License + +This project is released under the +[MIT License](https://opensource.org/licenses/MIT) as specified in the +[`LICENSE`](LICENSE) file. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/LibOA.hs b/app/LibOA.hs new file mode 100644 --- /dev/null +++ b/app/LibOA.hs @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- | +-- Module : LibOA +-- Description : supplementary functions for optparse-applicative +-- Copyright : Copyright (c) 2019-2022 Travis Cardwell +-- License : MIT +-- +-- This is a collection of functions that I often use with +-- @optparse-applicative@. I do not feel that it is worth maintaining yet +-- another helper package on Hackage, so I just copy the code to different +-- projects as required. If the library grows to a substantial size or others +-- with to use it, I will reconsider. +-- +-- Revision: 2022-01-02 +------------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module LibOA + ( -- * Options + -- $Options + helper + , versioner + -- * Utilities + , commands + -- * Help + , (<||>) + , section + , table + , table_ + , vspace + ) where + +-- https://hackage.haskell.org/package/ansi-wl-pprint +import qualified Text.PrettyPrint.ANSI.Leijen as Doc +import Text.PrettyPrint.ANSI.Leijen (Doc) + +-- https://hackage.haskell.org/package/base +import Data.List (intersperse, transpose) +import Data.Maybe (fromMaybe) +#if !MIN_VERSION_base (4,11,0) +import Data.Monoid ((<>)) +#endif + +-- https://hackage.haskell.org/package/optparse-applicative +import qualified Options.Applicative as OA +#if MIN_VERSION_optparse_applicative (0,16,0) +import qualified Options.Applicative.Builder.Internal as OABI +#endif +import qualified Options.Applicative.Common as OAC +import qualified Options.Applicative.Types as OAT + +------------------------------------------------------------------------------ +-- $Options +-- +-- Option descriptions are not capitalized. + +-- | A hidden @-h@ / @--help@ option that always fails, showing the help +-- +-- This is the same as 'OA.helper' except that it has a different help +-- message. +helper :: OA.Parser (a -> a) +#if MIN_VERSION_optparse_applicative (0,16,0) +helper = OA.option helpReader $ mconcat + [ OA.short 'h' + , OA.long "help" + , OA.value id + , OA.metavar "" + , OABI.noGlobal + , OA.noArgError (OA.ShowHelpText Nothing) + , OA.help "show this help text" + , OA.hidden + ] + where + helpReader = do + potentialCommand <- OAT.readerAsk + OA.readerAbort $ OA.ShowHelpText (Just potentialCommand) +#else +helper = OA.abortOption OA.ShowHelpText $ mconcat + [ OA.short 'h' + , OA.long "help" + , OA.help "show help and exit" + , OA.hidden + ] +#endif + +-- | A hidden @--version@ option that always fails, showing the version +versioner + :: String -- ^ version string + -> OA.Parser (a -> a) +versioner verStr = OA.infoOption verStr $ mconcat + [ OA.long "version" + , OA.help "show version and exit" + , OA.hidden + ] + +------------------------------------------------------------------------------ +-- $Utilities + +-- | Get a list of commands for a parser +commands :: OA.Parser a -> [String] +commands = + let go _ opt = case OAT.optMain opt of + OAT.CmdReader _ cmds _ -> reverse cmds + _otherReader -> [] + in concat . OAC.mapParser go + +------------------------------------------------------------------------------ +-- $Help + +-- | Insert a blank line between two documents +(<||>) :: Doc -> Doc -> Doc +d1 <||> d2 = d1 <> Doc.line <> Doc.line <> d2 +infixr 5 <||> + +-- | Create a section with a title and indented body +section :: String -> Doc -> Doc +section title = (Doc.text title Doc.<$$>) . Doc.indent 2 + +-- | Create a table, with formatting +table :: Int -> [[(String, Doc -> Doc)]] -> Doc +table sep rows = Doc.vcat $ + map (fromMaybe Doc.empty . foldr go Nothing . zip lengths) rows + where + lengths :: [Int] + lengths = map ((+) sep . maximum . map (length . fst)) $ transpose rows + + go :: (Int, (String, Doc -> Doc)) -> Maybe Doc -> Maybe Doc + go (len, (s, f)) = Just . \case + Just doc -> Doc.fill len (f $ Doc.string s) <> doc + Nothing -> f $ Doc.string s + +-- | Create a table, without formatting +table_ :: Int -> [[String]] -> Doc +table_ sep = table sep . (map . map) (, id) + +-- | Vertically space documents with blank lines between them +vspace :: [Doc] -> Doc +vspace = mconcat . intersperse (Doc.line <> Doc.line) diff --git a/app/queue-sheet.hs b/app/queue-sheet.hs new file mode 100644 --- /dev/null +++ b/app/queue-sheet.hs @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : queue-sheet program +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +-- https://hackage.haskell.org/package/base +import Control.Applicative (optional) +import System.Exit (exitFailure) + +-- https://hackage.haskell.org/package/optparse-applicative +import qualified Options.Applicative as OA + +-- (queue-sheet) +import QueueSheet (version) +import QueueSheet.Build (buildPdf) + +-- (queue-sheet:executable) +import qualified LibOA + +------------------------------------------------------------------------------ +-- $Constants + +-- | Default template file +defaultTemplate :: FilePath +defaultTemplate = "template.tex" + +------------------------------------------------------------------------------ +-- $Library + +-- | Display an error and exit the program +errorExit :: String -> IO a +errorExit msg = do + putStrLn $ "error: " ++ msg + exitFailure + +------------------------------------------------------------------------------ +-- $Options + +-- | Program options +data Options + = Options + { optTemplate :: !FilePath + , optOutput :: !(Maybe FilePath) + , optQueues :: !FilePath + } + deriving Show + +-- | Parse program options +parseOptions :: IO Options +parseOptions = OA.execParser + $ OA.info (LibOA.helper <*> LibOA.versioner version <*> options) + $ mconcat + [ OA.fullDesc + , OA.progDesc "queue sheet utility" + , OA.failureCode 2 + ] + where + options :: OA.Parser Options + options = Options + <$> templateOption + <*> optional outputOption + <*> queuesArgument + + templateOption :: OA.Parser FilePath + templateOption = OA.strOption $ mconcat + [ OA.long "template" + , OA.short 't' + , OA.metavar "TEMPLATE.tex" + , OA.value defaultTemplate + , OA.showDefaultWith id + , OA.help "template file" + ] + + outputOption :: OA.Parser FilePath + outputOption = OA.strOption $ mconcat + [ OA.long "output" + , OA.short 'o' + , OA.metavar "QUEUES.pdf" + , OA.help "output file" + ] + + queuesArgument :: OA.Parser FilePath + queuesArgument = OA.strArgument $ mconcat + [ OA.metavar "QUEUES.yaml" + , OA.help "YAML file specifying queue information" + ] + +------------------------------------------------------------------------------ +-- $main + +main :: IO () +main = do + Options{..} <- parseOptions + either errorExit return =<< buildPdf optQueues optTemplate optOutput diff --git a/queue-sheet.cabal b/queue-sheet.cabal new file mode 100644 --- /dev/null +++ b/queue-sheet.cabal @@ -0,0 +1,97 @@ +name: queue-sheet +version: 0.7.0.2 +category: Utils +synopsis: queue sheet utility +description: + This package provides a utility for creating queue sheets. Please see the + README on GitHub at + . + +homepage: https://github.com/ExtremaIS/queue-sheet-haskell#readme +bug-reports: https://github.com/ExtremaIS/queue-sheet-haskell/issues +author: Travis Cardwell +maintainer: Travis Cardwell +copyright: Copyright (c) 2020-2022 Travis Cardwell +license: MIT +license-file: LICENSE + +cabal-version: 1.24 +build-type: Simple +tested-with: + GHC ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.1 + +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/ExtremaIS/queue-sheet-haskell.git + +flag write-hie + description: write .hie files + default: False + +library + hs-source-dirs: src + exposed-modules: + QueueSheet + , QueueSheet.Build + , QueueSheet.File + , QueueSheet.Template + , QueueSheet.Types + other-modules: + Paths_queue_sheet + build-depends: + aeson >= 1.2 && <2.1 + , base >=4.7 && <5 + , bytestring >=0.10.8 && <0.12 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.5 + , ginger >=0.7.3 && <0.11 + , process >=1.6 && <1.7 + , scientific >=0.3 && <0.4 + , text >=1.2.3 && <2.1 + , transformers >=0.5.2 && <0.6 + , ttc >=1.1 && <1.2 + , vector >=0.12 && <0.13 + , yaml >=0.8 && <0.12 + default-language: Haskell2010 + if flag(write-hie) + ghc-options: -Wall -fwrite-ide-info -hiedir=.hie + else + ghc-options: -Wall + +executable queue-sheet + hs-source-dirs: app + main-is: queue-sheet.hs + other-modules: + LibOA + build-depends: + ansi-wl-pprint >=0.6 && <0.7 + , base + , optparse-applicative >=0.14 && <0.18 + , queue-sheet + default-language: Haskell2010 + ghc-options: -Wall + +test-suite queue-sheet-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + QueueSheet.File.Test + build-depends: + base + , bytestring + , queue-sheet + , tasty >=1.0 && <1.5 + , tasty-hunit >=0.10 && <0.11 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/QueueSheet.hs b/src/QueueSheet.hs new file mode 100644 --- /dev/null +++ b/src/QueueSheet.hs @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------ +-- | +-- Module : QueueSheet +-- Description : queue sheet metadata +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +module QueueSheet + ( -- * Constants + version + ) where + +-- https://hackage.haskell.org/package/base +import Data.Version (showVersion) + +-- (queue-sheet:cabal) +import qualified Paths_queue_sheet as Project + +------------------------------------------------------------------------------ +-- $Constants + +-- | QueueSheet version string (\"@queue-sheet-haskell X.X.X.X@\") +-- +-- @since 0.3.0.0 +version :: String +version = "queue-sheet-haskell " ++ showVersion Project.version diff --git a/src/QueueSheet/Build.hs b/src/QueueSheet/Build.hs new file mode 100644 --- /dev/null +++ b/src/QueueSheet/Build.hs @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- | +-- Module : QueueSheet.Build +-- Description : queue sheet build functions +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +module QueueSheet.Build + ( -- * API + buildPdf + ) where + +-- https://hackage.haskell.org/package/base +import Control.Exception (displayException) +import Control.Monad (when) +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) +import System.IO.Error (tryIOError) + +-- https://hackage.haskell.org/package/directory +import System.Directory + ( createDirectory, doesPathExist, removeDirectoryRecursive, renameFile + , withCurrentDirectory + ) + +-- https://hackage.haskell.org/package/filepath +import System.FilePath ((), replaceExtension, takeFileName) + +-- https://hackage.haskell.org/package/process +import qualified System.Process as Proc + +-- https://hackage.haskell.org/package/transformers +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE) + +-- (queue-sheet) +import QueueSheet.File (loadYaml) +import QueueSheet.Template (loadTemplate, renderTemplate) + +------------------------------------------------------------------------------ +-- $Constants + +-- | Build directory name +-- +-- @since 0.3.0.0 +buildDir :: FilePath +buildDir = "queue-sheet-build" + +------------------------------------------------------------------------------ +-- $API + +-- | Build a PDF +-- +-- @since 0.3.0.0 +buildPdf + :: FilePath -- ^ queues path + -> FilePath -- ^ template path + -> Maybe FilePath -- ^ output path (default: queues path w/ .pdf extension) + -> IO (Either String ()) +buildPdf queuesPath templatePath mOutputPath = runExceptT $ do + queueSheet <- ExceptT $ loadYaml queuesPath + template <- ExceptT $ loadTemplate templatePath + exists <- lift $ doesPathExist buildDir + when exists . throwE $ "directory already exists: " ++ buildDir + let outputPath = fromMaybe (replaceExtension queuesPath "pdf") mOutputPath + sourcePath = takeFileName $ replaceExtension outputPath "tex" + ExceptT . fmap (first displayException) . tryIOError $ do + createDirectory buildDir + withCurrentDirectory buildDir $ do + renderTemplate sourcePath template queueSheet + Proc.callProcess "xelatex" ["-halt-on-error", sourcePath] + renameFile (buildDir takeFileName outputPath) outputPath + removeDirectoryRecursive buildDir diff --git a/src/QueueSheet/File.hs b/src/QueueSheet/File.hs new file mode 100644 --- /dev/null +++ b/src/QueueSheet/File.hs @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- | +-- Module : QueueSheet.File +-- Description : queue sheet file loading +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module QueueSheet.File + ( -- * YAML + loadYaml + , loadYaml' + ) where + +-- https://hackage.haskell.org/package/base +import Control.Exception (displayException) +import Control.Monad (forM, forM_, unless, when) +import Data.Bifunctor (first) +import System.IO.Error (tryIOError) + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) + +-- https://hackage.haskell.org/package/directory +import System.Directory (makeAbsolute) + +-- https://hackage.haskell.org/package/filepath +import System.FilePath ((), isAbsolute, normalise, takeDirectory) + +-- https://hackage.haskell.org/package/transformers +import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE) + +-- https://hackage.haskell.org/package/ttc +import qualified Data.TTC as TTC + +-- https://hackage.haskell.org/package/yaml +import qualified Data.Yaml as Yaml + +-- (queue-sheet) +import QueueSheet.Types + ( Import(Import, importPath, importSection) + , ImportOrQueue(IQImport, IQQueue) + , Queue(Queue, queueName, queueSection) + , QueuesFile(QueuesFile, qfSections, qfImportOrQueues) + , QueueSheet(QueueSheet, qsSections, qsQueues) + ) + +------------------------------------------------------------------------------ +-- $Yaml + +-- | Load a queues YAML file, resolving imports +-- +-- @since 0.3.0.0 +loadYaml + :: FilePath + -> IO (Either String QueueSheet) +loadYaml path = runExceptT $ do + let tryIOError' = fmap (first displayException) . tryIOError + absPath <- ExceptT . tryIOError' $ makeAbsolute path + ExceptT $ loadYaml' (tryIOError' . BS.readFile) absPath + +-- | Load a queues YAML file using the given file loader, resolving imports +-- +-- This function defines the logic for 'loadYaml' using an arbitrary monad. +-- It is exposed for testing purposes. +-- +-- @since 0.3.0.0 +loadYaml' + :: forall m. Monad m + => (FilePath -> m (Either String ByteString)) -- ^ file loader + -> FilePath -- ^ absolute path + -> m (Either String QueueSheet) +loadYaml' loadFile = runExceptT . go [] + where + go :: [FilePath] -> FilePath -> ExceptT String m QueueSheet + go seenPaths path = do + let error' = throwE . (("error loading " ++ path ++ ": ") ++) + yamlError = error' . Yaml.prettyPrintParseException + content <- ExceptT $ loadFile path + QueuesFile{..} <- either yamlError pure $ Yaml.decodeEither' content + queues <- fmap concat . forM qfImportOrQueues $ \case + IQImport Import{..} -> do + let seenPaths' = path : seenPaths + importAbsPath + | isAbsolute importPath = importPath + | otherwise = normalise $ takeDirectory path importPath + when (importAbsPath `elem` seenPaths') . error' $ + "cyclic import: " ++ importAbsPath + queueSheet <- go seenPaths' importAbsPath + let queues' = qsQueues queueSheet + case importSection of + Just section -> do + unless (section `elem` qfSections) . error' . unwords $ + [ "import", importPath + , "has unknown section", TTC.render section + ] + return [queue{ queueSection = section } | queue <- queues'] + Nothing -> do + forM_ queues' $ \Queue{..} -> + unless (queueSection `elem` qfSections) . error' . unwords $ + [ "queue", TTC.render queueName + , "imported from", importPath + , "has unknown section", TTC.render queueSection + ] + return queues' + IQQueue queue@Queue{..} -> do + unless (queueSection `elem` qfSections) . error' . unwords $ + [ "queue", TTC.render queueName + , "has unknown section", TTC.render queueSection + ] + return [queue] + return $ QueueSheet + { qsSections = qfSections + , qsQueues = queues + } diff --git a/src/QueueSheet/Template.hs b/src/QueueSheet/Template.hs new file mode 100644 --- /dev/null +++ b/src/QueueSheet/Template.hs @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- | +-- Module : QueueSheet.Template +-- Description : queue sheet template functions +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module QueueSheet.Template + ( -- * API + loadTemplate + , renderTemplate + ) where + +-- https://hackage.haskell.org/package/base +import Data.Bifunctor (first) +#if !MIN_VERSION_base (4,11,0) +import Data.Monoid ((<>)) +#endif +import qualified System.IO as IO + +-- https://hackage.haskell.org/package/ginger +import qualified Text.Ginger as Ginger +import Text.Ginger ((~>)) + +-- https://hackage.haskell.org/package/text +import Data.Text (Text) +import qualified Data.Text.IO as TIO + +-- https://hackage.haskell.org/package/transformers +import Control.Monad.Trans.Writer (Writer) + +-- (queue-sheet) +import QueueSheet.Types + ( Date, Item, Name + , Queue + ( Queue, queueDate, queueItems, queueName, queueSection, queueTags + , queueUrl + ) + , QueueSheet(QueueSheet, qsQueues, qsSections), Section, Tag(Tag), Url + ) + +------------------------------------------------------------------------------ +-- $QueueCtx + +-- | Queue context +data QueueCtx + = QueueCtx + { name :: !Name + , url :: !(Maybe Url) + , date :: !(Maybe Date) + , tags :: ![Tag] + , prevItem :: !(Maybe Item) + , nextItems :: ![Item] + } + +instance Ginger.ToGVal m QueueCtx where + toGVal QueueCtx{..} = Ginger.dict $ + [ "name" ~> name + , "url" ~> url + , "date" ~> date + , "prev_item" ~> prevItem + , "next_items" ~> nextItems + ] ++ [("tag_" <> tag) ~> True | Tag tag <- tags] + +-- | Construct a queue context +queueCtx :: Queue -> QueueCtx +queueCtx Queue{..} = QueueCtx + { name = queueName + , url = queueUrl + , date = queueDate + , tags = queueTags + , prevItem = either Just (const Nothing) =<< queueItems + , nextItems = maybe [] (either (const []) id) queueItems + } + +------------------------------------------------------------------------------ +-- $SectionCtx + +-- | Section context +newtype SectionCtx = SectionCtx (Section, [QueueCtx]) + +instance Ginger.ToGVal m SectionCtx where + toGVal (SectionCtx (section, queues)) = Ginger.dict + [ "name" ~> section + , "queues" ~> queues + ] + +-- | Check if a section context has any queues +sectionCtxHasQueues :: SectionCtx -> Bool +sectionCtxHasQueues (SectionCtx (_, [])) = False +sectionCtxHasQueues _ = True + +------------------------------------------------------------------------------ +-- $Context + +-- | Template context +newtype Context = Context [SectionCtx] + deriving newtype (Ginger.ToGVal m) + +-- | Template context constructor +context :: [Section] -> [Queue] -> Context +context sections queues = Context $ filter sectionCtxHasQueues + [ SectionCtx + ( section + , [ queueCtx queue + | queue <- queues, queueSection queue == section + ] + ) + | section <- sections + ] + +-- | Create a Ginger context from a template context +gingerContext + :: Context + -> Ginger.GingerContext Ginger.SourcePos (Writer Text) Text +gingerContext ctx = Ginger.makeContextText $ \case + "sections" -> Ginger.toGVal ctx + _ -> Ginger.toGVal (Nothing :: Maybe Text) + +------------------------------------------------------------------------------ +-- $API + +-- | Load a Ginger template +-- +-- @since 0.3.0.0 +loadTemplate + :: FilePath + -> IO (Either String (Ginger.Template Ginger.SourcePos)) +loadTemplate path = first formatError <$> Ginger.parseGingerFile' options path + where + options :: Ginger.ParserOptions IO + options = Ginger.ParserOptions + { poIncludeResolver = fmap Just . IO.readFile + , poSourceName = Nothing + , poKeepTrailingNewline = False + , poLStripBlocks = False + , poTrimBlocks = False + , poDelimiters = Ginger.Delimiters + { delimOpenInterpolation = "<<" + , delimCloseInterpolation = ">>" + , delimOpenTag = "" + , delimOpenComment = "<#" + , delimCloseComment = "#>" + } + } + + formatError :: Ginger.ParserError -> String + formatError err = concat + [ "error loading template: " + , maybe path show $ Ginger.peSourcePosition err + , ": " + , Ginger.peErrorMessage err + ] + +-- | Render a template using the given context +-- +-- @since 0.3.0.0 +renderTemplate + :: FilePath + -> Ginger.Template Ginger.SourcePos + -> QueueSheet + -> IO () +renderTemplate path template QueueSheet{..} = + let ctx = gingerContext $ context qsSections qsQueues + in TIO.writeFile path $ Ginger.runGinger ctx template diff --git a/src/QueueSheet/Types.hs b/src/QueueSheet/Types.hs new file mode 100644 --- /dev/null +++ b/src/QueueSheet/Types.hs @@ -0,0 +1,359 @@ +------------------------------------------------------------------------------ +-- | +-- Module : QueueSheet.Types +-- Description : queue sheet types +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module QueueSheet.Types + ( -- * Name + Name(..) + -- * Url + , Url(..) + -- * Date + , Date(..) + -- * Section + , Section(..) + , defaultSection + -- * Tag + , Tag(..) + -- * Item + , Item(..) + -- * Queue + , Queue(..) + -- * Import + , Import(..) + -- * ImportOrQueue + , ImportOrQueue(..) + -- * QueuesFile + , QueuesFile(..) + -- * QueueSheet + , QueueSheet(..) + ) where + +-- https://hackage.haskell.org/package/aeson +import qualified Data.Aeson as A +import Data.Aeson (FromJSON(parseJSON), (.:), (.:?), (.!=)) +import qualified Data.Aeson.Types as AT + +-- https://hackage.haskell.org/package/base +import Control.Applicative ((<|>)) +import Control.Monad (unless, when) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +#if !MIN_VERSION_base (4,11,0) +import Data.Monoid ((<>)) +#endif + +-- https://hackage.haskell.org/package/ginger +import qualified Text.Ginger as Ginger +import Text.Ginger ((~>)) + +-- https://hackage.haskell.org/package/scientific +import qualified Data.Scientific as Sci + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import Data.Text (Text) + +-- https://hackage.haskell.org/package/ttc +import qualified Data.TTC as TTC + +-- https://hackage.haskell.org/package/vector +import qualified Data.Vector as V + +------------------------------------------------------------------------------ +-- $Name + +-- | Name of a queue or queue item +-- +-- @since 0.3.0.0 +newtype Name = Name Text + deriving newtype (Eq, Show) + +instance FromJSON Name where + parseJSON = fmap Name . parseToString + +instance Ginger.ToGVal m Name where + toGVal (Name t) = Ginger.toGVal $ escapeTeX t + +instance TTC.Render Name where + render (Name t) = TTC.fromT t + +------------------------------------------------------------------------------ +-- $Url + +-- | URL of queue or queue item +-- +-- @since 0.3.0.0 +newtype Url = Url Text + deriving newtype (Eq, Show) + +instance FromJSON Url where + parseJSON = fmap Url . parseToString + +instance Ginger.ToGVal m Url where + toGVal (Url t) = Ginger.toGVal $ escapeTeX t + +instance TTC.Render Url where + render (Url t) = TTC.fromT t + +------------------------------------------------------------------------------ +-- $Date + +-- | Date of last queue update +-- +-- @since 0.3.0.0 +newtype Date = Date Text + deriving newtype (Eq, Show) + +instance FromJSON Date where + parseJSON = fmap Date . parseToString + +instance Ginger.ToGVal m Date where + toGVal (Date t) = Ginger.toGVal $ escapeTeX t + +instance TTC.Render Date where + render (Date t) = TTC.fromT t + +------------------------------------------------------------------------------ +-- $Section + +-- | Section used to organize queues +-- +-- @since 0.3.0.0 +newtype Section = Section Text + deriving newtype (Eq, Show) + +instance FromJSON Section where + parseJSON = fmap Section . parseToString + +instance Ginger.ToGVal m Section where + toGVal (Section t) = Ginger.toGVal $ escapeTeX t + +instance TTC.Render Section where + render (Section t) = TTC.fromT t + +-- | The default section is represented as an empty string +defaultSection :: Section +defaultSection = Section "" + +------------------------------------------------------------------------------ +-- $Tag + +-- | Queue tag +-- +-- @since 0.3.0.0 +newtype Tag = Tag Text + deriving newtype (Eq, Show) + +instance FromJSON Tag where + parseJSON = A.withText "Tag" $ \t -> do + when (T.null t) $ fail "empty tag" + unless (T.all isValidChar t) $ fail ("invalid tag: " ++ T.unpack t) + return $ Tag t + where + isValidChar :: Char -> Bool + isValidChar c + | isAsciiLower c = True + | isAsciiUpper c = True + | isDigit c = True + | otherwise = c `elem` ("._-" :: String) + +------------------------------------------------------------------------------ +-- $Item + +-- | Queue item +-- +-- @since 0.5.0.0 +data Item + = Item + { itemName :: !Name + , itemUrl :: !(Maybe Url) + , itemTags :: ![Tag] + } + deriving (Eq, Show) + +instance FromJSON Item where + parseJSON = \case + (A.Object o) -> do + itemName <- o .: "name" + itemUrl <- o .:? "url" + itemTags <- maybe (pure []) parseCSV =<< (o .:? "tags") + return Item{..} + value -> do + itemName <- Name <$> parseToString value + let itemUrl = Nothing + itemTags = [] + return Item{..} + +instance Ginger.ToGVal m Item where + toGVal Item{..} = Ginger.dict $ + [ "name" ~> itemName + , "url" ~> itemUrl + ] ++ [("tag_" <> tag) ~> True | Tag tag <- itemTags] + +------------------------------------------------------------------------------ +-- $Queue + +-- | Queue information +-- +-- @since 0.5.0.0 +data Queue + = Queue + { queueName :: !Name + , queueUrl :: !(Maybe Url) + , queueDate :: !(Maybe Date) + , queueSection :: !Section + , queueTags :: ![Tag] + , queueItems :: !(Maybe (Either Item [Item])) + } + deriving (Eq, Show) + +instance FromJSON Queue where + parseJSON = A.withObject "Queue" $ \o -> do + queueName <- o .: "name" + queueUrl <- o .:? "url" + queueDate <- o .:? "date" + queueSection <- o .:? "section" .!= defaultSection + queueTags <- maybe (pure []) parseCSV =<< (o .:? "tags") + mPrevItem <- o .:? "prev" + mNextValue <- o .:? "next" + queueItems <- case (mPrevItem, mNextValue) of + (_, Just nextValue) -> Just . Right <$> parseCSV nextValue + (Just item, Nothing) -> pure . Just $ Left item + (Nothing, Nothing) -> pure Nothing + return Queue{..} + +------------------------------------------------------------------------------ +-- $Import + +-- | Import declaration +-- +-- @since 0.3.0.0 +data Import + = Import + { importPath :: !FilePath + , importSection :: !(Maybe Section) + } + deriving (Eq, Show) + +instance FromJSON Import where + parseJSON = A.withObject "Import" $ \o -> do + importPath <- o .: "import" + importSection <- o .:? "section" + return Import{..} + +------------------------------------------------------------------------------ +-- $ImportOrQueue + +-- | Import declaration or queue information +-- +-- @since 0.3.0.0 +data ImportOrQueue + = IQImport !Import + | IQQueue !Queue + deriving (Eq, Show) + +instance FromJSON ImportOrQueue where + parseJSON value = + (IQImport <$> parseJSON value) <|> (IQQueue <$> parseJSON value) + +------------------------------------------------------------------------------ +-- $QueuesFile + +-- | Queues file +-- +-- @since 0.3.0.0 +data QueuesFile + = QueuesFile + { qfSections :: ![Section] + , qfImportOrQueues :: ![ImportOrQueue] + } + deriving (Eq, Show) + +instance FromJSON QueuesFile where + parseJSON = \case + (A.Object o) -> do + qfSections <- (:) defaultSection <$> (o .:? "sections" .!= []) + qfImportOrQueues <- o .: "queues" + return QueuesFile{..} + a@A.Array{} -> do + let qfSections = [defaultSection] + qfImportOrQueues <- parseJSON a + return QueuesFile{..} + A.String{} -> fail "unexpected string" + A.Number{} -> fail "unexpected number" + A.Bool{} -> fail "unexpected bool" + A.Null -> fail "unexpected null" + +------------------------------------------------------------------------------ +-- $QueueSheet + +-- | Queue sheet +-- +-- @since 0.3.0.0 +data QueueSheet + = QueueSheet + { qsSections :: ![Section] + , qsQueues :: ![Queue] + } + deriving (Eq, Show) + +------------------------------------------------------------------------------ +-- $Internal + +-- | Escape a string for inclusion in a TeX document +escapeTeX :: Text -> Text +escapeTeX = T.foldl go "" + where + go :: Text -> Char -> Text + go acc = \case + '#' -> acc <> "\\#" + '$' -> acc <> "\\$" + '%' -> acc <> "\\%" + '&' -> acc <> "\\&" + '\\' -> acc <> "\\textbackslash{}" + '^' -> acc <> "\\textasciicircum{}" + '_' -> acc <> "\\_" + '{' -> acc <> "\\{" + '}' -> acc <> "\\}" + '~' -> acc <> "\\textasciitilde{}" + c -> acc `T.snoc` c + +-- | Parse an array or string in simplified CSV format +-- +-- Strings are split on commas, and leading/trailing whitespace is removed +-- from each item. +parseCSV :: A.FromJSON a => A.Value -> AT.Parser [a] +parseCSV = \case + (A.String t) -> mapM (parseJSON . A.String . T.strip) $ T.splitOn "," t + (A.Array v) -> mapM parseJSON $ V.toList v + A.Object{} -> fail "unexpected object" + value -> (: []) <$> parseJSON value + +-- | Parse any scalar value as a string +-- +-- Strings, numbers, booleans, and null are parsed as a string. Empty +-- strings, arrays, and objects result in an error. +parseToString :: A.Value -> AT.Parser Text +parseToString = \case + (A.String t) + | T.null t -> fail "empty string" + | otherwise -> pure t + (A.Number n) -> pure . T.pack . either (show @Double) (show @Integer) $ + Sci.floatingOrInteger n + (A.Bool b) -> pure $ if b then "true" else "false" + A.Null -> pure "null" + A.Array{} -> fail "unexpected array" + A.Object{} -> fail "unexpected object" diff --git a/test/QueueSheet/File/Test.hs b/test/QueueSheet/File/Test.hs new file mode 100644 --- /dev/null +++ b/test/QueueSheet/File/Test.hs @@ -0,0 +1,1132 @@ +------------------------------------------------------------------------------ +-- | +-- Module : QueueSheet.File.Test +-- Description : queues file tests +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +{-# LANGUAGE OverloadedStrings #-} + +module QueueSheet.File.Test (tests) where + +-- https://hackage.haskell.org/package/base +import Control.Monad (unless) +import Data.Functor.Identity (Identity(runIdentity)) +import Data.List (intercalate) +import Data.Maybe (fromMaybe, listToMaybe) + +-- https://hackage.haskell.org/package/bytestring +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (TestTree, testGroup) + +-- https://hackage.haskell.org/package/tasty-hunit +import Test.Tasty.HUnit ((@=?), testCase) + +-- (queue-sheet) +import QueueSheet.File (loadYaml') +import QueueSheet.Types + ( Date(Date), Item(Item, itemName, itemTags, itemUrl), Name(Name) + , Queue + ( Queue, queueDate, queueItems, queueName, queueSection, queueTags + , queueUrl + ) + , QueueSheet(QueueSheet, qsQueues, qsSections) + , Section(Section), Tag(Tag), Url(Url), defaultSection + ) + +------------------------------------------------------------------------------ + +defaultItem :: Item +defaultItem = Item + { itemName = Name "" + , itemUrl = Nothing + , itemTags = [] + } + +defaultQueue :: Queue +defaultQueue = Queue + { queueName = Name "" + , queueUrl = Nothing + , queueSection = defaultSection + , queueTags = [] + , queueDate = Nothing + , queueItems = Nothing + } + +defaultQueueSheet :: QueueSheet +defaultQueueSheet = QueueSheet + { qsSections = [defaultSection] + , qsQueues = [] + } + +------------------------------------------------------------------------------ + +loadYaml + :: [(FilePath, Either String ByteString)] + -> Either String QueueSheet +loadYaml files + = runIdentity + . loadYaml' loadFile + . fromMaybe "/tmp/unknown.yaml" + . listToMaybe + . map fst + $ take 1 files + where + loadFile :: FilePath -> Identity (Either String ByteString) + loadFile path = pure . + fromMaybe (Left ("file not found: " ++ path)) $ lookup path files + +validFile + :: FilePath + -> [ByteString] + -> (FilePath, Either String ByteString) +validFile path lines' = (path, Right (BS8.unlines $ "---" : "" : lines')) + +invalidFile + :: FilePath + -> (FilePath, Either String ByteString) +invalidFile path = (path, Left ("error loading file: " ++ path)) + +------------------------------------------------------------------------------ +-- $Queue + +testQueueName :: TestTree +testQueueName = testGroup "name" + [ testCase "string" $ do + let expected = defaultQueueSheet + { qsQueues = [defaultQueue{ queueName = Name "test" }] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + ] + ] + , testCase "number" $ do + let expected = defaultQueueSheet + { qsQueues = [defaultQueue{ queueName = Name "42" }] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: 42" + ] + ] + , testCase "bool" $ do + let expected = defaultQueueSheet + { qsQueues = [defaultQueue{ queueName = Name "true" }] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: true" + ] + ] + , testCase "null" $ do + let expected = defaultQueueSheet + { qsQueues = [defaultQueue{ queueName = Name "null" }] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: null" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].name: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: \"\"" + ] + ] + , testCase "array" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].name: unexpected array" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name:" + , " - invalid" + ] + ] + , testCase "object" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].name: unexpected object" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name:" + , " invalid: true" + ] + ] + ] + +testQueueUrl :: TestTree +testQueueUrl = testGroup "url" + [ testCase "string" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueUrl = Just $ Url "https://www.example.com:8080/" + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " url: https://www.example.com:8080/" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].url: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " url: \"\"" + ] + ] + ] + +testQueueSection :: TestTree +testQueueSection = testGroup "section" + [ testCase "known" $ do + let generalSection = Section "general" + expected = QueueSheet + { qsSections = [defaultSection, generalSection] + , qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueSection = generalSection + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "sections:" + , " - general" + , "" + , "queues:" + , " - name: test" + , " section: general" + ] + ] + , testCase "multiple" $ do + let generalSection = Section "general" + expected = QueueSheet + { qsSections = [defaultSection, generalSection] + , qsQueues = + [ defaultQueue + { queueName = Name "one" + , queueSection = defaultSection + } + , defaultQueue + { queueName = Name "two" + , queueSection = generalSection + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "sections:" + , " - general" + , "" + , "queues:" + , " - name: one" + , " - name: two" + , " section: general" + ] + ] + , testCase "none" $ do + let expected = QueueSheet + { qsSections = [defaultSection] + , qsQueues = + [ defaultQueue + { queueName = Name "one" + , queueSection = defaultSection + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "sections:" + , "" + , "queues:" + , " - name: one" + ] + ] + , testCase "unknown" $ do + let message = unwords + [ "error loading /tmp/test.yaml:" + , "queue test has unknown section general" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " section: general" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].section: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " section: \"\"" + ] + ] + ] + +testQueueTag :: TestTree +testQueueTag = testGroup "tag" + [ testGroup "array" + [ testCase "valid" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueTags = [Tag "partial"] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags:" + , " - partial" + ] + ] + , testCase "multiple" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueTags = [Tag "complete", Tag "partial"] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags:" + , " - complete" + , " - partial" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: empty tag" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags:" + , " - \"\"" + ] + ] + , testCase "invalid" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: invalid tag: (invalid)" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags:" + , " - (invalid)" + ] + ] + , testCase "number" $ do + let messageOld = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: expected Tag, encountered Number" + ] + message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: parsing Tag failed, " ++ + "expected String, but encountered Number" + ] + eeq = loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags:" + , " - 13" + ] + ] + unless (Left messageOld == eeq) $ Left message @=? eeq + ] + , testGroup "csv" + [ testCase "single" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueTags = [Tag "partial"] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags: partial" + ] + ] + , testCase "multiple" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueTags = [Tag "complete", Tag "partial"] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags: complete, partial" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: empty tag" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags: \"\"" + ] + ] + , testCase "invalid" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: invalid tag: (invalid)" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags: (invalid)" + ] + ] + , testCase "number" $ do + let messageOld = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: expected Tag, encountered Number" + ] + message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: parsing Tag failed, " ++ + "expected String, but encountered Number" + ] + eeq = loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " tags: 13" + ] + ] + unless (Left messageOld == eeq) $ Left message @=? eeq + ] + ] + +testQueueDate :: TestTree +testQueueDate = testGroup "date" + [ testCase "string" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueDate = Just $ Date "2020-08-14" + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " date: 2020-08-14" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].date: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " date: \"\"" + ] + ] + ] + +testQueuePrev :: TestTree +testQueuePrev = testGroup "prev" + [ testCase "string" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just . Left $ defaultItem + { itemName = Name "premiere" + } + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev: premiere" + ] + ] + , testCase "number" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just . Left $ defaultItem + { itemName = Name "42" + } + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev: 42" + ] + ] + , testCase "object" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just . Left $ defaultItem + { itemName = Name "premiere" + } + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev:" + , " name: premiere" + ] + ] + , testCase "url" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just . Left $ defaultItem + { itemName = Name "42" + , itemUrl = Just $ Url "https://www.example.com/42" + } + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev:" + , " name: 42" + , " url: https://www.example.com/42" + ] + ] + , testGroup "tags" + [ testCase "array" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just . Left $ defaultItem + { itemName = Name "42" + , itemTags = [Tag "one", Tag "two"] + } + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev:" + , " name: 42" + , " tags:" + , " - one" + , " - two" + ] + ] + , testCase "csv" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just . Left $ defaultItem + { itemName = Name "42" + , itemTags = [Tag "one", Tag "two"] + } + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev:" + , " name: 42" + , " tags: one, two" + ] + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0].prev.name: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev:" + , " name: \"\"" + ] + ] + ] + +testQueueNext :: TestTree +testQueueNext = testGroup "next" + [ testGroup "array" + [ testCase "string" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - one" + ] + ] + , testCase "number" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "42" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - 42" + ] + ] + , testCase "object" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - name: one" + ] + ] + , testCase "url" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + , itemUrl = Just $ + Url "https://www.example.com/one" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - name: one" + , " url: https://www.example.com/one" + ] + ] + , testGroup "tags" + [ testCase "array" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + , itemTags = [Tag "one", Tag "two"] + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - name: one" + , " tags:" + , " - one" + , " - two" + ] + ] + , testCase "csv" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + , itemTags = [Tag "one", Tag "two"] + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - name: one" + , " tags: one, two" + ] + ] + ] + , testCase "multiple" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + } + , defaultItem + { itemName = Name "42" + , itemUrl = Just $ + Url "https://www.example.com/42" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - one" + , " - name: 42" + , " url: https://www.example.com/42" + ] + ] + , testCase "none" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Nothing + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + ] + ] + , testCase "prev" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "42" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " prev: 41" + , " next:" + , " - 42" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next:" + , " - \"\"" + ] + ] + ] + , testGroup "csv" + [ testCase "single" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "one" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next: one" + ] + ] + , testCase "number" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "42" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next: 42" + ] + ] + , testCase "multiple" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "test" + , queueItems = Just $ Right + [ defaultItem + { itemName = Name "11" + } + , defaultItem + { itemName = Name "42" + } + ] + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next: 11, 42" + ] + ] + , testCase "empty" $ do + let message = intercalate "\n" + [ "error loading /tmp/test.yaml: Aeson exception:" + , "Error in $[0]: empty string" + ] + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: test" + , " next: \"\"" + ] + ] + ] + ] + +------------------------------------------------------------------------------ +-- $Import + +testImportSection :: TestTree +testImportSection = testGroup "section" + [ testCase "existing" $ do + let generalSection = Section "general" + extraSection = Section "extra" + expected = defaultQueueSheet + { qsSections = [defaultSection, generalSection, extraSection] + , qsQueues = + [ defaultQueue + { queueName = Name "one" + , queueSection = generalSection + } + , defaultQueue + { queueName = Name "two" + , queueSection = extraSection + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "sections:" + , " - general" + , " - extra" + , "" + , "queues:" + , " - name: one" + , " section: general" + , " - import: extra.yaml" + , " section: extra" + ] + , validFile "/tmp/extra.yaml" + [ "sections:" + , " - general" + , "" + , "queues:" + , " - name: two" + , " section: general" + ] + ] + , testCase "unknown" $ do + let message = + "error loading /tmp/test.yaml: " ++ + "import extra.yaml has unknown section extra" + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: one" + , "- import: extra.yaml" + , " section: extra" + ] + , validFile "/tmp/extra.yaml" + [ "- name: two" + ] + ] + ] + +testImportInherit :: TestTree +testImportInherit = testGroup "inherit" + [ testCase "default" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "one" + } + , defaultQueue + { queueName = Name "two" + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: one" + , "- import: extra.yaml" + ] + , validFile "/tmp/extra.yaml" + [ "- name: two" + ] + ] + , testCase "existing" $ do + let generalSection = Section "general" + expected = defaultQueueSheet + { qsSections = [defaultSection, generalSection] + , qsQueues = + [ defaultQueue + { queueName = Name "one" + , queueSection = generalSection + } + , defaultQueue + { queueName = Name "two" + , queueSection = generalSection + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "sections:" + , " - general" + , "" + , "queues:" + , " - name: one" + , " section: general" + , " - import: extra.yaml" + ] + , validFile "/tmp/extra.yaml" + [ "sections:" + , " - general" + , "" + , "queues:" + , " - name: two" + , " section: general" + ] + ] + , testCase "unknown" $ do + let message = + "error loading /tmp/test.yaml: " ++ + "queue two imported from extra.yaml has unknown section general" + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: one" + , "- import: extra.yaml" + ] + , validFile "/tmp/extra.yaml" + [ "sections:" + , " - general" + , "" + , "queues:" + , " - name: two" + , " section: general" + ] + ] + ] + +testImportPath :: TestTree +testImportPath = testGroup "path" + [ testCase "absolute" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "one" + } + , defaultQueue + { queueName = Name "two" + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: one" + , "- import: /home/test/extra.yaml" + ] + , validFile "/home/test/extra.yaml" + [ "- name: two" + ] + ] + , testCase "relative" $ do + let expected = defaultQueueSheet + { qsQueues = + [ defaultQueue + { queueName = Name "one" + } + , defaultQueue + { queueName = Name "two" + } + ] + } + Right expected @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- name: one" + , "- import: test/extra.yaml" + ] + , validFile "/tmp/test/extra.yaml" + [ "- name: two" + ] + ] + , testCase "error" $ do + let message = "error loading file: /tmp/extra.yaml" + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- import: extra.yaml" + ] + , invalidFile "/tmp/extra.yaml" + ] + , testCase "same" $ do + let message = + "error loading /tmp/test.yaml: " ++ + "cyclic import: /tmp/test.yaml" + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- import: test.yaml" + ] + ] + , testCase "cyclic" $ do + let message = + "error loading /tmp/two.yaml: " ++ + "cyclic import: /tmp/one.yaml" + Left message @=? loadYaml + [ validFile "/tmp/test.yaml" + [ "- import: one.yaml" + ] + , validFile "/tmp/one.yaml" + [ "- import: two.yaml" + ] + , validFile "/tmp/two.yaml" + [ "- import: one.yaml" + ] + ] + ] + +------------------------------------------------------------------------------ +-- $File + +testFileLoad :: TestTree +testFileLoad = testGroup "load" + [ testCase "error" $ do + let message = "error loading file: /tmp/test.yaml" + Left message @=? loadYaml + [ invalidFile "/tmp/test.yaml" + ] + ] + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "QueueSheet.File" + [ testGroup "Queue" + [ testQueueName + , testQueueUrl + , testQueueSection + , testQueueTag + , testQueueDate + , testQueuePrev + , testQueueNext + ] + , testGroup "Import" + [ testImportSection + , testImportInherit + , testImportPath + ] + , testGroup "File" + [ testFileLoad + ] + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : queue sheet test runner +-- Copyright : Copyright (c) 2020-2022 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +module Main (main) where + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (defaultMain, testGroup) + +-- (queue-sheet:test) +import qualified QueueSheet.File.Test + +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ testGroup "test" + [ QueueSheet.File.Test.tests + ]