iso8601-duration (empty) → 0.1.1.0
raw patch · 9 files changed
+533/−0 lines, 9 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed
Dependencies added: QuickCheck, attoparsec, base, bytestring, bytestring-lexing, hspec, hspec-core, iso8601-duration, quickcheck-instances, time
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- iso8601-duration.cabal +57/−0
- src/Data/Time/ISO8601/Duration.hs +170/−0
- src/Data/Time/ISO8601/Interval.hs +122/−0
- test/Data/Time/ISO8601/DurationSpec.hs +72/−0
- test/Data/Time/ISO8601/IntervalSpec.hs +74/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for iso8601-duration++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Niklas Hambüchen++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 Niklas Hambüchen 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
+ iso8601-duration.cabal view
@@ -0,0 +1,57 @@+-- Initial iso8601-duration.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: iso8601-duration+version: 0.1.1.0+synopsis: Types and parser for ISO8601 durations+description: Types and parser for ISO8601 durations and intervals+homepage: https://github.com/meteogrid/iso8601-duration+license: BSD3+license-file: LICENSE+author: Alberto Valverde (original code from Niklas Hambüchen?)+maintainer: alberto@meteogrid.com+copyright: 2016-2018 Alberto Valverde+category: Data+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Data.Time.ISO8601.Duration+ , Data.Time.ISO8601.Interval+ -- other-modules: + other-extensions: ScopedTypeVariables, OverloadedStrings+ build-depends: base >= 4.7 && < 4.12+ , bytestring >= 0.10 && < 0.11+ , attoparsec >= 0.13.1 && < 0.14+ , time >= 1.8 && < 1.9+ , bytestring-lexing >= 0.5 && < 0.6+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ -fwarn-incomplete-patterns+ -fwarn-incomplete-uni-patterns++test-suite spec+ type: exitcode-stdio-1.0+ build-depends: base+ , bytestring+ , time+ , hspec+ , hspec-core >= 1.13+ , QuickCheck+ , quickcheck-instances+ , iso8601-duration+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Data.Time.ISO8601.DurationSpec+ Data.Time.ISO8601.IntervalSpec+ default-language: Haskell2010+ ghc-options: -Wall+ -fwarn-incomplete-patterns+ -fwarn-incomplete-uni-patterns+++source-repository head+ type: git+ location: https://github.com/meteogrid/iso8601-duration
+ src/Data/Time/ISO8601/Duration.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++-- Stolen from https://gist.github.com/nh2/16c84db9d10e8869d8ae++module Data.Time.ISO8601.Duration (+ Duration (..)+ , DurDate (..)+ , DurTime (..)+ , DurYear (..)+ , DurMonth (..)+ , DurWeek (..)+ , DurDay (..)+ , DurHour (..)+ , DurMinute (..)+ , DurSecond (..)+ , parseDuration+ , duration+ , formatDuration+ , formatDurationB+ , addDuration+) where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Monoid ((<>))+import Data.String (IsString, fromString)+import Data.Time hiding (formatTime)++++newtype DurSecond = DurSecond Integer deriving (Eq, Ord, Show)+data DurMinute = DurMinute Integer (Maybe DurSecond) deriving (Eq, Ord, Show)+data DurHour = DurHour Integer (Maybe DurMinute) deriving (Eq, Ord, Show)+data DurTime = DurTimeHour DurHour+ | DurTimeMinute DurMinute+ | DurTimeSecond DurSecond deriving (Eq, Ord, Show)+newtype DurDay = DurDay Integer deriving (Eq, Ord, Show)+newtype DurWeek = DurWeek Integer deriving (Eq, Ord, Show)+data DurMonth = DurMonth Integer (Maybe DurDay) deriving (Eq, Ord, Show)+data DurYear = DurYear Integer (Maybe DurMonth) deriving (Eq, Ord, Show)+data DurDate = DurDateDay DurDay (Maybe DurTime)+ | DurDateMonth DurMonth (Maybe DurTime)+ | DurDateYear DurYear (Maybe DurTime) deriving (Eq, Ord, Show)++data Duration = DurationDate DurDate+ | DurationTime DurTime+ | DurationWeek DurWeek deriving (Eq, Ord, Show)+++durSecond :: Parser DurSecond+durMinute :: Parser DurMinute+durHour :: Parser DurHour+durTime :: Parser DurTime+durDay :: Parser DurDay+durWeek :: Parser DurWeek+durMonth :: Parser DurMonth+durYear :: Parser DurYear+durDate :: Parser DurDate+duration :: Parser Duration++durSecond = DurSecond <$> (decimal <* char 'S')+durMinute = DurMinute <$> (decimal <* char 'M') <*> optional durSecond+durHour = DurHour <$> (decimal <* char 'H') <*> optional durMinute+durTime = char 'T' *> ((DurTimeHour <$> durHour) <|>+ (DurTimeMinute <$> durMinute) <|>+ (DurTimeSecond <$> durSecond))+durDay = DurDay <$> (decimal <* char 'D')+durWeek = DurWeek <$> (decimal <* char 'W')+durMonth = DurMonth <$> (decimal <* char 'M') <*> optional durDay+durYear = DurYear <$> (decimal <* char 'Y') <*> optional durMonth+durDate = (DurDateDay <$> durDay <*> optional durTime) <|>+ (DurDateMonth <$> durMonth <*> optional durTime) <|>+ (DurDateYear <$> durYear <*> optional durTime)++duration = char 'P' *> ((DurationDate <$> durDate) <|>+ (DurationTime <$> durTime) <|>+ (DurationWeek <$> durWeek))+++parseDuration :: ByteString -> Either String Duration+parseDuration = parseOnly (duration <* endOfInput)+++formatDuration :: Duration -> ByteString+formatDuration = runBuilder . formatDurationB++formatDurationB :: Duration -> Builder+formatDurationB dur = "P" <> case dur of+ DurationDate date -> formatDate date+ DurationTime time -> formatTime time+ DurationWeek week -> formatWeek week+ where+ formatSecond (DurSecond second) = show' second <> "S"+ formatMinute (DurMinute minute mbSecond) =+ show' minute <> "M" <> maybe "" formatSecond mbSecond+ formatHour (DurHour hour mbMinute) =+ show' hour <> "H" <> maybe "" formatMinute mbMinute+ formatTime time = "T" <> case time of+ DurTimeSecond second -> formatSecond second+ DurTimeMinute minute -> formatMinute minute+ DurTimeHour hour -> formatHour hour+ formatDay (DurDay day) = show' day <> "D"+ formatWeek (DurWeek week) = show' week <> "W"+ formatMonth (DurMonth month mbDay) =+ show' month <> "M" <> maybe "" formatDay mbDay+ formatYear (DurYear year mbMonth) =+ show' year <> "Y" <> maybe "" formatMonth mbMonth+ formatDate date = case date of+ DurDateDay day mbTime -> formatDay day <> maybe "" formatTime mbTime+ DurDateMonth month mbTime -> formatMonth month <> maybe "" formatTime mbTime+ DurDateYear year mbTime -> formatYear year <> maybe "" formatTime mbTime++runBuilder :: Builder -> ByteString+runBuilder = LBS.toStrict . toLazyByteString++show' :: (Show a, IsString b) => a -> b+show' = fromString . show++++addDuration :: Duration -> UTCTime -> UTCTime+addDuration (DurationDate s) = addDurationDate s+addDuration (DurationTime s) = addDurationTime s+addDuration (DurationWeek s) = addDurationWeek s++addDurationDate :: DurDate -> UTCTime -> UTCTime+addDurationDate (DurDateDay d dt) =+ maybe id addDurationTime dt . addDurDay d++addDurationDate (DurDateMonth m dt) =+ maybe id addDurationTime dt . addDurMonth m++addDurationDate (DurDateYear y dt) =+ maybe id addDurationTime dt . addDurYear y++addDurDay :: DurDay -> UTCTime -> UTCTime+addDurDay (DurDay s) (UTCTime d dt) = UTCTime (addDays s d) dt++addDurMonth :: DurMonth -> UTCTime -> UTCTime+addDurMonth (DurMonth s m) (UTCTime d dt) =+ maybe id addDurDay m $+ UTCTime (addGregorianMonthsRollOver s d) dt++addDurYear :: DurYear -> UTCTime -> UTCTime+addDurYear (DurYear s m) (UTCTime d dt) =+ maybe id addDurMonth m $+ UTCTime (addGregorianYearsRollOver s d) dt+++addDurationTime :: DurTime -> UTCTime -> UTCTime+addDurationTime = addUTCTime . durTimeToNDT+ where+ durTimeToNDT (DurTimeHour s) = durHourToNDT s+ durTimeToNDT (DurTimeMinute s) = durMinuteToNDT s+ durTimeToNDT (DurTimeSecond s) = durSecondToNDT s++ durHourToNDT (DurHour s m) =+ fromIntegral (s * 60 * 60) + maybe 0 durMinuteToNDT m++ durMinuteToNDT (DurMinute s m) =+ fromIntegral (s * 60) + maybe 0 durSecondToNDT m++ durSecondToNDT (DurSecond s) = fromIntegral s++addDurationWeek :: DurWeek -> UTCTime -> UTCTime+addDurationWeek (DurWeek w) = addDurDay (DurDay (w*7))
+ src/Data/Time/ISO8601/Interval.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Time.ISO8601.Interval (+ IntervalSpec (..)+, Interval (..)+, interval+, isoTime+, parseInterval+, formatInterval+, formatIntervalB+) where++import Data.Time.ISO8601.Duration++import Control.Applicative+import Data.Attoparsec.ByteString (Parser)+import Data.Attoparsec.ByteString.Char8 as AP+import Data.ByteString.Lex.Integral (readDecimal)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Builder+import Data.Monoid ((<>))+import Data.String (IsString(..))+import Data.Time+import Data.Time.Calendar (fromGregorian)+import Data.Time.Calendar.WeekDate (fromWeekDateValid)+++data IntervalSpec+ = StartEnd UTCTime UTCTime+ | StartDuration UTCTime Duration+ | DurationEnd Duration UTCTime+ | JustDuration Duration+ deriving ( Eq, Show )++data Interval+ = Interval IntervalSpec+ | RecurringInterval IntervalSpec (Maybe Integer)+ deriving ( Eq, Show )++parseInterval :: ByteString -> Either String Interval+parseInterval = parseOnly (interval <* endOfInput)+++interval :: Parser Interval+interval = recurringInterval+ <|> simpleInterval+ where+ recurringInterval =+ flip RecurringInterval <$> (char 'R' *> optional decimal <* char '/')+ <*> intervalSpec+ simpleInterval = Interval <$> intervalSpec++intervalSpec :: Parser IntervalSpec+intervalSpec = startEnd+ <|> startDuration+ <|> durationEnd+ <|> justDuration+ where+ startEnd = StartEnd <$> isoTime <*> (char '/' *> isoTime)+ startDuration = StartDuration <$> isoTime <*> (char '/' *> duration)+ durationEnd = DurationEnd <$> duration <*> (char '/' *> isoTime)+ justDuration = JustDuration <$> duration+++isoTime :: Parser UTCTime+isoTime = do+ d <- dayWeek <|> day+ dt <- option 0 (oChar 'T' *> diffTime <* oChar 'Z') --FIXME: Parse tz offsets+ return (UTCTime d dt)++day :: Parser Day+day = day2 <|> day1+ where day1 = fromGregorian <$> decimalN 4+ <*> option 1 (char '-' *> intN 2)+ <*> option 1 (char '-' *> intN 2)+ day2 = fromGregorian <$> decimalN 4 <*> intN 2 <*> intN 2++dayWeek :: Parser Day+dayWeek = maybe (fail "Invalid week day") return =<< go+ where+ go = fromWeekDateValid+ <$> decimalN 4+ <*> ("-W" *> intN 2)+ <*> option 1 (char '-' *> intN 1)++diffTime :: Parser DiffTime+diffTime = do+ h <- fromIntegral <$> intN 2+ m <- fromIntegral <$> option 0 (oChar ':' *> intN 2)+ s <- maybe 0 realToFrac <$> optional (oChar ':' *> scientific)+ return (s + m*60 + h*3600)++intN :: Int -> Parser Int+intN = decimalN++decimalN :: Integral a => Int -> Parser a+decimalN n =+ maybe (fail "not an int") (return . fst) =<< fmap readDecimal (AP.take n)++oChar :: Char -> Parser (Maybe Char)+oChar = optional . char+++formatInterval :: Interval -> ByteString+formatInterval = toStrict . toLazyByteString . formatIntervalB++formatIntervalB :: Interval -> Builder+formatIntervalB (RecurringInterval i r) = "R" <> maybe "" bShow r <> "/"+ <> formatIntervalSpec i+formatIntervalB (Interval i) = formatIntervalSpec i++formatIntervalSpec :: IntervalSpec -> Builder+formatIntervalSpec (StartEnd s1 s2) = formatIsoTime s1 <> "/" <> formatIsoTime s2+formatIntervalSpec (StartDuration s1 s2) = formatIsoTime s1 <> "/" <> formatDurationB s2+formatIntervalSpec (DurationEnd s1 s2) = formatDurationB s1 <> "/" <> formatIsoTime s2+formatIntervalSpec (JustDuration s) = formatDurationB s++formatIsoTime :: UTCTime -> Builder+formatIsoTime = fromString . formatTime defaultTimeLocale "%FT%T%QZ"++bShow :: Show a => a -> Builder+bShow = fromString . show
+ test/Data/Time/ISO8601/DurationSpec.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Time.ISO8601.DurationSpec (main, spec) where++import Data.Time.ISO8601.Duration+import Data.Time+import qualified Data.ByteString.Char8 as BS8+import Data.String+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++main :: IO ()+main = hspec spec++spec :: Spec+spec = do++ describe "format/parse" $ do++ prop "is idempotent" $ \(dur :: Duration) ->+ counterexample (BS8.unpack (formatDuration dur)) $+ parseDuration (formatDuration dur) === Right dur++ describe "works on hand picked examples" $ do+ tryExample "P3Y6M4DT12H30M5S"+ tryExample "P6M4D"++ describe "addDuration" $ do+ itAddsDuration "P6D" (datetime 2016 11 22 13 14 0) (datetime 2016 11 28 13 14 0)+ itAddsDuration "P6DT5H4M" (datetime 2016 11 22 13 14 0) (datetime 2016 11 28 18 18 0)+ itAddsDuration "P6DT5H4M61S" (datetime 2016 11 22 13 14 0) (datetime 2016 11 28 18 19 1)+ itAddsDuration "P8W" (datetime 2016 11 22 13 14 0) (datetime 2017 1 17 13 14 0)++itAddsDuration :: Duration -> UTCTime -> UTCTime -> SpecWith (Arg Expectation)+itAddsDuration d t e = it msg $ d `addDuration` t `shouldBe` e where+ msg = show (formatDuration d) ++ " `addDuration` " ++ show t ++ " == " ++ show e+ +unsafeParseDuration :: BS8.ByteString -> Duration+unsafeParseDuration = either (const (error "unparsable")) id . parseDuration++datetime :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime+datetime y m d h m' s = UTCTime (fromGregorian y m d) (fromIntegral (h*3600+m'*60+s))++instance IsString Duration where+ fromString = unsafeParseDuration . fromString++tryExample :: BS8.ByteString -> SpecWith (Arg Expectation)+tryExample str = it ("parses " ++ BS8.unpack str) $+ fmap formatDuration (parseDuration str) `shouldBe` Right str+++instance Arbitrary DurSecond where arbitrary = DurSecond <$> (getPositive <$> arbitrary)+instance Arbitrary DurMinute where arbitrary = DurMinute <$> (getPositive <$> arbitrary) <*> arbitrary+instance Arbitrary DurHour where arbitrary = DurHour <$> (getPositive <$> arbitrary) <*> arbitrary+instance Arbitrary DurTime where arbitrary = oneof [ DurTimeHour <$> arbitrary+ , DurTimeMinute <$> arbitrary+ , DurTimeSecond <$> arbitrary+ ]+instance Arbitrary DurDay where arbitrary = DurDay <$> (getPositive <$> arbitrary)+instance Arbitrary DurWeek where arbitrary = DurWeek <$> (getPositive <$> arbitrary)+instance Arbitrary DurMonth where arbitrary = DurMonth <$> (getPositive <$> arbitrary) <*> arbitrary+instance Arbitrary DurYear where arbitrary = DurYear <$> (getPositive <$> arbitrary) <*> arbitrary+instance Arbitrary DurDate where arbitrary = oneof [ DurDateDay <$> arbitrary <*> arbitrary+ , DurDateMonth <$> arbitrary <*> arbitrary+ , DurDateYear <$> arbitrary <*> arbitrary+ ]+instance Arbitrary Duration where arbitrary = oneof [ DurationDate <$> arbitrary+ , DurationTime <$> arbitrary+ , DurationWeek <$> arbitrary+ ]
+ test/Data/Time/ISO8601/IntervalSpec.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Time.ISO8601.IntervalSpec (main, spec) where++-- For Duration Arbitrary instances+import Data.Time.ISO8601.DurationSpec ()+import Data.Time.ISO8601.Interval+import Data.Time++import qualified Data.ByteString.Char8 as BS8+import Data.Either (isLeft)+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck+import Test.QuickCheck.Instances ()++main :: IO ()+main = hspec spec++spec :: Spec+spec = do++ prop "format/parse is idempotent" $ \(int :: Interval) ->+ counterexample (BS8.unpack (formatInterval int)) $+ parseInterval (formatInterval int) === Right int++ describe "hand picked examples" $ do+ parseFormatIdempotent "P3Y6M4DT12H30M5S"+ parseFormatIdempotent "P6M4D"+ parseShouldSatisfy "20080229/P6M4D" $ \i ->+ case i of+ Interval (StartDuration t _) -> t == datetime 2008 2 29 0 0 0+ _ -> False+ shouldParse "R/2014-12T20/P1W"+ shouldNotParse "R/201412T20/P1W"+ shouldParse "R/2014/P1W"+ shouldParse "R1000/2014/P1W"+ shouldParse "R/2014-W01-1T19:00:00/P1W"+ shouldNotParse "R/2014-W1-1T19:00:00/P1W"+ shouldNotParse "R/2014-W01-8T19:00:00/P1W"+ shouldNotParse "R/2014-W54-1T19:00:00/P1W"++datetime :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime+datetime y m d h m' s = UTCTime (fromGregorian y m d) (fromIntegral (h*3600+m'*60+s))+++parseShouldSatisfy :: BS8.ByteString -> (Interval -> Bool) -> SpecWith (Arg Expectation)+parseShouldSatisfy str fun = it ("parses " ++ BS8.unpack str) $+ parseInterval str `shouldSatisfy` either (const False) fun++shouldParse :: BS8.ByteString -> SpecWith (Arg Expectation)+shouldParse str = parseShouldSatisfy str (const True)++shouldNotParse :: BS8.ByteString -> SpecWith (Arg Expectation)+shouldNotParse str = it ("does not parse " ++ BS8.unpack str) $+ parseInterval str `shouldSatisfy` isLeft++parseFormatIdempotent :: BS8.ByteString -> SpecWith (Arg Expectation)+parseFormatIdempotent str = it ("parse/format idempotent on " ++ BS8.unpack str) $+ fmap formatInterval (parseInterval str) `shouldBe` Right str+++instance Arbitrary Interval where+ arbitrary = oneof [ Interval <$> arbitrary+ , RecurringInterval <$> arbitrary <*> (fmap getPositive <$> arbitrary)+ ]++instance Arbitrary IntervalSpec where+ arbitrary = oneof [ StartEnd <$> arbitrary <*> arbitrary+ , StartDuration <$> arbitrary <*> arbitrary+ , DurationEnd <$> arbitrary <*> arbitrary+ , JustDuration <$> arbitrary+ ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}