module Data.Microformats2.Parser.Date where
import Prelude.Compat
import Control.Applicative
import Control.Monad
import Control.Error.Util (hush)
import Text.Printf
import Data.Maybe
import Data.Foldable
import Data.Attoparsec.Text
import qualified Data.Time.Calendar as C
import qualified Data.Time.Calendar.OrdinalDate as O
import qualified Data.Text as T
data Date = Date Int Int Int
instance Show Date where
show (Date y m d) = printf "%d-%02d-%02d" y m d
data HourType = TwentyFourHour | AMHour | PMHour
data Time = Time Int Int Int
instance Show Time where
show (Time h m s) = printf "%02d:%02d:%02d" h m s
data DateTime = DateTime Date Time
instance Show DateTime where
show (DateTime d t) = show d ++ "T" ++ show t
data ZoneType = Plus | Minus
data Zone = Zone ZoneType Int Int
instance Show Zone where
show (Zone Plus h m) = printf "+%02d:%02d" h m
show (Zone Minus h m) = printf "-%02d:%02d" h m
data TimeZone = TimeZone Time Zone
instance Show TimeZone where
show (TimeZone t z) = show t ++ show z
data DateTimeZone = DateTimeZone DateTime Zone
instance Show DateTimeZone where
show (DateTimeZone dt z) = show dt ++ show z
data DTPart = DatePart Date | TimePart Time | ZonePart Zone | TimeZonePart TimeZone | DateTimePart DateTime | DateTimeZonePart DateTimeZone
instance Show DTPart where
show (DatePart d) = show d
show (TimePart t) = show t
show (ZonePart z) = show z
show (TimeZonePart tz) = show tz
show (DateTimePart dt) = show dt
show (DateTimeZonePart dtz) = show dtz
isDatePart, isTimePart, isZonePart, isTimeZonePart, isDateTimePart, isDateTimeZonePart ∷ DTPart → Bool
isDatePart (DatePart _) = True
isDatePart _ = False
isTimePart (TimePart _) = True
isTimePart _ = False
isZonePart (ZonePart _) = True
isZonePart _ = False
isTimeZonePart (TimeZonePart _) = True
isTimeZonePart _ = False
isDateTimePart (DateTimePart _) = True
isDateTimePart _ = False
isDateTimeZonePart (DateTimeZonePart _) = True
isDateTimeZonePart _ = False
parseDate ∷ Parser Date
parseDate = parseDate'
where parseDate' = do
year ← read <$> count 4 digit
char '-'
parseMMDD year <|> parseDDD year
parseMMDD year = do
mm ← read <$> count 2 digit
char '-'
dd ← read <$> count 2 digit
return $ Date year mm dd
parseDDD year = do
ddd ← read <$> count 3 digit
let (_, mm, dd) = C.toGregorian $ O.fromOrdinalDate (fromIntegral year) ddd
return $ Date year mm dd
parseHourType ∷ Parser HourType
parseHourType =
((char 'a' <|> char 'A') >> option '.' (char '.') >> (char 'm' <|> char 'M') >> option '.' (char '.') >> return AMHour)
<|> ((char 'p' <|> char 'P') >> option '.' (char '.') >> (char 'm' <|> char 'M') >> option '.' (char '.') >> return PMHour)
parseTime ∷ Parser Time
parseTime = do
hrs ← read <$> count 2 digit
mins ← option 0 $ char ':' >> read <$> count 2 digit
secs ← option 0 $ char ':' >> read <$> count 2 digit
htyp ← option TwentyFourHour $ parseHourType
let hrs' = case (hrs, htyp) of
(12, AMHour) → 00
(x, PMHour) | x < 12 → x + 12
(x, _) → x
return $ Time hrs' mins secs
parseZone ∷ Parser Zone
parseZone = (char 'Z' >> return (Zone Plus 0 0)) <|> parseZone'
where parseZone' = do
htyp ← (char '+' >> return Plus) <|> (char '-' >> return Minus)
hrs ← read <$> count 2 digit
mins ← option 0 $ option ':' (char ':') >> read <$> count 2 digit
return $ Zone htyp hrs mins
parseTimeZone ∷ Parser TimeZone
parseTimeZone = do
t ← parseTime
z ← parseZone
return $ TimeZone t z
parseDateTime ∷ Parser DateTime
parseDateTime = do
d ← parseDate
option 'T' $ char 'T' <|> char ' '
t ← parseTime
return $ DateTime d t
parseDateTimeZone ∷ Parser DateTimeZone
parseDateTimeZone = do
dt ← parseDateTime
z ← parseZone
return $ DateTimeZone dt z
parseDTPart ∷ Parser DTPart
parseDTPart =
(liftM DateTimeZonePart parseDateTimeZone)
<|> (liftM DateTimePart parseDateTime)
<|> (liftM DatePart parseDate)
<|> (liftM TimeZonePart parseTimeZone)
<|> (liftM TimePart parseTime)
<|> (liftM ZonePart parseZone)
parseDTParts ∷ (Traversable φ, Monoid (φ DTPart)) ⇒ φ T.Text → φ DTPart
parseDTParts = fromMaybe mempty . sequence . fmap (hush . parseOnly parseDTPart)
normalizeDTParts ∷ (Foldable φ) ⇒ φ DTPart → Maybe DTPart
normalizeDTParts ps = asum [ find isDateTimeZonePart ps, findDateTime, findDateAndTime, find isDatePart ps, find isTimeZonePart ps, find isTimePart ps ]
where findDateTime = do
(DateTimePart dt) ← find isDateTimePart ps
return $ case find isZonePart ps of
Just (ZonePart z) → DateTimeZonePart $ DateTimeZone dt z
_ → DateTimePart dt
findDateAndTime = do
(DatePart d) ← find isDatePart ps
case find isTimeZonePart ps of
Just (TimeZonePart (TimeZone t z)) → return $ DateTimeZonePart $ DateTimeZone (DateTime d t) z
_ → findTime d
findTime d = do
(TimePart t) ← find isTimePart ps
return $ case find isZonePart ps of
Just (ZonePart z) → DateTimeZonePart $ DateTimeZone (DateTime d t) z
_ → DateTimePart $ DateTime d t