diff --git a/Data/Time/Zones/Read.hs b/Data/Time/Zones/Read.hs --- a/Data/Time/Zones/Read.hs +++ b/Data/Time/Zones/Read.hs @@ -1,5 +1,5 @@ {- | -Module : Data.Time.Zones +Module : Data.Time.Zones.Read Copyright : (C) 2014 Mihaly Barasz License : Apache-2.0, see LICENSE Maintainer : Mihaly Barasz @@ -9,15 +9,22 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Time.Zones.Read ( + -- * Various ways of loading `TZ` loadTZFromFile, loadSystemTZ, loadLocalTZ, loadTZFromDB, + -- * Reading only the description, no parsing + tzDescriptionFromFile, + tzDescriptionFromDB, + systemTZDescription, + -- * Parsing Olson data olsonGet, + parseTZDescription, ) where import Control.Applicative -import Control.Monad (unless) +import Control.Monad import Data.Binary import Data.Binary.Get import qualified Data.ByteString.Char8 as BS @@ -47,8 +54,6 @@ dir <- fromMaybe "/usr/share/zoneinfo" <$> getEnvMaybe "TZDIR" loadTZFromFile $ dir ++ "/" ++ tzName - - -- | Returns the local `TZ` based on the @TZ@ and @TZDIR@ -- environment variables. -- @@ -84,17 +89,45 @@ fn <- getDataFileName $ tzName ++ ".zone" loadTZFromFile fn +tzDescriptionFromFile :: FilePath -> IO BL.ByteString +tzDescriptionFromFile fname = olsonDescription <$> BL.readFile fname + +tzDescriptionFromDB :: String -> IO BL.ByteString +tzDescriptionFromDB tzName = do + -- TODO(klao): this probably won't work on Windows. + fn <- getDataFileName $ tzName ++ ".zone" + tzDescriptionFromFile fn + +systemTZDescription :: String -> IO BL.ByteString +systemTZDescription tzName = do + dir <- fromMaybe "/usr/share/zoneinfo" <$> getEnvMaybe "TZDIR" + tzDescriptionFromFile $ dir ++ "/" ++ tzName + +-------------------------------------------------------------------------------- + olsonGet :: Get TZ -olsonGet = do +olsonGet = olsonGet' False + +olsonGet' :: Bool -> Get TZ +olsonGet' abridged = do version <- olsonHeader case () of () | version == '\0' -> olsonGetWith 4 getTime32 () | version `elem` ['2', '3'] -> do - skipOlson0 - _ <- olsonHeader + unless abridged $ skipOlson0 >> void olsonHeader olsonGetWith 8 getTime64 -- TODO(klao): read the rule string _ -> fail $ "olsonGet: invalid version character: " ++ show version + +olsonDescription :: BL.ByteString -> BL.ByteString +olsonDescription input = flip runGet input $ do + version <- olsonHeader + if version `elem` ['2', '3'] + then skipOlson0 >> getRemainingLazyByteString + else return input + +parseTZDescription :: BL.ByteString -> TZ +parseTZDescription = runGet (olsonGet' True) olsonHeader :: Get Char olsonHeader = do diff --git a/Data/Time/Zones/TH.hs b/Data/Time/Zones/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Zones/TH.hs @@ -0,0 +1,141 @@ +-- | +-- Module : Data.Time.Zones.TH +-- Copyright : (C) 2014 Mihaly Barasz +-- License : Apache-2.0, see LICENSE +-- Maintainer : Mihaly Barasz +-- Stability : experimental +-- +-- /Example usage:/ +-- +-- > +-- >{-# LANGUAGE TemplateHaskell #-} +-- > +-- >import Data.Time +-- >import Data.Time.Zones +-- >import Data.Time.Zones.TH +-- > +-- >tzBudapest :: TZ +-- >tzBudapest = $(includeTZFromDB "Europe/Budapest") +-- > +-- >tzLosAngeles :: TZ +-- >tzLosAngeles = $(includeTZFromDB "America/Los_Angeles") +-- > +-- >main :: IO () +-- >main = do +-- > t <- getCurrentTime +-- > putStrLn $ "Time in Budapest: " ++ show (utcToLocalTimeTZ tzBudapest t) +-- > putStrLn $ "Time in Los Angeles: " ++ show (utcToLocalTimeTZ tzLosAngeles t) +-- + +{-# OPTIONS_HADDOCK prune #-} + +module Data.Time.Zones.TH ( + includeTZFromDB, + includeSystemTZ, + includeTZFromFile, + -- Internal functions + parseTZInternal, + ) where + +import Control.DeepSeq +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Time.Zones.Read +import Data.Time.Zones.Types +import Data.Version +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Paths_tz + +-- | Generate a `TZ` definition from an entry out of the time zone +-- database shipped with this package. +includeTZFromDB :: String -> Q Exp +includeTZFromDB tzName = do + desc <- runIO $ tzDescriptionFromDB tzName + parseTZ desc + +-- | Generate a `TZ` definition from a system time zone information file. +-- +-- See also: `loadSystemTZ` for details on how system time zone files +-- are located. +includeSystemTZ :: String -> Q Exp +includeSystemTZ tzName = do + desc <- runIO $ systemTZDescription tzName + parseTZ desc + +-- | Generate a `TZ` definition from the given time zone information file. +includeTZFromFile :: FilePath -> Q Exp +includeTZFromFile fname = do + desc <- runIO $ tzDescriptionFromFile fname + parseTZ desc + +-------------------------------------------------------------------------------- +-- Template Haskell helper functions. + +-- A bit of a rationale about this implementation. +-- +-- 1. The implementation below is basically a convoluted version of +-- the following: +-- +-- parseTZ :: BL.ByteString -> Q Exp +-- parseTZ desc = +-- [| parseTZDescription (BL.pack $(stringE $ BL.unpack desc)) |] +-- +-- So, why the complications? +-- +-- Why we want to _provide_ the possibility for the users to define +-- TZs with Template Haskell, we do not want to _depend_ on Template +-- Haskell in _this package_ itself. This way @tz@ can potentially be +-- cross-compiled. +-- +-- 2. Why the round-trip through `String`? Why don't we generate a +-- fully expanded definition of `TZ`? +-- +-- First, we want a definition that is stored compactly in the +-- resulting binary, and `String` literals are stored as C strings. +-- +-- Secondly, vectors (which are the internal representation of TZ) +-- don't have literal representation, so we couldn't produce a +-- fully-evaluated representation anyway. Also, it would be much more +-- complicated. +-- +parseTZ :: BL.ByteString -> Q Exp +parseTZ desc = do + -- Check that the description actually parses, so if there's a bug + -- we fail at compile time and not at run time: + parseTZDescription desc `deepseq` return () + parseTZInternalName <- getLocalName "parseTZInternal" + appE (varE parseTZInternalName) $ stringE $ BL.unpack desc + +-- Create a `Name` of the safe form that value name quoting +-- (ie. 'function) creates. +globalName :: String -> String -> String -> Name +globalName name modName package = + Name (OccName name) (NameG VarName (PkgName package) (ModName modName)) + +-- This is an imperfect substitute of name quoting +-- (eg. 'parseTZInternalName), which again we are doing because we +-- don't want to use the TemplateHaskell extension. +-- +-- If you have the @tz@ package installed and just using it; or if you +-- are building this package with Cabal, the parseTZInternal name is +-- found in the package "tz-". +-- But, if you are just debugging things in this package and compiling +-- stuff with ghc by hand, it will be found in the "main" package. So, +-- we first construct a global name as if it were in the "main" +-- package. Then, we try to reify it, which will fail in the normal +-- (first) case, in which case we fall back to "tz-". +getLocalName :: String -> Q Name +getLocalName functionName = do + let nameInPackage = globalName functionName "Data.Time.Zones.TH" + recover (return $ nameInPackage $ "tz-" ++ showVersion version) $ do + let name = nameInPackage "main" + _ <- reify name + return name + +-- Internal function used by spliced `TZ` definitions +-- +-- This function has to be exported, so that it can be found at the +-- place of splicing. +parseTZInternal :: String -> TZ +{-# INLINE parseTZInternal #-} +parseTZInternal = parseTZDescription . BL.pack diff --git a/Data/Time/Zones/Types.hs b/Data/Time/Zones/Types.hs --- a/Data/Time/Zones/Types.hs +++ b/Data/Time/Zones/Types.hs @@ -1,5 +1,5 @@ {- | -Module : Data.Time.Zones +Module : Data.Time.Zones.Types Copyright : (C) 2014 Mihaly Barasz License : Apache-2.0, see LICENSE Maintainer : Mihaly Barasz @@ -10,6 +10,7 @@ TZ(..), ) where +import Control.DeepSeq import Data.Int import qualified Data.Vector.Unboxed as VU import qualified Data.Vector as VB @@ -22,3 +23,6 @@ -- stored? _tzInfos :: !(VB.Vector (Bool, String)) -- (summer, name) } deriving (Eq,Show) + +instance NFData TZ where + rnf (TZ { _tzInfos = infos }) = rnf infos diff --git a/benchmarks/benchTZ.hs b/benchmarks/benchTZ.hs --- a/benchmarks/benchTZ.hs +++ b/benchmarks/benchTZ.hs @@ -24,6 +24,11 @@ mkUTC y m d hh mm ss = UTCTime (fromGregorian y m d) (timeOfDayToTime $ TimeOfDay hh mm ss) +utcToLocalTimeIO :: UTCTime -> IO LocalTime +utcToLocalTimeIO ut = do + tz <- getTimeZone ut + return $ utcToLocalTime tz ut + utcToLocalNano :: TZ -> Int64 -> Int64 {-# INLINE utcToLocalNano #-} utcToLocalNano tz t = t + 1000000000 * fromIntegral diff @@ -51,6 +56,11 @@ bench "past" $ nf (utcToLocalTime cetTZ) ut0, bench "now" $ nf (utcToLocalTime cetTZ) ut1, bench "future" $ nf (utcToLocalTime cetTZ) ut2 + ], + bgroup "fullUTCToLocalTime" [ + bench "past" $ nfIO (utcToLocalTimeIO ut0), + bench "now" $ nfIO (utcToLocalTimeIO ut1), + bench "future" $ nfIO (utcToLocalTimeIO ut2) ], bgroup "utcToLocalTimeTZ" [ bench "past" $ nf (utcToLocalTimeTZ tz) ut0, diff --git a/examples/exampleTH.hs b/examples/exampleTH.hs new file mode 100644 --- /dev/null +++ b/examples/exampleTH.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.Time +import Data.Time.Zones +import Data.Time.Zones.TH + +tzBudapest :: TZ +tzBudapest = $(includeTZFromDB "Europe/Budapest") + +tzLosAngeles :: TZ +tzLosAngeles = $(includeTZFromDB "America/Los_Angeles") + +main :: IO () +main = do + t <- getCurrentTime + putStrLn $ "Time in Budapest: " ++ show (utcToLocalTimeTZ tzBudapest t) + putStrLn $ "Time in Los Angeles: " ++ show (utcToLocalTimeTZ tzLosAngeles t) diff --git a/tests/testTH.hs b/tests/testTH.hs new file mode 100644 --- /dev/null +++ b/tests/testTH.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.Time.Zones +import Data.Time.Zones.TH +import Test.Framework.Providers.HUnit +import Test.Framework.TH +import Test.HUnit hiding (Test, assert) + +tzBudapest :: TZ +tzBudapest = $(includeSystemTZ "Europe/Budapest") + +case_Budapest_is_Budapest :: IO () +case_Budapest_is_Budapest = do + readBp <- loadSystemTZ "Europe/Budapest" + tzBudapest @?= readBp + +main :: IO () +main = do + $defaultMainGenerator diff --git a/tz.cabal b/tz.cabal --- a/tz.cabal +++ b/tz.cabal @@ -1,5 +1,5 @@ Name: tz -Version: 0.0.0.1 +Version: 0.0.0.2 License: Apache-2.0 License-File: LICENSE Author: Mihaly Barasz, Gergely Risko @@ -35,6 +35,7 @@ Extra-Source-Files: README.md + examples/*.hs Source-Repository head Type: git @@ -44,7 +45,8 @@ Exposed-Modules: Data.Time.Zones, Data.Time.Zones.Types, - Data.Time.Zones.Read + Data.Time.Zones.Read, + Data.Time.Zones.TH Other-Modules: Paths_tz Default-Language: Haskell2010 GHC-Options: -Wall @@ -52,6 +54,8 @@ base >= 4 && < 5, binary >= 0.5 && < 0.8, bytestring >= 0.9 && < 0.11, + deepseq >= 1.1 && < 2, + template-haskell >= 2.6 && < 2.9, time >= 1.2 && < 1.5, vector >= 0.9 && < 0.11 @@ -73,6 +77,20 @@ test-framework-th >= 0.2 && < 0.4, time >= 1.2 && < 1.5, unix >= 2.6 && < 3 + +Test-Suite th-test + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: tests + Main-Is: testTH.hs + GHC-Options: -Wall + Build-Depends: + tz, + base >= 4 && < 5, + HUnit >= 1.2 && < 1.3, + test-framework >= 0.4 && < 1, + test-framework-hunit >= 0.2 && < 0.4, + test-framework-th >= 0.2 && < 0.4 Benchmark bench Default-Language: Haskell2010