period (empty) → 0.1.0.0

raw patch · 6 files changed

+334/−0 lines, 6 filesdep +HUnitdep +basedep +hspecsetup-changed

Dependencies added: HUnit, base, hspec, optparse-applicative, parsec, period, text, text-show, time

Files

LICENSE +30/−0
Setup.hs +2/−0
exec/period.hs +43/−0
period.cabal +54/−0
src/Text/Period.hs +159/−0
test/Spec.hs +46/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2015, Alexey Karakulov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Alexey Karakulov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ exec/period.hs view

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Text.Period+import Options.Applicative+import qualified Data.Text as T+import qualified Data.Text.IO as T++main :: IO ()+main = execParser (info (helper <*> optParser) $ progDesc "period") >>= runCommand++data Command+  = Collapse PeriodFmt T.Text+  | Expand PeriodFmt T.Text++periodArg :: Parser T.Text+periodArg = argument (T.pack <$> str) (metavar "PERIOD")++parseFmt :: Parser PeriodFmt+parseFmt = PeriodFmt <$>+  option (T.pack <$> str) (+    short 'f' <> long "field-sep" <> value "-" <>+    help "Field separator, by default '-' as in 'yyyy-mm-dd'") <*>+  option (T.pack <$> str) (+    short 'd' <> long "date-sep" <> value "," <>+    help "Field separator, by default ',' as in 'yyyy-mm-dd,yyyy-mm-dd'")+++mkCommand :: String -> String -> Parser Command -> Mod CommandFields Command+mkCommand cmd desc parser =+  command cmd $ info (helper <*> parser) (progDesc desc)++optParser :: Parser Command+optParser = subparser $ mconcat $+  [ mkCommand "collapse" "Find shortest representation for time period" $+    Collapse <$> parseFmt <*> periodArg+  , mkCommand "expand" "Display start and end points of time period" $+    Expand <$> parseFmt <*> periodArg+  ]++runCommand :: Command -> IO ()+runCommand (Collapse fmt per) = T.putStrLn $ collapsePeriod fmt $ parsePeriod per+runCommand (Expand fmt per) = T.putStrLn $ formatPeriod fmt $ parsePeriod per

+ period.cabal view

@@ -0,0 +1,54 @@+name:                period+version:             0.1.0.0+synopsis:            Parse and format date periods, collapse and expand their text representations.+-- description:         +homepage:            https://github.com/w3rs/period+license:             BSD3+license-file:        LICENSE+author:              Alexey Karakulov+maintainer:          ankarakulov@gmail.com+-- copyright:           +category:            Text+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Text.Period+  build-depends:+                base >=4.6 && < 5,+                time >=1.4,+                text >= 1.2,+                text-show >= 2,+                parsec >= 3.1+  hs-source-dirs:      src+  default-language:    Haskell2010+  GHC-options: -Wall++test-suite test+  main-is:             Spec.hs+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  default-language:    Haskell2010+  build-depends:+                base,+                period,+                text,+                hspec,+                HUnit,+                time++executable period+  main-is: period.hs+  hs-source-dirs: exec/+  default-language: Haskell2010+  build-depends:+                period,+                base,+                text,+                optparse-applicative+  GHC-options: -Wall -O2++source-repository head+  type: git+  location: git://github.com/w3rs/period.git

+ src/Text/Period.hs view

@@ -0,0 +1,159 @@+{-# LANGUAGE LambdaCase   #-}+{-# LANGUAGE MultiWayIf   #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.Period+ ( Period, PeriodFmt(..), parsePeriod, parsePeriodMay, parsePeriodEither+ , formatPeriod, collapsePeriod+ )where++import           Control.Arrow+import           Control.Monad+import           Data.Char+import           Data.Monoid ((<>))+import qualified Data.Text as T+import           Data.Time+import           TextShow (showt)++import           Text.Parsec.Char+import           Text.Parsec.Combinator+import           Text.Parsec.Prim+import           Text.Parsec.Text+++type Period = (Day, Day)++data PeriodFmt = PeriodFmt+  { perFieldSep :: T.Text -- ^ Separator between year, month and day+  , perDateSep :: T.Text -- ^ Separator between dates in the range, e.g. comma+                         -- in @yyyy-mm-dd,yyyy-mm-dd@+  }++data ParseState+  = StateYear Integer+  | StateMonth Integer Int+  | StateDay Integer Int Int+  | StateNone++number :: (Read a, Integral a) => Int -> Parser a+number n = read <$> count n digit++skipFieldSep :: Stream s m Char => Bool -> T.Text -> ParsecT s u m ()+skipFieldSep b sep = when b (string (T.unpack sep)>> return ())++-- | Parse period from text representation, which can be either simple date+-- range (@yyyy-mm-dd,yyyy-mm-dd@) or something shorter like @yyyy,yyyy@, or even+-- something like @yyyy-01-23,03-21@ which corresponds to+-- @yyyy-01-23,yyyy-03-21@. The list of possible combinations can be found in+-- @test/Spec.hs@.+--+-- 'parsePeriod' understands dash as field separator (like @yyyy-mm-dd@), or+-- accepts short date format (@yyyymmdd@). It+-- understands comma and underscore as separators between+-- dashed dates (@yyyy-mm-dd@) and dash as separator between short dates (@yyyymmdd@).+--+-- 'parsePeriod' produces error on unparsable input.+parsePeriod :: T.Text -> Period+parsePeriod = either (error . show) id . parse period "parsePeriod"++-- | Safe analogue of 'parsePeriod' using Maybe+parsePeriodMay :: T.Text -> Maybe Period+parsePeriodMay = either (const Nothing) Just . parse period ""++-- | Safe analogue of 'parsePeriod' using Either+parsePeriodEither :: T.Text -> Either String Period+parsePeriodEither = either (Left . show) Right . parse period "parsePeriod"++period :: Parser Period+period =+  try (rangePeriod '-' "") <|>+  try (rangePeriod '_' "-") <|>+  try (rangePeriod ',' "-") <|>+  try (primPeriod "" <* eof) <|>+  try (primPeriod "-" <* eof) <|>+  (quarter <* eof)++rangePeriod :: Char -> T.Text -> Parser Period+rangePeriod sep fmt = do+  s1 <- prim StateNone True+  _ <- char sep+  s2 <- foldr (<|>) (prim StateNone True <* eof) $+    [try (prim s False <* eof) | s <- states s1]+  return (startDay s1, endDay s2)+  where+  prim = primPeriod' fmt+  states (StateMonth y _) = [StateYear y]+  states (StateDay y m _) = [StateMonth y m, StateYear y]+  states _ = []++startDay :: ParseState -> Day+startDay StateNone = error "startDay StateNone"+startDay (StateYear y) = fromGregorian y 1 1+startDay (StateMonth y m) = fromGregorian y m 1+startDay (StateDay y m d) = fromGregorian y m d++endDay :: ParseState -> Day+endDay StateNone = error "endDay StateNone"+endDay (StateYear y) = fromGregorian y 12 31+endDay (StateMonth y m) = fromGregorian y m 31+endDay (StateDay y m d) = fromGregorian y m d++primPeriod :: T.Text -> Parser Period+primPeriod fmt = (startDay &&& endDay) <$> primPeriod' fmt StateNone True++primPeriod' :: T.Text -> ParseState -> Bool -> Parser ParseState+primPeriod' fmt StateNone _ = do+  s <- StateYear <$> number 4+  primPeriod' fmt s True <|> return s+primPeriod' fmt (StateYear y) skip = do+  skipFieldSep skip fmt+  s <- StateMonth y <$> number 2+  primPeriod' fmt s True <|> return s+primPeriod' fmt (StateMonth y m) skip = do+  skipFieldSep skip fmt+  StateDay y m <$> number 2+primPeriod' _ (StateDay _ _ _) _ = unexpected "primPeriod': StateDay"++quarter :: Parser Period+quarter = do+  y <- number 4+  _ <- char 'Q'+  q <- digitToInt <$> digit+  return (fromGregorian y (q * 3 - 2) 1, fromGregorian y (q * 3) 31)++-- | Format a period in the shortest fashion, e.g. collapse @yyyy-01-01,yyyy-01-31@+-- to @yyyy-01@+collapsePeriod :: PeriodFmt -> Period -> T.Text+collapsePeriod (PeriodFmt fieldSep sep) (start, end) = if+  | m1 == 1, d1 == 1, m2 == 12, d2 == 31 -> if+      | y1 == y2 -> showt y1+      | otherwise -> showt y1 <> sep <> showt y2+  | d1 == 1, end == monthEnd start -> format yyyymm start+  | d1 == 1, end == quarterEnd start -> showt y1 <> "Q" <> showt q+  | start == end -> format yyyymmdd start+  | otherwise -> format yyyymmdd start <> sep <> format yyyymmdd end+  where+  format f = T.pack . formatTime defaultTimeLocale f+  (y1, m1, d1) = toGregorian start+  (y2, m2, d2) = toGregorian end+  q = (m1 - 1) `div` 3 + 1+  yyyymm = T.unpack $ "%Y" <> fieldSep <> "%m"+  yyyymmdd = T.unpack $ "%Y" <> fieldSep <> "%m" <> fieldSep <> "%d"++-- | Format a period as a simple date range, e.g. @yyyy-mm-dd,yyyy-mm-dd@+formatPeriod :: PeriodFmt -> Period -> T.Text+formatPeriod (PeriodFmt fieldSep sep) (start, end) =+  format start <> sep <> format end+  where+  format = T.pack . formatTime defaultTimeLocale yyyymmdd+  yyyymmdd = T.unpack $ "%Y" <> fieldSep <> "%m" <> fieldSep <> "%d"++monthEnd :: Day -> Day+monthEnd = pred . addGregorianMonthsClip 1++quarterEnd :: Day -> Day+quarterEnd =  pred . addGregorianMonthsClip 3

+ test/Spec.hs view

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Time+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.HUnit ((@?=))+import qualified Data.Text as T+import Text.Period++main :: IO ()+main = hspec $ do+    describe "Primitive" $ do+      parse "2015" (2015,01,01) (2015,12,31)+      parse "201501" (2015,01,01) (2015,01,31)+      parse "20150131" (2015,01,31) (2015,01,31)+      parse "2015-01" (2015,01,01) (2015,01,31)+      parse "2015-01-31" (2015,01,31) (2015,01,31)+    describe "Quarters" $ do+      parse "2015Q1" (2015,01,01) (2015,03,31)+      parse "2015Q2" (2015,04,01) (2015,06,31)+      parse "2015Q3" (2015,07,01) (2015,09,31)+      parse "2015Q4" (2015,10,01) (2015,12,31)+    describe "Simple ranges" $ do+      parse "2014_2015" (2014,01,01) (2015,12,31)+      parse "2014-2015" (2014,01,01) (2015,12,31)+      parse "201406-201502" (2014,06,01) (2015,02,28)+      parse "2014-06_2015-02" (2014,06,01) (2015,02,28)+      parse "20140601-20150314" (2014,06,01) (2015,03,14)+      parse "2014-06-01_2015-03-14" (2014,06,01) (2015,03,14)+    describe "Ranges within same year" $ do+      parse "2015-02_05" (2015,02,01) (2015,05,31)+      parse "2015-02-22_05-11" (2015,02,22) (2015,05,11)+    describe "Ranges within same month" $ do+      parse "2015-01-22_31" (2015,01,22) (2015,01,31)+    describe "Unparsable" $ do+      failOn "201501_201502"+      failOn "20140601_20150314"++  where+  parse per (y1,m1,d1) (y2,m2,d2) = specify per $+    parsePeriod (T.pack per) @?=(fromGregorian y1 m1 d1, fromGregorian y2 m2 d2)+  failOn per = specify per $ parsePeriodMay (T.pack per) @?= Nothing++