diff --git a/include/thyme.h b/include/thyme.h --- a/include/thyme.h +++ b/include/thyme.h @@ -1,5 +1,5 @@ #define INSTANCES_USUAL Eq, Ord, Data, Typeable, Generic -#define INSTANCES_NEWTYPE INSTANCES_USUAL, Enum, Ix, NFData, MVector VUM.MVector, Vector VU.Vector, VUM.Unbox +#define INSTANCES_NEWTYPE INSTANCES_USUAL, Enum, Ix, NFData #define INSTANCES_MICRO INSTANCES_NEWTYPE, Bounded, Random, Arbitrary, CoArbitrary #define LensP Lens' #define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \ S {..} F/**/_ -> S {F = F/**/_, ..} diff --git a/src/Data/Thyme/Calendar/Internal.hs b/src/Data/Thyme/Calendar/Internal.hs --- a/src/Data/Thyme/Calendar/Internal.hs +++ b/src/Data/Thyme/Calendar/Internal.hs @@ -3,8 +3,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} @@ -25,10 +27,12 @@ import Data.Int import Data.Ix import Data.Thyme.Format.Internal -import Data.Vector.Generic (Vector) -import Data.Vector.Generic.Mutable (MVector) +#if __GLASGOW_HASKELL__ != 706 +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +#endif import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM +import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import System.Random import Test.QuickCheck hiding ((.&.)) @@ -396,4 +400,34 @@ firstMonday = mod (5 - firstDay) 7 yd = firstMonday + 7 * (w - 1) + d - 1 lastDay = if isLeapYear y then 365 else 364 + +------------------------------------------------------------------------ +-- Unbox instances at the end avoids TH-related declaration order issues + +derivingUnbox "Day" [t| Day -> Int |] + [| toModifiedJulianDay |] [| ModifiedJulianDay |] + +derivingUnbox "YearMonthDay" [t| YearMonthDay -> (Year, Month, DayOfMonth) |] + [| \ YearMonthDay {..} -> (ymdYear, ymdMonth, ymdDay) |] + [| \ (ymdYear, ymdMonth, ymdDay) -> YearMonthDay {..} |] + +derivingUnbox "OrdinalDate" [t| OrdinalDate -> (Year, DayOfYear) |] + [| \ OrdinalDate {..} -> (odYear, odDay) |] + [| \ (odYear, odDay) -> OrdinalDate {..} |] + +derivingUnbox "MonthDay" [t| MonthDay -> (Month, DayOfMonth) |] + [| \ MonthDay {..} -> (mdMonth, mdDay) |] + [| \ (mdMonth, mdDay) -> MonthDay {..} |] + +derivingUnbox "WeekDate" [t| WeekDate -> (Year, WeekOfYear, DayOfWeek) |] + [| \ WeekDate {..} -> (wdYear, wdWeek, wdDay) |] + [| \ (wdYear, wdWeek, wdDay) -> WeekDate {..} |] + +derivingUnbox "SundayWeek" [t| SundayWeek -> (Year, WeekOfYear, DayOfWeek) |] + [| \ SundayWeek {..} -> (swYear, swWeek, swDay) |] + [| \ (swYear, swWeek, swDay) -> SundayWeek {..} |] + +derivingUnbox "MondayWeek" [t| MondayWeek -> (Year, WeekOfYear, DayOfWeek) |] + [| \ MondayWeek {..} -> (mwYear, mwWeek, mwDay) |] + [| \ (mwYear, mwWeek, mwDay) -> MondayWeek {..} |] diff --git a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs --- a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs +++ b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs @@ -1,8 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} + #include "thyme.h" module Data.Thyme.Calendar.WeekdayOfMonth @@ -20,6 +24,11 @@ import Data.Data import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal +#if __GLASGOW_HASKELL__ != 706 +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +#endif +import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import System.Random import Test.QuickCheck @@ -30,6 +39,11 @@ , womNth :: {-# UNPACK #-}!Int -- ^ ±1–5, negative means n-th last , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek } deriving (INSTANCES_USUAL, Show) + +derivingUnbox "WeekdayOfMonth" + [t| WeekdayOfMonth -> (Year, Month, Int, DayOfWeek) |] + [| \ WeekdayOfMonth {..} -> (womYear, womMonth, womNth, womDayOfWeek) |] + [| \ (womYear, womMonth, womNth, womDayOfWeek) -> WeekdayOfMonth {..} |] instance NFData WeekdayOfMonth diff --git a/src/Data/Thyme/Clock/Internal.hs b/src/Data/Thyme/Clock/Internal.hs --- a/src/Data/Thyme/Clock/Internal.hs +++ b/src/Data/Thyme/Clock/Internal.hs @@ -3,7 +3,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -- workaround {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} @@ -23,10 +26,11 @@ import Data.Ix import Data.Thyme.Internal.Micro import Data.Thyme.Calendar.Internal -import Data.Vector.Generic (Vector) -import Data.Vector.Generic.Mutable (MVector) -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM +#if __GLASGOW_HASKELL__ != 706 +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +#endif +import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Random @@ -104,6 +108,9 @@ -- @ newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) +derivingUnbox "DiffTime" [t| DiffTime -> Micro |] + [| \ (DiffTime a) -> a |] [| DiffTime |] + #if SHOW_INTERNAL deriving instance Show DiffTime deriving instance Read DiffTime @@ -152,6 +159,9 @@ -- @ newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) +derivingUnbox "NominalDiffTime" [t| NominalDiffTime -> Micro |] + [| \ (NominalDiffTime a) -> a |] [| NominalDiffTime |] + #if SHOW_INTERNAL deriving instance Show NominalDiffTime deriving instance Read NominalDiffTime @@ -200,6 +210,9 @@ -- . newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO) +derivingUnbox "UnversalTime" [t| UniversalTime -> NominalDiffTime |] + [| \ (UniversalRep a) -> a |] [| UniversalRep |] + -- | View 'UniversalTime' as a fractional number of days since the -- . {-# INLINE modJulianDate #-} @@ -232,11 +245,18 @@ -- . newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO) +derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |] + [| \ (UTCRep a) -> a |] [| UTCRep |] + -- | Unpacked 'UTCTime', partly for compatibility with @time@. data UTCView = UTCTime { utctDay :: {-# UNPACK #-}!Day , utctDayTime :: {-# UNPACK #-}!DiffTime } deriving (INSTANCES_USUAL, Show) + +derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |] + [| \ UTCTime {..} -> (utctDay, utctDayTime) |] + [| \ (utctDay, utctDayTime) -> UTCTime {..} |] instance NFData UTCView diff --git a/src/Data/Thyme/Clock/TAI.hs b/src/Data/Thyme/Clock/TAI.hs --- a/src/Data/Thyme/Clock/TAI.hs +++ b/src/Data/Thyme/Clock/TAI.hs @@ -2,8 +2,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -44,10 +46,11 @@ import Data.Thyme.Clock.Internal import Data.Thyme.Format.Internal import Data.Thyme.LocalTime -import Data.Vector.Generic (Vector) -import Data.Vector.Generic.Mutable (MVector) -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM +#if __GLASGOW_HASKELL__ != 706 +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +#endif +import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Locale @@ -55,6 +58,9 @@ import Test.QuickCheck newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO) + +derivingUnbox "AbsoluteTime" [t| AbsoluteTime -> DiffTime |] + [| \ (AbsoluteTime a) -> a |] [| AbsoluteTime |] instance Show AbsoluteTime where {-# INLINEABLE showsPrec #-} diff --git a/src/Data/Thyme/Internal/Micro.hs b/src/Data/Thyme/Internal/Micro.hs --- a/src/Data/Thyme/Internal/Micro.hs +++ b/src/Data/Thyme/Internal/Micro.hs @@ -2,7 +2,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} @@ -19,10 +21,11 @@ import Data.Int import Data.Ix import Data.Ratio -import Data.Vector.Generic (Vector) -import Data.Vector.Generic.Mutable (MVector) -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM +#if __GLASGOW_HASKELL__ != 706 +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +#endif +import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Random @@ -39,6 +42,9 @@ #endif newtype Micro = Micro Int64 deriving (INSTANCES_MICRO) + +derivingUnbox "Micro" [t| Micro -> Int64 |] + [| \ (Micro a) -> a |] [| Micro |] #if SHOW_INTERNAL deriving instance Show Micro diff --git a/src/Data/Thyme/LocalTime.hs b/src/Data/Thyme/LocalTime.hs --- a/src/Data/Thyme/LocalTime.hs +++ b/src/Data/Thyme/LocalTime.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -27,6 +30,11 @@ import Data.Thyme.Clock.Internal import Data.Thyme.Format.Internal import qualified Data.Time as T +#if __GLASGOW_HASKELL__ != 706 +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +#endif +import Data.Vector.Unboxed.Deriving import Data.VectorSpace import GHC.Generics (Generic) import System.Random @@ -121,6 +129,10 @@ , todSec :: {-# UNPACK #-}!DiffTime } deriving (INSTANCES_USUAL) +derivingUnbox "TimeOfDay" [t| TimeOfDay -> (Hour, Minute, DiffTime) |] + [| \ TimeOfDay {..} -> (todHour, todMin, todSec) |] + [| \ (todHour, todMin, todSec) -> TimeOfDay {..} |] + instance NFData TimeOfDay #if SHOW_INTERNAL @@ -217,6 +229,10 @@ { localDay :: {-# UNPACK #-}!Day , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay } deriving (INSTANCES_USUAL) + +derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |] + [| \ LocalTime {..} -> (localDay, localTimeOfDay) |] + [| \ (localDay, localTimeOfDay) -> LocalTime {..} |] instance NFData LocalTime diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -1,5 +1,5 @@ name: thyme -version: 0.3.4.0 +version: 0.3.5.0 synopsis: A faster time library description: Thyme is a rewrite of the fine @time@ library, with a particular focus @@ -11,10 +11,10 @@ license-file: LICENSE author: Liyang HU, Ashley Yakeley maintainer: thyme@liyang.hu -copyright: © 2013 Liyang HU +copyright: © 2013−2014 Liyang HU category: Data, System build-type: Simple -cabal-version: >= 1.8 +cabal-version: >= 1.10 stability: experimental extra-source-files: include/thyme.h @@ -49,6 +49,7 @@ manual: True library + default-language: Haskell2010 include-dirs: include hs-source-dirs: src if !flag(lens) @@ -91,6 +92,7 @@ text >= 0.11, time >= 1.4, vector >= 0.9, + vector-th-unbox >= 0.2, vector-space >= 0.8 if os(windows) build-depends: Win32 @@ -107,6 +109,7 @@ ghc-options: -Werror test-suite sanity + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests if !flag(lens) @@ -132,6 +135,7 @@ ghc-options: -Wall test-suite rewrite + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: rewrite.hs @@ -148,6 +152,7 @@ ghc-options: -Wall test-suite hlint + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: hlint.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N @@ -158,6 +163,7 @@ buildable: False benchmark bench + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests if !flag(lens)