queue-sheet (empty) → 0.7.0.2
raw patch · 14 files changed
+2510/−0 lines, 14 filesdep +aesondep +ansi-wl-pprintdep +basesetup-changed
Dependencies added: aeson, ansi-wl-pprint, base, bytestring, directory, filepath, ginger, optparse-applicative, process, queue-sheet, scientific, tasty, tasty-hunit, text, transformers, ttc, vector, yaml
Files
- CHANGELOG.md +121/−0
- LICENSE +21/−0
- README.md +117/−0
- Setup.hs +2/−0
- app/LibOA.hs +141/−0
- app/queue-sheet.hs +101/−0
- queue-sheet.cabal +97/−0
- src/QueueSheet.hs +27/−0
- src/QueueSheet/Build.hs +74/−0
- src/QueueSheet/File.hs +120/−0
- src/QueueSheet/Template.hs +176/−0
- src/QueueSheet/Types.hs +359/−0
- test/QueueSheet/File/Test.hs +1132/−0
- test/Spec.hs +22/−0
+ CHANGELOG.md view
@@ -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]: <https://pvp.haskell.org/>+[SemVer]: <https://semver.org/>++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]: <https://keepachangelog.com/en/1.0.0/>++## 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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,117 @@+# Queue Sheet++[](https://www.repostatus.org/#active)+[](https://github.com/ExtremaIS/queue-sheet-haskell/actions)+[](https://hackage.haskell.org/package/queue-sheet)+[](https://stackage.org/package/queue-sheet)+[](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]: <https://github.com/ExtremaIS/queue-sheet-haskell/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]: <https://hackage.haskell.org/package/queue-sheet>+[Cabal]: <https://www.haskell.org/cabal/>++#### Installation From Stackage++Install Queue Sheet from [Stackage][] using [Stack][] as follows:++```+$ stack install queue-sheet+```++[Stackage]: <https://www.stackage.org/package/queue-sheet>+[Stack]: <https://haskellstack.org/>++### 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: <https://hackage.haskell.org/package/queue-sheet>+* Stackage: <https://www.stackage.org/package/queue-sheet>+* GitHub: <https://github.com/ExtremaIS/queue-sheet-haskell>+* GitHub Actions CI: <https://github.com/ExtremaIS/queue-sheet-haskell/actions>++### 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:+<https://github.com/ExtremaIS/queue-sheet-haskell/issues>++Issues may also be submitted via email to <bugs@extrema.is>.++### License++This project is released under the+[MIT License](https://opensource.org/licenses/MIT) as specified in the+[`LICENSE`](LICENSE) file.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/LibOA.hs view
@@ -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)
+ app/queue-sheet.hs view
@@ -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
+ queue-sheet.cabal view
@@ -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+ <https://github.com/ExtremaIS/queue-sheet-haskell#readme>.++homepage: https://github.com/ExtremaIS/queue-sheet-haskell#readme+bug-reports: https://github.com/ExtremaIS/queue-sheet-haskell/issues+author: Travis Cardwell <travis.cardwell@extrema.is>+maintainer: Travis Cardwell <travis.cardwell@extrema.is>+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
+ src/QueueSheet.hs view
@@ -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
+ src/QueueSheet/Build.hs view
@@ -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
+ src/QueueSheet/File.hs view
@@ -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+ }
+ src/QueueSheet/Template.hs view
@@ -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 = "<!"+ , delimCloseTag = "!>"+ , 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
+ src/QueueSheet/Types.hs view
@@ -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"
+ test/QueueSheet/File/Test.hs view
@@ -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+ ]+ ]
+ test/Spec.hs view
@@ -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+ ]