├── .gitignore ├── .travis.yml ├── HLint.hs ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── calz.cabal ├── package.yaml ├── screenshot.png ├── src └── Calz │ ├── ArgParser.hs │ ├── DateUtil.hs │ ├── Layout │ ├── Flow.hs │ ├── Grid.hs │ └── Util.hs │ ├── PhraseParser.hs │ └── Types.hs ├── stack.yaml └── test ├── Calz └── PhraseParserSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .*.sw[nop] 3 | *~ 4 | tags 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | # 11 | # UPDATE(jez): I added support for building on macOS 12 | 13 | # Do not choose a language; we provide our own build tools. 14 | language: generic 15 | 16 | # Caching so the next build will be fast too. 17 | cache: 18 | directories: 19 | - $HOME/.ghc 20 | - $HOME/.stack 21 | - $TRAVIS_BUILD_DIR/.stack-work 22 | 23 | # The different configurations we want to test. We have BUILD=cabal which uses 24 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 25 | # of those below. 26 | # 27 | # We set the compiler values here to tell Travis to use a different 28 | # cache file per set of arguments. 29 | # 30 | # If you need to have different apt packages for each combination in the 31 | # matrix, you can use a line such as: 32 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 33 | matrix: 34 | include: 35 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 36 | # variable, such as using --stack-yaml to point to a different file. 37 | - env: BUILD=stack ARGS="" 38 | compiler: ": #stack default" 39 | addons: {apt: {packages: [libgmp-dev]}} 40 | 41 | # Build on macOS in addition to Linux 42 | - env: BUILD=stack ARGS="" 43 | compiler: ": #stack default osx" 44 | os: osx 45 | 46 | before_install: 47 | # Using compiler above sets CC to an invalid value, so unset it 48 | - unset CC 49 | 50 | # Download and unpack the stack executable 51 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 52 | - mkdir -p ~/.local/bin 53 | - | 54 | if [ `uname` = "Darwin" ] 55 | then 56 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 57 | else 58 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 59 | fi 60 | 61 | install: 62 | # Build dependencies 63 | - stack --no-terminal --install-ghc test --only-dependencies 64 | 65 | script: 66 | # Build the package, its tests, and its docs and run the tests 67 | - stack --no-terminal test 68 | 69 | before_deploy: 70 | - stack --no-terminal install 71 | - cp "$TRAVIS_BUILD_DIR/README.md" "$TRAVIS_BUILD_DIR/LICENSE" "$HOME/.local/bin" 72 | - cd "$HOME/.local/bin" 73 | - tar czf "calz-${TRAVIS_TAG}-${TRAVIS_OS_NAME}.tar.gz" calz README.md LICENSE 74 | 75 | deploy: 76 | provider: releases 77 | api_key: 78 | secure: 1hxoP674XYj8idP+Kmobh0i6AZw2YRcSAETWzwG4s0Ma4D6cAawlfwS0k3bEAmMx3Bh+aNlhQfuPdxxZTAud4zP/SdFFfd6XPmCY86KD5l+zIZ9qqFYYIqDBHVDE7Uop0bIgP4/OPixqNRhr2odRWO/EyzmPZOgREMorPd2jwucYLP6AMIVkuDN/JNAmQ0dcleY4ymIU6MXuhxagNFkF/XiQWV2F8QlnTcHZq9sJ8pqW7Mlmd07PlLjjGhbFYbcXjSCEANW7Hsa4TJOsD36JFmPyuIF1Kx3ZfNXo37hyt7eUA3/bWKzTZW8/o5kiKRfdi/XPGReb/aEEOKrXB/iLduyx4mYpHUgOJD4sxQ8CJDjtgooc9d9dA+2pa8AW1/0JmA6YAifKB9hD8O4q6RuZ4T+2sTz2DihHkHx4sSi0fI3hq2pS1mWn61Jz61mtnFqH2RPWRXGKKa7ylpjAQ9VYRNkBiAdJGb1bpcMn/LMDJXqrtupOTRUmAzG1PPqbCSqex2Icm+SJaYmcuMmp/ALJHkE8aPH+ilLNKsH2u2nzAi1gd9X+jvxGDVbno3L4EcGMXsHS3ighbYeT9fAMuL4xxl/1UJS257m5aXad2tRtpcKdLOnzuleMBwr/H0dLlA9iEWnVIFv6ofasOk2U0AIk+haSX3z5qTMJPmh2K+V2u+g= 79 | file: "$HOME/.local/bin/calz-${TRAVIS_TAG}-${TRAVIS_OS_NAME}.tar.gz" 80 | on: 81 | tags: true 82 | repo: jez/calz 83 | -------------------------------------------------------------------------------- /HLint.hs: -------------------------------------------------------------------------------- 1 | ignore "Redundant do" 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Jake Zimmerman (c) 2018 2 | The MIT License (MIT) 3 | 4 | Copyright (c) 2018 Jake Zimmerman 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # calz 2 | 3 | > A feature-rich command line cal alternative 4 | 5 | I'm a huge fan of the Unix `cal` program, but it has a limited set of features 6 | when it comes to colors and displaying date *ranges*. `calz` is an alternative 7 | to `cal` with a whole host of features and layouting options. 8 | 9 | calz screenshot 10 | 11 | 12 | ## Install 13 | 14 | ### Using Homebrew 15 | 16 | ``` 17 | brew install jez/formulae/calz 18 | ``` 19 | 20 | ### On Linux 21 | 22 | Check the [Releases](https://github.com/jez/calz/releases) page for pre-built 23 | 64 bit binaries for Linux (note you'll also need libgmp installed). 24 | 25 | ### From Source 26 | 27 | To build this project from source, use Haskell's [Stack]. 28 | 29 | [Stack]: https://docs.haskellstack.org/en/stable/ 30 | 31 | ``` 32 | git clone https://github.com/jez/calz.git 33 | 34 | stack build && stack install 35 | ``` 36 | 37 | If you've packaged this software for your operating system, let me know and I 38 | can link to it from these instructions. 39 | 40 | ## Usage 41 | 42 | ``` 43 | Display a calendar for a month or a range of months. 44 | 45 | Usage: 46 | calz [options] [...] 47 | 48 | Options: 49 | -l, --layout= Can be 'grid' or 'flow' [default: flow] 50 | -n, --columns= If layout is 'grid': how many columns to use 51 | [default: 3] 52 | -C, --no-color Disable all color 53 | -H, --no-labels Don't show month labels 54 | -P, --no-pad Complete the first and last weeks of every month with 55 | the first and last days of surrounding months 56 | -h, --help Show this help message 57 | 58 | Phrase: 59 | calz [] 60 | calz 61 | calz (last|this|next) (month|year) 62 | calz last (months|years) 63 | calz (months|years) ago 64 | calz next (months|years) 65 | calz (months|years) from (now|today) 66 | calz from ... to ... 67 | 68 | Examples: 69 | dec 2017 70 | next month 71 | 3 months ago 72 | from 2 months from now to next year 73 | ``` 74 | 75 | The goal is to accept as many commonly used phrases for talking about dates as 76 | possible. If you find yourself using a phrase that's not accepted, please open 77 | an issue. 78 | 79 | 80 | ## Potential Future Features 81 | 82 | - Highlight arbitrary ISO-8601 dates provided on stdin 83 | - Display line separators between months in flow layout 84 | - Customize colors with flags 85 | 86 | 87 | ## License 88 | 89 | [![MIT License](https://img.shields.io/badge/license-MIT-blue.svg)](https://jez.io/MIT-LICENSE.txt) 90 | 91 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Main where 4 | 5 | import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc) 6 | import Data.Time 7 | import Data.Version (showVersion) 8 | import System.Console.Docopt 9 | import System.Environment (getArgs) 10 | import System.Exit (exitSuccess) 11 | 12 | import Calz.ArgParser 13 | import Calz.Layout.Flow 14 | import Calz.Layout.Grid 15 | import Calz.Types 16 | import Paths_calz (version) 17 | 18 | parseArgvOrThrow :: Day -> [String] -> IO (Config, DatePhrase) 19 | parseArgvOrThrow today argv = case parseArgv today argv of 20 | Left (HelpError message) -> exitWithUsageMessage patterns message 21 | Left Version -> do 22 | putStrLn . showVersion $ version 23 | exitSuccess 24 | Right parsed -> return parsed 25 | 26 | main :: IO () 27 | main = do 28 | today <- localDay . zonedTimeToLocalTime <$> getZonedTime 29 | (config, fromTo) <- getArgs >>= parseArgvOrThrow today 30 | 31 | let layoutFn = case optLayout config of 32 | Grid _ -> layoutGrid 33 | Flow _ -> layoutFlow 34 | 35 | putDoc $ layoutFn config fromTo today 36 | -------------------------------------------------------------------------------- /calz.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 5504c1fedc2447e6435b2cd30e97b624a198a72273441efb653a2799aa65b036 6 | 7 | name: calz 8 | version: 0.9.1.0 9 | synopsis: Like the Unix cal program, but better 10 | description: Please see the README on Github at 11 | category: System 12 | homepage: https://github.com/jez/calz#readme 13 | bug-reports: https://github.com/jez/calz/issues 14 | author: Jake Zimmerman 15 | maintainer: zimmerman.jake@gmail.com 16 | copyright: 2018 Jake Zimmerman 17 | license: MIT 18 | license-file: LICENSE 19 | build-type: Simple 20 | cabal-version: >= 1.10 21 | extra-source-files: 22 | LICENSE 23 | README.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/jez/calz 28 | 29 | library 30 | hs-source-dirs: 31 | src 32 | ghc-options: -Wall -Wcompat -Wmissing-signatures -Werror -funbox-strict-fields -optP-Wno-nonportable-include-path -O2 33 | build-depends: 34 | base >=4.7 && <5 35 | , docopt 36 | , monadplus 37 | , mtl 38 | , parsec 39 | , prettyprinter 40 | , prettyprinter-ansi-terminal 41 | , split 42 | , text 43 | , time 44 | exposed-modules: 45 | Calz.ArgParser 46 | Calz.DateUtil 47 | Calz.Layout.Flow 48 | Calz.Layout.Grid 49 | Calz.Layout.Util 50 | Calz.PhraseParser 51 | Calz.Types 52 | other-modules: 53 | Paths_calz 54 | default-language: Haskell2010 55 | 56 | executable calz 57 | main-is: Main.hs 58 | hs-source-dirs: 59 | app 60 | ghc-options: -Wall -Wcompat -Wmissing-signatures -Werror -funbox-strict-fields -optP-Wno-nonportable-include-path -O2 -threaded -rtsopts -with-rtsopts=-N 61 | build-depends: 62 | base >=4.7 && <5 63 | , calz 64 | , docopt 65 | , monadplus 66 | , mtl 67 | , parsec 68 | , prettyprinter 69 | , prettyprinter-ansi-terminal 70 | , split 71 | , text 72 | , time 73 | other-modules: 74 | Paths_calz 75 | default-language: Haskell2010 76 | 77 | test-suite calz-test 78 | type: exitcode-stdio-1.0 79 | main-is: Spec.hs 80 | hs-source-dirs: 81 | test 82 | ghc-options: -Wall -Wcompat -Wmissing-signatures -Werror -funbox-strict-fields -optP-Wno-nonportable-include-path -O2 -threaded -rtsopts -with-rtsopts=-N 83 | build-depends: 84 | base >=4.7 && <5 85 | , calz 86 | , docopt 87 | , hspec 88 | , monadplus 89 | , mtl 90 | , parsec 91 | , prettyprinter 92 | , prettyprinter-ansi-terminal 93 | , split 94 | , text 95 | , time 96 | other-modules: 97 | Calz.PhraseParserSpec 98 | Paths_calz 99 | default-language: Haskell2010 100 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: calz 2 | version: 0.9.2.0 3 | github: jez/calz 4 | license: MIT 5 | author: Jake Zimmerman 6 | maintainer: zimmerman.jake@gmail.com 7 | copyright: 2018 Jake Zimmerman 8 | 9 | extra-source-files: 10 | - README.md 11 | - LICENSE 12 | 13 | # Metadata used when publishing your package 14 | synopsis: Like the Unix cal program, but better 15 | description: Please see the README on Github at 16 | category: System 17 | 18 | ghc-options: 19 | - -Wall 20 | - -Wcompat 21 | - -Wmissing-signatures 22 | - -Werror 23 | - -funbox-strict-fields 24 | # TODO(jez) Remove this option once https://github.com/haskell/cabal/issues/4739 is fixed 25 | - -optP-Wno-nonportable-include-path 26 | - -O2 27 | 28 | dependencies: 29 | - base >= 4.7 && < 5 30 | - docopt 31 | - time 32 | - parsec 33 | - monadplus 34 | - split 35 | - mtl 36 | - text 37 | - prettyprinter 38 | - prettyprinter-ansi-terminal 39 | 40 | 41 | library: 42 | source-dirs: src 43 | 44 | executables: 45 | calz: 46 | main: Main.hs 47 | source-dirs: app 48 | ghc-options: 49 | - -threaded 50 | - -rtsopts 51 | - -with-rtsopts=-N 52 | dependencies: 53 | - calz 54 | 55 | tests: 56 | calz-test: 57 | main: Spec.hs 58 | source-dirs: test 59 | ghc-options: 60 | - -threaded 61 | - -rtsopts 62 | - -with-rtsopts=-N 63 | dependencies: 64 | - calz 65 | - hspec 66 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jez/calz/dbaf27ec38df7bcdc8356ac400782226ffc61b0d/screenshot.png -------------------------------------------------------------------------------- /src/Calz/ArgParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module Calz.ArgParser (parseArgv, patterns, ArgvParseError(..)) where 6 | 7 | import Control.Monad (when) 8 | import Control.Monad.Except 9 | import qualified Data.Text as T 10 | import Data.Time 11 | import System.Console.Docopt 12 | 13 | import Calz.DateUtil 14 | import Calz.PhraseParser 15 | import Calz.Types 16 | 17 | patterns :: Docopt 18 | patterns = 19 | [docopt| 20 | Display a calendar for a month or a range of months. 21 | 22 | Usage: 23 | calz [options] [...] 24 | 25 | Options: 26 | -l, --layout= Can be 'grid' or 'flow' [default: flow] 27 | -n, --columns= If layout is 'grid': how many columns to use 28 | [default: 3] 29 | -s, --separators If layout is 'flow': show month separators 30 | -C, --no-color Disable all color 31 | -H, --no-labels Don't show month labels 32 | -P, --no-pad Complete the first and last weeks of every month with 33 | the first and last days of surrounding months 34 | -h, --help Show this help message 35 | -v, --version Show version information 36 | 37 | Phrase: 38 | calz [] 39 | calz 40 | calz (last|this|next) (month|year) 41 | calz last (months|years) 42 | calz (months|years) ago 43 | calz next (months|years) 44 | calz (months|years) from (now|today) 45 | calz from ... to ... 46 | calz ... to ... 47 | 48 | Examples: 49 | dec 2017 50 | next month 51 | 3 months ago 52 | from 2 months from now to next year 53 | |] 54 | 55 | data ArgvParseError 56 | = HelpError String 57 | | Version 58 | 59 | throwHelpError :: MonadError ArgvParseError m => String -> m a 60 | throwHelpError = throwError . HelpError 61 | 62 | parseArgsOrThrow :: MonadError ArgvParseError m => [String] -> m Arguments 63 | parseArgsOrThrow argv = case parseArgs patterns argv of 64 | Left _ -> throwHelpError "" 65 | Right result -> return result 66 | 67 | hasOption' :: Arguments -> String -> Bool 68 | hasOption' args opt = isPresent args (longOption opt) 69 | 70 | getArgOrThrow' :: MonadError ArgvParseError m => Arguments -> Option -> m String 71 | getArgOrThrow' args opt = case getArg args opt of 72 | Nothing -> throwHelpError "" 73 | Just result -> return result 74 | 75 | parseArgv 76 | :: MonadError ArgvParseError m => Day -> [String] -> m (Config, DatePhrase) 77 | parseArgv today argv = do 78 | args <- parseArgsOrThrow argv 79 | 80 | -- helpers 81 | let hasOption = hasOption' args 82 | getArgOrThrow = getArgOrThrow' args 83 | 84 | -- exit immediately if we see the '--help' flag 85 | when (hasOption "help") (throwHelpError "") 86 | 87 | -- exit immediately if we see the '--version' flag 88 | when (hasOption "version") (throwError Version) 89 | 90 | -- layout has two dependent options (it would be nice if docopt were smart 91 | -- enough to know that this will never fail, so we could omit getArgOrThrow) 92 | layoutOpt <- getArgOrThrow (longOption "layout") >>= \case 93 | "grid" -> Grid . read <$> getArgOrThrow (longOption "columns") 94 | "flow" -> return . Flow $ hasOption "separators" 95 | val -> throwHelpError $ "--layout must be 'flow' or 'grid'; found: " ++ val 96 | 97 | -- simple boolean options 98 | let color = not $ hasOption "no-color" 99 | let hideLabels = hasOption "no-labels" 100 | let hidePad = hasOption "no-pad" 101 | 102 | -- Done with config 103 | let config = Config layoutOpt color hideLabels hidePad 104 | 105 | -- Parse phrase to get month range 106 | let phrase = T.pack $ unwords . getAllArgs args $ argument "phrase" 107 | fromTo <- if getArgCount args (argument "phrase") == 0 108 | then 109 | let start = thisMonth today 110 | end = addMonth start 111 | in return $ DatePhrase start end 112 | else case parsePhrase today phrase of 113 | Left _ -> throwHelpError $ "Could't parse phrase: " ++ T.unpack phrase 114 | Right x -> return x 115 | 116 | return (config, fromTo) 117 | -------------------------------------------------------------------------------- /src/Calz/DateUtil.hs: -------------------------------------------------------------------------------- 1 | module Calz.DateUtil where 2 | 3 | import Data.Time 4 | import Data.Time.Calendar.WeekDate 5 | 6 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 7 | uncurry3 f (x, y, z) = f x y z 8 | 9 | 10 | ----- SundayWeekDate ---------------------------------------------------------- 11 | 12 | -- | Like toWeekDate, but uses 1 for Sunday and 7 for Saturday. 13 | toSundayWeekDate :: Day -> (Integer, Int, Int) 14 | toSundayWeekDate = toWeekDate . succ 15 | 16 | -- | Like fromWeekDate, but uses 1 for Sunday and 7 for Saturday. 17 | fromSundayWeekDate :: (Integer, Int, Int) -> Day 18 | fromSundayWeekDate = pred . uncurry3 fromWeekDate 19 | 20 | -- | Get the Sunday that starts the week for a given day 21 | firstOfSundayWeek :: Day -> Day 22 | firstOfSundayWeek day = fromSundayWeekDate (y, w, 1) 23 | where (y, w, _) = toSundayWeekDate day 24 | 25 | -- | Get the Saturday that ends the week for a given day 26 | lastOfSundayWeek :: Day -> Day 27 | lastOfSundayWeek day = fromSundayWeekDate (y, w, 7) 28 | where (y, w, _) = toSundayWeekDate day 29 | 30 | -- | Extract the week of a day, treating Sunday as the first day of the week. 31 | getSundayWeek :: Day -> (Integer, Int) 32 | getSundayWeek day = (y, w) where (y, w, _) = toSundayWeekDate day 33 | 34 | -- | Check whether the weeks of two dates are the same, starting with Sundays 35 | sameSundayWeek :: Day -> Day -> Bool 36 | sameSundayWeek day1 day2 = getSundayWeek day1 == getSundayWeek day2 37 | 38 | 39 | ----- Projections ------------------------------------------------------------- 40 | 41 | getDay :: Day -> Int 42 | getDay day = let (_, _, d) = toGregorian day in d 43 | 44 | getMonth :: Day -> (Integer, Int) 45 | getMonth day = let (y, m, _) = toGregorian day in (y, m) 46 | 47 | getYear :: Day -> Integer 48 | getYear day = let (y, _, _) = toGregorian day in y 49 | 50 | 51 | ----- Computing offsets ------------------------------------------------------- 52 | 53 | addMonth :: Day -> Day 54 | addMonth = addGregorianMonthsClip 1 55 | 56 | addYear :: Day -> Day 57 | addYear = addGregorianMonthsClip 12 58 | 59 | ----- Month beginnings and endings -------------------------------------------- 60 | 61 | firstDayOfMonth :: (Integer, Int) -> Day 62 | firstDayOfMonth (y, m) = fromGregorian y m 1 63 | 64 | thisMonth :: Day -> Day 65 | thisMonth day = firstDayOfMonth . getMonth $ day 66 | 67 | nextMonth :: Day -> Day 68 | nextMonth = addMonth . thisMonth 69 | -------------------------------------------------------------------------------- /src/Calz/Layout/Flow.hs: -------------------------------------------------------------------------------- 1 | module Calz.Layout.Flow (layoutFlow, layoutFlowDebug) where 2 | 3 | import Control.Monad.Reader 4 | import Data.Function ((&)) 5 | import Data.List (groupBy) 6 | import Data.Text.Prettyprint.Doc 7 | import Data.Text.Prettyprint.Doc.Render.Terminal 8 | import Data.Time 9 | 10 | import Calz.Layout.Util 11 | import Calz.Types 12 | 13 | -- | Check if two weeks share the same month 14 | -- 15 | -- Answers the question, "Do we have to put a new label next to the week2, 16 | -- or can we re-use the label from week1?" 17 | sameMonthOfWeek :: [Day] -> [Day] -> Bool 18 | sameMonthOfWeek week1 week2 = getMonthOfWeek week1 == getMonthOfWeek week2 19 | 20 | -- | Group a list of weeks into lists "months". 21 | -- 22 | -- If a week contains the start of the month, all days in that week are 23 | -- considered part of _that_ month, even if they technically belong to the 24 | -- previous month. For example: 25 | -- 26 | -- > [[[31 01 02 03 04 05 06], -- January 27 | -- > [07 08 09 10 11 12 13], 28 | -- > [14 15 16 17 18 19 20], 29 | -- > [21 22 23 24 25 26 27]], 30 | -- > [[28 29 30 31 01 02 03], -- February 31 | -- > [04 05 06 07 08 09 10], 32 | -- > [11 12 13 14 15 16 17], 33 | -- > [18 19 20 21 22 23 24]], 34 | -- > [[25 26 27 28 01 02 03]], -- March 35 | -- > ] 36 | groupWeeksByMonth :: [[Day]] -> [[[Day]]] 37 | groupWeeksByMonth weeks = groupBy sameMonthOfWeek weeks 38 | 39 | withMonth :: [[Day]] -> (String, [[Day]]) 40 | -- @month@ is non-empty because groupBy ensures each sublist is non-empty. 41 | withMonth [] = error "A month ([[Day]]) must have at least one week ([Day])" 42 | withMonth (month@(week:_)) = 43 | let monthIdx = snd $ getMonthOfWeek week 44 | in (getLongMonthName monthIdx, month) 45 | 46 | withMonths :: [[[Day]]] -> [(String, [[Day]])] 47 | withMonths ms = map withMonth ms 48 | 49 | monthNamePad :: Int 50 | monthNamePad = 1 + (maximum . map (length . fst) $ months defaultTimeLocale) 51 | 52 | formatMonth :: (String, [[Day]]) -> M (Doc Annotation) 53 | formatMonth (monthName, monthGrid) = do 54 | hideLabels <- optHideLabels . formatConfig <$> ask 55 | grid <- monthGrid & mapM (mapM dayToDoc >>^ hsep) >>^ vsep 56 | 57 | if hideLabels 58 | then return grid 59 | else do 60 | -- TODO(jez) Show the year next to January if there are multiple years. 61 | -- Don't show a label if there's only one week in this month grid 62 | let label = fill monthNamePad $ if length monthGrid == 1 63 | then emptyDoc 64 | else annotate LabelAnn $ pretty monthName 65 | return $ label <+> align grid 66 | 67 | formatCalendar :: M (Doc Annotation) 68 | formatCalendar = do 69 | hideLabels <- optHideLabels . formatConfig <$> ask 70 | phrase <- formatDatePhrase <$> ask 71 | let weekdaysHeader = annotate HeaderAnn $ pretty "Su Mo Tu We Th Fr Sa" 72 | let header = if hideLabels 73 | then weekdaysHeader 74 | else fill monthNamePad emptyDoc <+> weekdaysHeader 75 | let grid = 76 | withMonths 77 | . groupWeeksByMonth 78 | . groupByWeek 79 | . allDays 80 | . padDatePhrase 81 | $ phrase 82 | (<+> line) . vsep . (header :) <$> (mapM formatMonth grid) 83 | 84 | layoutFlow :: Config -> DatePhrase -> Day -> Doc AnsiStyle 85 | layoutFlow config phrase today = 86 | runReader (formatCalendar >>= asAnsiStyle) (R config phrase today) 87 | 88 | ----- Only for debugging ------------------------------------------------------ 89 | 90 | jan01, jan21, mar01 :: Day 91 | jan01 = fromGregorian 2018 01 01 92 | jan21 = fromGregorian 2018 01 21 93 | mar01 = fromGregorian 2018 03 01 94 | 95 | layoutFlowDebug :: Doc AnsiStyle 96 | layoutFlowDebug = layoutFlow defaultConfig (DatePhrase jan01 mar01) jan21 97 | -------------------------------------------------------------------------------- /src/Calz/Layout/Grid.hs: -------------------------------------------------------------------------------- 1 | module Calz.Layout.Grid (layoutGrid, layoutGridDebug) where 2 | 3 | import Control.Monad 4 | import Control.Monad.Reader 5 | import Data.List.Split (chunksOf) 6 | import Data.Maybe (fromMaybe) 7 | import Data.Text.Prettyprint.Doc 8 | import Data.Text.Prettyprint.Doc.Render.Terminal 9 | import Data.Time 10 | 11 | import Calz.DateUtil 12 | import Calz.Layout.Util 13 | import Calz.Types 14 | 15 | enumMonthsFrom :: Day -> [Day] 16 | enumMonthsFrom from = from : (enumMonthsFrom (addMonth from)) 17 | 18 | enumMonthsFromTo :: Day -> Day -> [Day] 19 | enumMonthsFromTo from to = takeWhile (<= to) $ enumMonthsFrom from 20 | 21 | allMonthPhrases :: DatePhrase -> [DatePhrase] 22 | allMonthPhrases (DatePhrase from to) = 23 | let monthStarts = enumMonthsFromTo from to 24 | ms = zip monthStarts (drop 1 monthStarts) 25 | in map (uncurry DatePhrase) ms 26 | 27 | 28 | -- | Transpose, but record empty spots with @Nothing@. 29 | -- 30 | -- If a value is in the third row in the input, we guarantee it ends up in the 31 | -- third column in the output. Consider this matrix: 32 | -- 33 | -- > [[10, 11], 34 | -- > [20], 35 | -- > [30, 31, 32]] 36 | -- 37 | -- @jaggedTranspose@ outputs 31 and 32 in the third column by inserting padding 38 | -- in the other columns: 39 | -- 40 | -- > [[Just 10, Just 20, Just 30], 41 | -- > [Just 11, Nothing, Just 31], 42 | -- > [Nothing, Nothing, Just 32]] 43 | -- 44 | -- By comparson, @transpose@ puts 31 in the /second/ column, and 32 in the 45 | -- /first/ column: 46 | -- 47 | -- > [[10, 20, 30], 48 | -- > [11, 31], 49 | -- > [32]] 50 | jaggedTranspose :: [[a]] -> [[Maybe a]] 51 | jaggedTranspose = 52 | let makeAllJust = (map . map $ Just) in jaggedTranspose' . makeAllJust 53 | 54 | -- Like @join@, but with Maybe and List 55 | -- 56 | -- @join@ requires that the two monads being joined are the same. 57 | joinListMaybe :: Maybe [a] -> [a] 58 | joinListMaybe Nothing = [] 59 | joinListMaybe (Just []) = [] 60 | joinListMaybe (Just xs) = xs 61 | 62 | jaggedTranspose' :: [[Maybe a]] -> [[Maybe a]] 63 | jaggedTranspose' [] = [] 64 | jaggedTranspose' ([]:xss) = jaggedTranspose' xss 65 | jaggedTranspose' ((x:xs):xss) = 66 | let xss' = map (joinListMaybe . tl) xss 67 | xs' = if null xs && any ((> 0) . length) xss' then [Nothing] else xs 68 | in (x : map (join . hd) xss) : jaggedTranspose' (xs' : xss') 69 | 70 | -- The prettyprint library doesn't have a way to put arbitrary groups of lines 71 | -- side by side. Instead, we have to manually interleave the lines. 72 | -- 73 | -- The goal is that the raw data has the same shape as the characters that will 74 | -- be displayed on the screen, instead of having each month be its own Doc. 75 | -- 76 | -- We end up with /rows/ of month grids, rather than them all in a single list. 77 | -- 78 | -- Interleaves weeks assuming there are n columns 79 | -- interleaveMonthGrids :: Int -> [[[Day]]] -> [[[Maybe [Day]]]] 80 | interleaveMonthGrids :: Int -> [[a]] -> [[[Maybe a]]] 81 | interleaveMonthGrids n monthGrids = 82 | map jaggedTranspose . chunksOf n $ monthGrids 83 | 84 | center :: Int -> String -> String 85 | center n s = 86 | let len = length s 87 | d = n - len 88 | r = d `quot` 2 89 | l = d - r 90 | in if len >= n then s else replicate l ' ' ++ s ++ replicate r ' ' 91 | 92 | weekToDoc :: [Day] -> M (Doc Annotation) 93 | weekToDoc days = hsep <$> mapM dayToDoc days 94 | 95 | formatMonthPhrase :: DatePhrase -> M [Doc Annotation] 96 | formatMonthPhrase monthPhrase = do 97 | hideLabels <- optHideLabels . formatConfig <$> ask 98 | 99 | let monthIdx = snd . getMonth . monthFrom $ monthPhrase 100 | let monthHeader = 101 | annotate LabelAnn 102 | . pretty 103 | . center (2 * 7 + 6) 104 | . getLongMonthName 105 | $ monthIdx 106 | let weekdaysHeader = annotate HeaderAnn $ pretty "Su Mo Tu We Th Fr Sa" 107 | 108 | -- Use runReader becasue we want to "modify" formatDatePhrase, 109 | -- but only for this call. 110 | r <- ask 111 | let r' = r { formatDatePhrase = monthPhrase } 112 | let weekGrid = runReader (mapM weekToDoc . gridOfWeeks $ monthPhrase) r' 113 | 114 | if hideLabels 115 | then return $ (weekdaysHeader : weekGrid) 116 | else return $ (monthHeader : weekdaysHeader : weekGrid) 117 | 118 | formatWeekDoc :: Maybe (Doc Annotation) -> Doc Annotation 119 | formatWeekDoc = fromMaybe (hsep $ replicate 7 (space <> space)) 120 | 121 | formatWeekRow :: [Maybe (Doc Annotation)] -> Doc Annotation 122 | formatWeekRow weekRow = concatWith twoSpaces $ map formatWeekDoc weekRow 123 | where twoSpaces x y = x <> space <> space <> y 124 | 125 | -- TODO(jez) Show year if there are multiple years (or maybe just always?) 126 | formatInterleavedWeeks :: [[Maybe (Doc Annotation)]] -> Doc Annotation 127 | formatInterleavedWeeks weeks = (vsep $ map formatWeekRow weeks) <> line 128 | 129 | formatCalendar :: M (Doc Annotation) 130 | formatCalendar = do 131 | monthPhrases <- allMonthPhrases . formatDatePhrase <$> ask 132 | monthDocGrids <- mapM formatMonthPhrase monthPhrases 133 | -- TODO(jez) This is a partial function! 134 | n <- columns . optLayout . formatConfig <$> ask 135 | let interleavedWeeks = interleaveMonthGrids n monthDocGrids 136 | return $ (vsep $ map formatInterleavedWeeks interleavedWeeks) <> line 137 | 138 | layoutGrid :: Config -> DatePhrase -> Day -> Doc AnsiStyle 139 | layoutGrid config phrase today = 140 | runReader (formatCalendar >>= asAnsiStyle) (R config phrase today) 141 | 142 | ----- Only for debugging ------------------------------------------------------ 143 | 144 | dec01, jan21, mar01 :: Day 145 | dec01 = fromGregorian 2017 12 01 146 | jan21 = fromGregorian 2018 01 21 147 | mar01 = fromGregorian 2018 03 01 148 | 149 | layoutGridDebug :: Doc AnsiStyle 150 | layoutGridDebug = layoutGrid 151 | (defaultConfig { optLayout = Grid {columns = 3} }) 152 | (DatePhrase dec01 mar01) 153 | jan21 154 | -------------------------------------------------------------------------------- /src/Calz/Layout/Util.hs: -------------------------------------------------------------------------------- 1 | module Calz.Layout.Util where 2 | 3 | import Control.Monad.Reader 4 | import Data.List (groupBy) 5 | import Data.Text.Prettyprint.Doc 6 | import Data.Text.Prettyprint.Doc.Render.Terminal 7 | import Data.Time 8 | 9 | import Calz.DateUtil 10 | import Calz.Types 11 | 12 | ----- Monad for layouting ----------------------------------------------------- 13 | 14 | -- This is just so we don't have to thread these three parameters through all 15 | -- of our functions. 16 | 17 | data R = R 18 | { formatConfig :: Config 19 | , formatDatePhrase :: DatePhrase 20 | , formatToday :: Day 21 | } 22 | type M a = Reader R a 23 | 24 | 25 | ----- Helper combinators ------------------------------------------------------ 26 | 27 | -- | Like @(.)@, but with a monadic action first 28 | -- 29 | -- Almost too clever for my own good. Best explained by analogy: 30 | -- 31 | -- > (.) :: (b -> c) -> (a -> b) -> (a -> c) 32 | -- > (>>^) :: Functor f => (b -> c) -> (a -> f b) -> (a -> f c) 33 | -- > (>>=) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) 34 | -- 35 | -- So it's like a middle ground between @(.)@ and @(>>=)@ where the first 36 | -- function is pure and the second is an action. 37 | (^<<) :: Functor f => (b -> c) -> (a -> f b) -> (a -> f c) 38 | (^<<) = (.) . fmap 39 | 40 | -- | Flipped version of the above. 41 | (>>^) :: Functor f => (a -> f b) -> (b -> c) -> (a -> f c) 42 | (>>^) = flip (^<<) 43 | 44 | -- | Safe list head 45 | hd :: [a] -> Maybe a 46 | hd [] = Nothing 47 | hd (x : _) = Just x 48 | 49 | -- | Safe list tail 50 | tl :: [a] -> Maybe [a] 51 | tl [] = Nothing 52 | tl (_ : xs) = Just xs 53 | 54 | 55 | ----- DatePhrases ------------------------------------------------------------- 56 | 57 | -- | Pad DatePhrase to start on a Sunday and end on a Saturday 58 | padDatePhrase :: DatePhrase -> DatePhrase 59 | padDatePhrase (DatePhrase from to) = 60 | -- The asymmetry is because @from@ is inclusive but @to@ is exclusive 61 | DatePhrase (firstOfSundayWeek from) (succ . lastOfSundayWeek $ pred to) 62 | 63 | -- | List of all days within @DatePhrase@ 64 | -- 65 | -- [@monthFrom@, @monthTo@) 66 | allDays :: DatePhrase -> [Day] 67 | allDays (DatePhrase from to) = [from .. (pred to)] 68 | 69 | -- | Group a list of days into weeks 70 | groupByWeek :: [Day] -> [[Day]] 71 | groupByWeek days = groupBy sameSundayWeek days 72 | 73 | -- | Turn a @DatePhrase@ into a the grid for that range. 74 | -- 75 | -- For a given @DatePhrase@, compute the least grid of full weeks (Sunday to 76 | -- Saturday weeks) containing the start and end of the @DatePhrase@. 77 | gridOfWeeks :: DatePhrase -> [[Day]] 78 | gridOfWeeks = groupByWeek . allDays . padDatePhrase 79 | 80 | -- | Get the month for a week 81 | -- 82 | -- The month of a week is the month we'd display next to it in the calendar. 83 | -- So if the month increments from say January to February this week, this 84 | -- week's month is February. 85 | getMonthOfWeek :: [Day] -> (Integer, Int) 86 | getMonthOfWeek week = maximum $ map getMonth week 87 | 88 | -- | Return the long month name (i.e., "January") for a given month by number. 89 | -- 90 | -- Takes a number between 1 - 12. Fails otherwise. 91 | getLongMonthName :: Int -> String 92 | -- This (!!) operation is safe because month number is always 1 - 12 93 | -- and months is length 12 94 | getLongMonthName monthIdx = fst $ (months defaultTimeLocale) !! (monthIdx - 1) 95 | 96 | 97 | ----- Annotations ------------------------------------------------------------- 98 | 99 | -- | Annotate a single day given some config 100 | dayToDoc :: Day -> M (Doc Annotation) 101 | dayToDoc date = do 102 | let d = getDay date 103 | let doc = if d < 10 then space <> pretty d else pretty d 104 | 105 | today <- formatToday <$> ask 106 | let doc' = if date == today then annotate TodayAnn doc else doc 107 | 108 | hidePad <- optHidePad . formatConfig <$> ask 109 | DatePhrase from to <- formatDatePhrase <$> ask 110 | let doc'' = if not (from <= date && date < to) 111 | then if hidePad then pretty " " else annotate PaddedAnn doc' 112 | else doc' 113 | 114 | let monthEnd = pred . nextMonth $ date 115 | -- TODO(jez) Figure out a way to add EndOfMonthAnn anns between the days. 116 | let doc''' = if date >= from && diffDays monthEnd date < 7 117 | then annotate EndOfMonthAnn doc'' 118 | else doc'' 119 | 120 | return doc''' 121 | 122 | removeSeparators :: Annotation -> [Annotation] 123 | removeSeparators EndOfMonthAnn = [] 124 | removeSeparators x = [x] 125 | 126 | singleton :: a -> [a] 127 | singleton x = [x] 128 | 129 | annotationToAnsi :: Annotation -> [AnsiStyle] 130 | annotationToAnsi HeaderAnn = [colorDull Cyan] 131 | annotationToAnsi LabelAnn = [color Magenta] 132 | annotationToAnsi TodayAnn = [colorDull Yellow] 133 | annotationToAnsi PaddedAnn = [color Black <> bold] 134 | annotationToAnsi EndOfMonthAnn = [underlined] 135 | 136 | asAnsiStyle :: Doc Annotation -> M (Doc AnsiStyle) 137 | asAnsiStyle doc = do 138 | useColor <- optColor . formatConfig <$> ask 139 | layout <- optLayout . formatConfig <$> ask 140 | 141 | let useSeparators = case layout of 142 | Flow seps -> seps 143 | _ -> False 144 | 145 | let updateSeparators = if useSeparators then singleton else removeSeparators 146 | let translate = if useColor then annotationToAnsi else const [] 147 | 148 | return $ alterAnnotations translate . alterAnnotations updateSeparators $ doc 149 | -------------------------------------------------------------------------------- /src/Calz/PhraseParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Calz.PhraseParser 5 | ( parsePhrase 6 | , parseWithEof 7 | ) 8 | where 9 | 10 | import Control.Monad.Reader 11 | import Data.Char (toLower) 12 | import qualified Data.Text as T 13 | import Data.Time 14 | import Text.Parsec 15 | 16 | import Calz.DateUtil 17 | import Calz.Types 18 | 19 | type M = ParsecT T.Text () (Reader Day) 20 | 21 | january :: Int 22 | january = 1 23 | 24 | text :: Monad m => T.Text -> ParsecT T.Text u m () 25 | text t = string (T.unpack t) *> return () 26 | 27 | spaces1 :: Stream s m Char => ParsecT s u m () 28 | spaces1 = skipMany1 space 29 | 30 | -- Collect information to make parsers for the three different month formats: 31 | -- 1 / "January" / "Jan" 32 | -- 33 | -- Input is like (1, ("January", "Jan")) 34 | -- Output is like [(1, "1"), (1, "january"), (1, "jan")] 35 | threeMonthReprs :: (Int, (String, String)) -> [(Int, String)] 36 | threeMonthReprs (mi, (longMonth, shortMonth)) = 37 | [(mi, show mi), (mi, map toLower longMonth), (mi, map toLower shortMonth)] 38 | 39 | allMonthParsers :: [M Int] 40 | allMonthParsers = 41 | map (\(i, s) -> string s >> return i) 42 | -- If the month string matches, return the Int for this month 43 | . concatMap threeMonthReprs 44 | -- Backwards so that we try to match '10', '11', and '12' before '1'. 45 | . zip [12, 11 .. 1] 46 | . reverse 47 | . months 48 | $ defaultTimeLocale 49 | 50 | month :: M Int 51 | month = choice . map try $ allMonthParsers 52 | 53 | year :: M Integer 54 | year = read <$> count 4 digit 55 | 56 | lastThisNext :: Integral a => M a 57 | lastThisNext = 58 | try (text "last" >> return (-1)) <|> try (text "this" >> return 0) <|> try 59 | (text "next" >> return 1) 60 | 61 | monthAndYearPhrase :: M DatePhrase 62 | monthAndYearPhrase = do 63 | m <- month 64 | spaces1 65 | y <- year 66 | let start = firstDayOfMonth (y, m) 67 | let end = addMonth start 68 | return $ DatePhrase start end 69 | 70 | monthPhrase :: M DatePhrase 71 | monthPhrase = do 72 | currYear <- asks getYear 73 | m <- month 74 | let start = firstDayOfMonth (currYear, m) 75 | let end = addMonth start 76 | return $ DatePhrase start end 77 | 78 | yearPhrase :: M DatePhrase 79 | yearPhrase = do 80 | y <- year 81 | let start = firstDayOfMonth (y, january) 82 | let end = addYear start 83 | return $ DatePhrase start end 84 | 85 | -- Alias for 'this month' 86 | todayNow :: M DatePhrase 87 | todayNow = do 88 | today <- ask 89 | _ <- try (text "today") <|> try (text "now") 90 | let start = thisMonth today 91 | let end = addMonth start 92 | return $ DatePhrase start end 93 | 94 | oneThruTen :: Integral a => M a 95 | oneThruTen = 96 | choice 97 | . map (try . makeParser) 98 | $ [ ("one" , 1) 99 | , ("two" , 2) 100 | , ("three", 3) 101 | , ("four" , 4) 102 | , ("five" , 5) 103 | , ("six" , 6) 104 | , ("seven", 7) 105 | , ("eight", 8) 106 | , ("nine" , 9) 107 | , ("ten" , 0) 108 | ] 109 | where 110 | makeParser :: Integral a => (T.Text, a) -> M a 111 | makeParser (t, i) = text t >> return i 112 | 113 | nUnits :: (Integral a, Read a) => T.Text -> M a 114 | nUnits unit = do 115 | number <* spaces1 <* text unit <* optional (char 's') 116 | where 117 | number :: (Integral a, Read a) => M a 118 | number = try (read <$> many1 digit) <|> try oneThruTen 119 | 120 | relativeUnit :: (Integral a, Read a) => T.Text -> M a 121 | relativeUnit unit = do 122 | try (lastThisNext <* spaces1 <* text unit) 123 | <|> try (nUnits unit <* spaces1 <* text "from" <* spaces1 <* todayNow) 124 | <|> try (negate <$> nUnits unit <* spaces1 <* text "ago") 125 | 126 | relativeMonths :: M DatePhrase 127 | relativeMonths = do 128 | today <- ask 129 | offset <- relativeUnit "month" 130 | let start = addGregorianMonthsClip offset . thisMonth $ today 131 | let end = addMonth start 132 | return $ DatePhrase start end 133 | 134 | relativeYears :: M DatePhrase 135 | relativeYears = do 136 | currYear <- asks getYear 137 | offset <- relativeUnit "year" 138 | let thisYear = firstDayOfMonth (currYear, january) 139 | let start = addGregorianMonthsClip (offset * 12) thisYear 140 | let end = addYear start 141 | return $ DatePhrase start end 142 | 143 | lastNextNMonths :: M DatePhrase 144 | lastNextNMonths = do 145 | today <- ask 146 | -- This is a clever trick: premultiply lastThisNext offset into 'n' 147 | -- (so nUnits can be forwards OR backwards) 148 | offset <- (*) <$> lastThisNext <*> (spaces1 *> nUnits "month") 149 | let thisMonth' = thisMonth today 150 | if offset < 0 151 | then do 152 | let start = addGregorianMonthsClip offset thisMonth' 153 | return $ DatePhrase start thisMonth' 154 | else do 155 | let end = addGregorianMonthsClip offset thisMonth' 156 | return $ DatePhrase thisMonth' end 157 | 158 | lastNextNYears :: M DatePhrase 159 | lastNextNYears = do 160 | currYear <- asks getYear 161 | -- This is a clever trick: premultiply lastThisNext offset into 'n' 162 | -- (so nUnits can be forwards OR backwards) 163 | offset <- (*) <$> lastThisNext <*> (spaces1 *> nUnits "year") 164 | let thisYear = firstDayOfMonth (currYear, january) 165 | if offset < 0 166 | then do 167 | let start = addGregorianMonthsClip (offset * 12) thisYear 168 | return $ DatePhrase start thisYear 169 | else do 170 | let end = addGregorianMonthsClip (offset * 12) thisYear 171 | return $ DatePhrase thisYear end 172 | 173 | simplePhrase :: M DatePhrase 174 | simplePhrase = 175 | try todayNow 176 | -- these phrases are more complex than below (more likely to fail) 177 | <|> try relativeMonths 178 | <|> try relativeYears 179 | <|> try lastNextNMonths 180 | <|> try lastNextNYears 181 | -- year before month, because year *must* be length 4, so it's more specific 182 | <|> try yearPhrase 183 | <|> try monthAndYearPhrase 184 | <|> try monthPhrase 185 | 186 | compoundPhrase :: M DatePhrase 187 | compoundPhrase = do 188 | optional (text "from" *> spaces1) 189 | DatePhrase startStart _ <- simplePhrase 190 | spaces1 *> text "to" *> spaces1 191 | DatePhrase _ endEnd <- simplePhrase 192 | return $ DatePhrase startStart endEnd 193 | 194 | simpleOrCompoundPhrase :: M DatePhrase 195 | simpleOrCompoundPhrase = try compoundPhrase <|> try simplePhrase 196 | 197 | parseWith :: Day -> M a -> T.Text -> Either ParseError a 198 | parseWith today parser phrase = 199 | runReader (runParserT parser () "(unknown)" (T.toLower phrase)) today 200 | 201 | -- | Just for testing; hard codes 18 Jan 2018 for convenience 202 | parseWithEof :: M a -> T.Text -> Either ParseError a 203 | parseWithEof parser = parseWith (fromGregorian 2018 01 18) (parser <* eof) 204 | 205 | parsePhrase :: Day -> T.Text -> Either ParseError DatePhrase 206 | parsePhrase today = 207 | parseWith today (spaces *> simpleOrCompoundPhrase <* spaces <* eof) 208 | -------------------------------------------------------------------------------- /src/Calz/Types.hs: -------------------------------------------------------------------------------- 1 | module Calz.Types where 2 | 3 | import Data.Time 4 | 5 | data Layout 6 | = Grid { columns :: Int } 7 | | Flow { separators :: Bool } 8 | deriving Show 9 | 10 | data Config = Config 11 | { optLayout :: Layout 12 | , optColor :: Bool 13 | , optHideLabels :: Bool 14 | , optHidePad :: Bool 15 | } 16 | deriving Show 17 | 18 | defaultConfig :: Config 19 | defaultConfig = Config 20 | { optLayout = Flow False 21 | , optColor = True 22 | , optHideLabels = False 23 | , optHidePad = False 24 | } 25 | 26 | data DatePhrase = DatePhrase 27 | { monthFrom :: Day -- ^ Inclusive 28 | , monthTo :: Day -- ^ Exclusive 29 | } 30 | deriving (Show, Eq) 31 | 32 | data Annotation 33 | = HeaderAnn 34 | | LabelAnn 35 | | TodayAnn 36 | | PaddedAnn 37 | | EndOfMonthAnn 38 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-10.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Calz/PhraseParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Calz.PhraseParserSpec where 5 | 6 | import Data.Either (either) 7 | import qualified Data.Text as T 8 | import Data.Time 9 | import Test.Hspec 10 | 11 | import Calz.PhraseParser 12 | import Calz.Types 13 | 14 | jan01_17, dec01_17, jan01, feb01, jan21, mar01, oct01, nov01, dec01, jan01_19, feb01_19, mar01_19, jan01_20, feb01_20, mar01_20, jan01_21 15 | :: Day 16 | jan01_17 = fromGregorian 2017 01 01 17 | dec01_17 = fromGregorian 2017 12 01 18 | jan01 = fromGregorian 2018 01 01 19 | feb01 = fromGregorian 2018 02 01 20 | jan21 = fromGregorian 2018 01 21 21 | mar01 = fromGregorian 2018 03 01 22 | oct01 = fromGregorian 2018 10 01 23 | nov01 = fromGregorian 2018 11 01 24 | dec01 = fromGregorian 2018 12 01 25 | jan01_19 = fromGregorian 2019 01 01 26 | feb01_19 = fromGregorian 2019 02 01 27 | mar01_19 = fromGregorian 2019 03 01 28 | jan01_20 = fromGregorian 2020 01 01 29 | feb01_20 = fromGregorian 2020 02 01 30 | mar01_20 = fromGregorian 2020 03 01 31 | jan01_21 = fromGregorian 2021 01 01 32 | 33 | good :: Day -> Day -> Maybe DatePhrase 34 | good from to = Just $ DatePhrase from to 35 | 36 | bad :: Maybe DatePhrase 37 | bad = Nothing 38 | 39 | testCases :: [(T.Text, Maybe DatePhrase)] 40 | testCases = 41 | [ ("1" , good jan01 feb01) 42 | , ("10" , good oct01 nov01) 43 | , ("12 2018" , good dec01 jan01_19) 44 | , ("12" , good dec01 jan01_19) 45 | , ("122018" , bad) 46 | , ("122108" , bad) 47 | , ("2 2020" , good feb01_20 mar01_20) 48 | , ("2" , good feb01 mar01) 49 | , ("2018" , good jan01 jan01_19) 50 | , ("2020 " , good jan01_20 jan01_21) 51 | , ("2020" , good jan01_20 jan01_21) 52 | , ("220" , bad) 53 | , ("dec 2018" , good dec01 jan01_19) 54 | , ("feb 2019" , good feb01_19 mar01_19) 55 | , ("feb" , good feb01 mar01) 56 | , ("feb2019" , bad) 57 | , ("from last month to next month", good dec01_17 mar01) 58 | , ("from last month to this month", good dec01_17 feb01) 59 | , ("last month to next month" , good dec01_17 mar01) 60 | , ("last month to this month" , good dec01_17 feb01) 61 | , ("jan" , good jan01 feb01) 62 | , ("last month" , good dec01_17 jan01) 63 | , ("last year" , good jan01_17 jan01) 64 | , ("last month" , good dec01_17 jan01) 65 | , ("lastmonth" , bad) 66 | , ("next year" , good jan01_19 jan01_20) 67 | , ("this month" , good jan01 feb01) 68 | , ("this month" , good jan01 feb01) 69 | , ("thismonth" , bad) 70 | ] 71 | 72 | toMaybe :: Either a b -> Maybe b 73 | toMaybe = either (const Nothing) Just 74 | 75 | inclExcl :: Maybe DatePhrase -> String 76 | inclExcl Nothing = "Nothing" 77 | inclExcl (Just (DatePhrase from to)) = 78 | "[" ++ (show from) ++ ", " ++ (show to) ++ ")" 79 | 80 | runTestCase :: (T.Text, Maybe DatePhrase) -> SpecWith () 81 | runTestCase (phrase, expected) = do 82 | it ("'" ++ (T.unpack phrase) ++ "' -> '" ++ (inclExcl expected) ++ "'") $ do 83 | toMaybe (parsePhrase jan21 phrase) `shouldBe` expected 84 | 85 | spec :: Spec 86 | spec = do 87 | describe "parsePhrase" $ do 88 | mapM_ runTestCase testCases 89 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------