diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Oleg Grenrus + +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 Oleg Grenrus 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# time-parsers + +[![Build Status](https://travis-ci.org/phadej/time-parsers.svg?branch=master)](https://travis-ci.org/phadej/time-parsers) +[![Hackage](https://img.shields.io/hackage/v/time-parsers.svg)](http://hackage.haskell.org/package/time-parsers) +[![Stackage LTS 2](http://stackage.org/package/time-parsers/badge/lts-2)](http://stackage.org/lts-2/package/time-parsers) +[![Stackage LTS 3](http://stackage.org/package/time-parsers/badge/lts-3)](http://stackage.org/lts-3/package/time-parsers) +[![Stackage Nightly](http://stackage.org/package/time-parsers/badge/nightly)](http://stackage.org/nightly/package/time-parsers) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/src/Data/Time/Parsers.hs b/src/Data/Time/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Parsers.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Data.Time.Parsers (Data.Aeson.Parser.Time) +-- Copyright: (c) 2015 Bryan O'Sullivan, 2015 Oleg Grenrus +-- License: BSD3 +-- Maintainer: Oleg Grenrus +-- +-- Parsers for parsing dates and times. + +module Data.Time.Parsers + ( day + , localTime + , timeOfDay + , timeZone + , utcTime + , zonedTime + , DateParsing + ) where + +import Control.Applicative (optional, some) +import Control.Monad (void, when) +import Data.Bits ((.&.)) +import Data.Char (isDigit, ord) +import Data.Fixed (Pico) +import Data.Int (Int64) +import Data.List (foldl') +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, fromGregorianValid) +import Data.Time.Clock (UTCTime (..)) +import Text.Parser.Char (CharParsing (..), digit) +import Text.Parser.LookAhead (LookAheadParsing (..)) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Time.LocalTime as Local + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((*>), (<$>), (<*), (<*>)) +#endif + +type DateParsing m = (CharParsing m, LookAheadParsing m, Monad m) + +toPico :: Integer -> Pico +toPico = unsafeCoerce + +-- | Parse a date of the form @YYYY-MM-DD@. +day :: DateParsing m => m Day +day = do + y <- decimal <* char '-' + m <- twoDigits <* char '-' + d <- twoDigits + maybe (fail "invalid date") return (fromGregorianValid y m d) + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: DateParsing m => m Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + +-- | Parse a time of the form @HH:MM:SS[.SSS]@. +timeOfDay :: DateParsing m => m Local.TimeOfDay +timeOfDay = do + h <- twoDigits <* char ':' + m <- twoDigits <* char ':' + s <- seconds + if h < 24 && m < 60 && s < 61 + then return (Local.TimeOfDay h m s) + else fail "invalid time" + +data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64 + +-- | Parse a count of seconds, with the integer part being two digits +-- long. +seconds :: DateParsing m => m Pico +seconds = do + real <- twoDigits + mc <- peekChar + case mc of + Just '.' -> do + t <- anyChar *> some digit + return $! parsePicos real t + _ -> return $! fromIntegral real + where + parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) + where T n t' = foldl' step (T 12 (fromIntegral a0)) t + step ma@(T m a) c + | m <= 0 = ma + | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15) + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZone :: DateParsing m => m (Maybe Local.TimeZone) +timeZone = do + let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar) + maybeSkip ' ' + ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + mm <- peekChar + m <- case mm of + Just ':' -> anyChar *> twoDigits + Just d | isDigit d -> twoDigits + _ -> return 0 + let off | ch == '-' = negate off0 + | otherwise = off0 + off0 = h * 60 + m + case undefined of + _ | off == 0 -> + return Nothing + | off < -720 || off > 840 || m > 59 -> + fail "invalid time zone offset" + | otherwise -> + let !tz = Local.minutesToTimeZone off + in return (Just tz) + +-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. +-- The space may be replaced with a @T@. The number of seconds may be +-- followed by a fractional component. +localTime :: DateParsing m => m Local.LocalTime +localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay + where daySep = satisfy (\c -> c == 'T' || c == ' ') + +-- | Behaves as 'zonedTime', but converts any time zone offset into a +-- UTC time. +utcTime :: DateParsing m => m UTCTime +utcTime = f <$> localTime <*> timeZone + where + f :: Local.LocalTime -> Maybe Local.TimeZone -> UTCTime + f (Local.LocalTime d t) Nothing = + let !tt = Local.timeOfDayToTime t + in UTCTime d tt + f lt (Just tz) = Local.localTimeToUTC tz lt + +-- | Parse a date with time zone info. Acceptable formats: +-- +-- @YYYY-MM-DD HH:MM:SS Z@ +-- +-- The first space may instead be a @T@, and the second space is +-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a +-- time zone offset of the form @+0000@ or @-08:00@, where the first +-- two digits are hours, the @:@ is optional and the second two digits +-- (also optional) are minutes. +zonedTime :: DateParsing m => m Local.ZonedTime +zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) + +utc :: Local.TimeZone +utc = Local.TimeZone 0 False "" + +decimal :: (DateParsing m, Integral a) => m a +decimal = foldl' step 0 `fmap` some digit + where step a w = a * 10 + fromIntegral (ord w - 48) + +peekChar :: DateParsing m => m (Maybe Char) +peekChar = optional peekChar' + +peekChar' :: DateParsing m => m Char +peekChar' = lookAhead anyChar diff --git a/src/Data/Time/TH.hs b/src/Data/Time/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/TH.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Template Haskell extras for `Data.Time`. +module Data.Time.TH (mkUTCTime) where + +import Data.Time (Day (..), UTCTime (..)) +import Data.Time.Parsers (utcTime) +import Language.Haskell.TH (Exp, Q, integerL, litE, rationalL) +import Text.ParserCombinators.ReadP (readP_to_S) + +-- | Make a 'UTCTime'. Accepts the same strings as `utcTime` parser accepts. +-- +-- > t :: UTCTime +-- > t = $(mkUTCTime "2014-05-12 00:02:03.456000Z") +-- +-- /Since: 0.2.3.0/ +mkUTCTime :: String -> Q Exp +mkUTCTime s = + case readP_to_S utcTime s of + [(UTCTime (ModifiedJulianDay d) dt, "")] -> + [| UTCTime (ModifiedJulianDay $(d')) $(dt') :: UTCTime |] + where d' = litE $ integerL d + dt' = litE $ rationalL $ toRational dt + _ -> error $ "Cannot parse date: " ++ s diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Bifunctor (first) +import Data.Time (Day (..), UTCTime (..)) + +import qualified Data.Attoparsec.Text as AT +import qualified Data.Text as T +import qualified Text.Parsec as Parsec + +import Data.Time.Parsers +import Data.Time.TH + +main :: IO () +main = defaultMain $ testGroup "tests" [utctimeTests, timeTHTests] + +utctimeTests :: TestTree +utctimeTests = testGroup "utcTime" $ map t timeStrings + where + t str = testCase str $ do + assertBool str (isRight $ parseParsec str) + assertEqual str (parseParsec str) (parseAttoParsec str) + +isRight :: Either a b -> Bool +isRight (Left _) = False +isRight (Right _) = True + +parseParsec :: String -> Either String UTCTime +parseParsec input = first show $ Parsec.parse utcTime"" input + +parseAttoParsec :: String -> Either String UTCTime +parseAttoParsec = AT.parseOnly utcTime . T.pack + +timeStrings :: [String] +timeStrings = + [ "2015-09-07T08:16:40.807Z" + , "2015-09-07T11:16:40.807+0300" + , "2015-09-07 08:16:40.807Z" + , "2015-09-07 08:16:40.807 Z" + , "2015-09-07 08:16:40.807 +0000" + , "2015-09-07 08:16:40.807 +00:00" + , "2015-09-07 11:16:40.807 +03:00" + , "2015-09-07 05:16:40.807 -03:00" + ] + +timeTHTests :: TestTree +timeTHTests = + testCase "time TH example" $ assertBool "should be equal" $ lhs == rhs + where lhs = UTCTime (ModifiedJulianDay 56789) 123.456 + rhs = $(mkUTCTime "2014-05-12 00:02:03.456000Z") + diff --git a/time-parsers.cabal b/time-parsers.cabal new file mode 100644 --- /dev/null +++ b/time-parsers.cabal @@ -0,0 +1,60 @@ +-- This file has been generated from package.yaml by hpack version 0.8.0. +-- +-- see: https://github.com/sol/hpack + +name: time-parsers +version: 0.1.0.0 +synopsis: Parsers for types in `time`. +description: Parsers for types in `time`. +category: Web +homepage: https://github.com/phadej/time-parsers#readme +bug-reports: https://github.com/phadej/time-parsers/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3 +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/phadej/time-parsers + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.6 && <4.9 + , parsers >=0.12.2.1 && <0.13 + , template-haskell >=2.8.0.0 && <2.11 + , time >=1.4.2 && <1.7 + exposed-modules: + Data.Time.Parsers + Data.Time.TH + default-language: Haskell2010 + +test-suite date-parsers-tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >=4.6 && <4.9 + , parsers >=0.12.2.1 && <0.13 + , template-haskell >=2.8.0.0 && <2.11 + , time >=1.4.2 && <1.7 + , time-parsers + , attoparsec >=0.12.1.6 && <0.14 + , bifunctors >=4.2.1 && <5.2 + , parsec >=3.1.9 && <3.2 + , parsers >=0.12.3 && <0.13 + , tasty >=0.10.1.2 && <0.12 + , tasty-hunit >=0.9.2 && <0.10 + , text + default-language: Haskell2010