module Hunt.Index.Schema.Normalize.Date
( normalize, denormalize
, isAnyDate
, isAnyDate'
, isTime
, nullDay
, showGYearMonth
, showGYear
, showGMonthDay
, showGMonth
, showGDay
, showTime
)
where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isDigit)
import Data.Function (on)
import Data.Ratio ((%))
import Data.Time (Day, DiffTime, UTCTime (..),
addUTCTime, fromGregorian)
import Text.Regex.XMLSchema.String
import Hunt.Utility
normalize :: Text -> Text
normalize t = fromMaybe t
(T.pack . normDateRep . showDateTime . toUTC <$> (readAnyDateM . T.unpack $ t))
where
normDateRep :: String -> String
normDateRep s
= if head' s == Just '-'
then ('-':) . fil . tail $ s
else fil s
where fil = filter (not . (`elem` "-T:"))
denormalize :: Text -> Text
denormalize t = T.concat [y1, y2, "-", m, "-", d, " ", h, ":", i, ":", s]
where
[y1,y2,m,d,h,i,s] = T.chunksOf 2 t
isAnyDate :: String -> Bool
isAnyDate s = any ($ s) $ map fst safeDateReaders
isAnyDate' :: String -> Bool
isAnyDate' s = fromMaybe False $ do
d <- readAnyDateM s
guard $ ((==s) . showDate . readAnyDate) s
return . not . isPrefixOf "-" . showDate . toUTC $ d
readAnyDate :: String -> Date
readAnyDate = fromJust . readAnyDateM
readAnyDateM :: String -> Maybe Date
readAnyDateM s = head' . catMaybes . map readDateM $ safeDateReaders
where
readDateM :: (String -> Bool, String -> Date) -> Maybe Date
readDateM (v, r) = guard (v s) >> return (r s)
safeDateReaders :: [(String -> Bool, String -> Date)]
safeDateReaders = zip validators readers
where
validators :: [String -> Bool]
validators = [ isDateTime, isDate, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay]
readers :: [String -> Date]
readers = [readDateTime, readDate, readGYearMonth, readGYear, readGMonthDay, readGMonth, readGDay]
data Date =
Date { _dUTCTime :: UTCTime
, _dTZ :: MaybeTimeZone
}
deriving (Show)
type MaybeTimeZone = Maybe Seconds
type Seconds = Int
instance Eq Date where
(==) = (==) `on` toUTCTime
instance Ord Date where
compare = compare `on` toUTCTime
mkDateTime :: Day -> DiffTime -> MaybeTimeZone -> Date
mkDateTime d t z
= Date (UTCTime d t) z
toUTCTime :: Date -> UTCTime
toUTCTime (Date d Nothing) = d
toUTCTime (Date d (Just tz)) = addUTCTime (fromInteger . toInteger $ tz) d
toUTC :: Date -> Date
toUTC d = Date (toUTCTime d) Nothing
isDateTime, isDate, isTime, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay :: String -> Bool
[isDateTime, isDate, isTime, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay]
= map matchRE rexDates
rexDates :: [Regex]
rexDates
= map rex [dateTime, date, time, gYearMonth, gYear, gMonthDay, gMonth, gDay]
where
dateTime = ymd ++ "T" ++ hms ++ tz
time = hms ++ tz
date = ymd ++ tz
gYearMonth = ym ++ tz
gYear = y ++ tz
gMonthDay = "--" ++ m2 ++ "-" ++ t2 ++ tz
gMonth = "--" ++ m2 ++ tz
gDay = "--" ++ "-" ++ t2 ++ tz
y = "-?" ++ y4'
ym = y ++ "-" ++ m2
ymd = ym ++ "-" ++ t2
hms = alt (h2 ++ ":" ++ i2 ++ ":" ++ s2 ++ fr)
("24:00:00" ++ opt ".0+")
tz = opt (alt tz0 "Z")
tz0 = (alt "\\-" "\\+") ++ tz1
tz1 = alt (h13 ++ ":" ++ i2) "14:00:00"
m2 = alt "0[1-9]" "1[0-2]"
t2 = alt "0[1-9]" (alt "[12][0-9]" "3[01]")
h2 = alt "[01][0-9]" "2[0-3]"
i2 = "[0-5][0-9]"
s2 = i2
y4 = "[0-9]{4}"
y4' = opt "[1-9][0-9]*" ++ y4
fr = opt ".[0-9]+"
h13 = alt "0[0-9]" "1[0-3]"
opt x = "(" ++ x ++ ")?"
alt x1 x2 = "((" ++ x1 ++ ")|(" ++ x2 ++ "))"
readDate
, readGYearMonth
, readGYear
, readGMonthDay
, readGMonth
, readGDay :: String -> Date
readDate = readDate' readYearMonthDayS
readGYearMonth = readDate' readYearMonthS
readGYear = readDate' readYearS
readGMonthDay = readDate' readMonthDayS
readGMonth = readDate' readMonthS
readGDay = readDate' readDayS
readTimeZone :: String -> MaybeTimeZone
readTimeZone ""
= Nothing
readTimeZone "Z"
= Just 0
readTimeZone (s : xs)
= Just .
( if s == '-' then negate else id ) .
readZone $ xs
where
readZone s'
= 60 * (60 * read hs + read ms)
where
(hs, (_ : ms)) = span (/= ':') s'
readYearMonthDayS :: String -> (Day, String)
readYearMonthDayS s0
= (fromGregorian (sign $ read year) (read month) (read day), rest)
where
(sign, s ) = if head s0 == '-'
then (negate, tail s0)
else (id, s0)
(year, (_ : rest1)) = span (/= '-') s
(month, (_ : rest2)) = span (/= '-') rest1
(day, rest ) = span isDigit rest2
readYearMonthS :: String -> (Day, String)
readYearMonthS s0
= (fromGregorian (sign $ read year) (read month) 1, rest)
where
(sign, s ) = if head s0 == '-'
then (negate, tail s0)
else (id, s0)
(year, (_ : rest1)) = span (/= '-') s
(month, rest ) = span isDigit rest1
readYearS :: String -> (Day, String)
readYearS s0
= (fromGregorian (sign $ read year) 1 1, rest)
where
(sign, s ) = if head s0 == '-'
then (negate, tail s0)
else (id, s0)
(year, rest ) = span isDigit s
readMonthDayS :: String -> (Day, String)
readMonthDayS s0
= (fromGregorian 1 (read month) (read day), rest)
where
(month, (_ : rest1)) = span isDigit . drop 2 $ s0
(day, rest ) = span isDigit rest1
readMonthS :: String -> (Day, String)
readMonthS s0
= (fromGregorian 1 (read month) 1, rest)
where
(month, rest ) = span isDigit . drop 2 $ s0
readDayS :: String -> (Day, String)
readDayS s0
= (fromGregorian 1 1 (read day), rest)
where
(day, rest ) = span isDigit . drop 3 $ s0
readHourMinSec :: String -> DiffTime
readHourMinSec s
= fromInteger (60 * (60 * read hours + read minutes))
+
fromRational (readDecimal seconds)
where
(hours, (_ : rest)) = span (/= ':') s
(minutes, (_ : seconds)) = span (/= ':') rest
readDateTime :: String -> Date
readDateTime s
= mkDateTime day (readHourMinSec time) (readTimeZone zone)
where
(day, (_ : rest)) = readYearMonthDayS s
(time, zone) = span (\ x -> isDigit x || x `elem` ":.") rest
readDate' :: (String -> (Day, String)) -> String -> Date
readDate' read' s
= mkDateTime day nullTime (readTimeZone zone)
where
(day, zone) = read' s
nullTime :: DiffTime
nullTime = fromInteger 0
nullDay :: Day
nullDay = fromGregorian 1 1 1
readDecimal :: String -> Rational
readDecimal ('+':s) = readDecimal' s
readDecimal ('-':s) = negate $ readDecimal' s
readDecimal s = readDecimal' s
readDecimal' :: String -> Rational
readDecimal' s
| f == 0 = (n % 1)
| otherwise = (n % 1) + (f % (10 ^ (toInteger $ length fs)))
where
(ns, fs') = span (/= '.') s
fs = drop 1 fs'
f :: Integer
f | null fs = 0
| otherwise = read fs
n :: Integer
n | null ns = 0
| otherwise = read ns
showDateTime :: Date -> String
showDateTime (Date d tz)
= ymd ++ "T" ++ hms ++ showTimeZone tz
where
(ymd : hms : _) = words . show $ d
showDate' :: (String -> String) -> Date -> String
showDate' fmt (Date d tz)
= fmt ymd ++ showTimeZone tz
where
(ymd : _) = words . show $ d
dropRev :: Int -> String -> String
dropRev i = reverse . drop i . reverse
showDate :: Date -> String
showDate = showDate' $ id
showGYearMonth :: Date -> String
showGYearMonth = showDate' $ dropRev 3
showGYear :: Date -> String
showGYear = showDate' $ dropRev 6
showGMonthDay :: Date -> String
showGMonthDay = showDate' $ ('-' :) . reverse . take 6 . reverse
showGMonth :: Date -> String
showGMonth = showDate' $ ('-' :) . reverse . take 3 . drop 3 . reverse
showGDay :: Date -> String
showGDay = showDate' $ ('-' :) . ('-' :) . reverse . take 3 . reverse
showTime :: Date -> String
showTime (Date d tz)
= hms ++ showTimeZone tz
where
(_ymd : hms : _) = words . show $ d
showTimeZone :: MaybeTimeZone -> String
showTimeZone Nothing
= ""
showTimeZone (Just s)
| s == 0 = "Z"
| s > 0 = '+' : showHourMin s
| otherwise = '-' : showHourMin (negate s)
showHourMin :: Int -> String
showHourMin s0
= showDec 2 (s `div` 60) ++ ":" ++ showDec 2 (s `mod` 60)
where
s = s0 `div` 60
showDec :: Int -> Int -> String
showDec n = reverse . toStr n
where
toStr 0 _ = ""
toStr l i = show (i `mod` 10) ++ toStr (l1) (i `div` 10)
rex :: String -> Regex
rex regex
| isZero ex = error $ "syntax error in regexp " ++ show regex ++ "."
| otherwise = ex
where
ex = parseRegex regex