Haskell module for parsing ISO8601 durations

iso6801-duration.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Data.Time.ISO8601.Duration where

import           Control.Applicative
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import           Data.Attoparsec.ByteString.Char8

import           Test.QuickCheck


data 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)
data DurDay    = DurDay    Integer                     deriving (Eq, Ord, Show)
data 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))


parseDurationBS :: ByteString -> Either String Duration
parseDurationBS = parseOnly (duration <* endOfInput)


parseDuration :: String -> Either String Duration
parseDuration = parseDurationBS . BS8.pack



formatDuration :: Duration -> String
formatDuration 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



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
                                                    ]

prop_formatParseIdempotent :: Property
prop_formatParseIdempotent = property $ \(dur :: Duration) ->
  counterexample (formatDuration dur) $
    parseDuration (formatDuration dur) === Right dur

-- Examples:
-- - "P1Y2M4DT5H6M7S"