[commit: packages/time] format-widths, improve-leapseconds, master, posix-perf, tasty, wip/travis: initial revision, including draft of Clock and outlines of TAI and Calendar (239f07b)

git at git.haskell.org git at git.haskell.org
Mon Feb 20 21:06:48 UTC 2017 

Repository : ssh://git@git.haskell.org/time

On branches: format-widths,improve-leapseconds,master,posix-perf,tasty,wip/travis
Link       : http://git.haskell.org/packages/time.git/commitdiff/239f07b42ef31a05b9b3894dc656620c8699cc9b

>---------------------------------------------------------------

commit 239f07b42ef31a05b9b3894dc656620c8699cc9b
Author: Ashley Yakeley <ashley at semantic.org>
Date:   Tue Feb 22 21:19:59 2005 -0800

    initial revision, including draft of Clock and outlines of TAI and Calendar
    
    darcs-hash:20050223051959-ac6dd-ea6ff7c56b81deaffc2584a3a196a8e6262805d9


>---------------------------------------------------------------

239f07b42ef31a05b9b3894dc656620c8699cc9b
 Makefile                |  30 +++++++++++++
 System/Time/Calendar.hs |  61 +++++++++++++++++++++++++
 System/Time/Clock.hs    | 116 ++++++++++++++++++++++++++++++++++++++++++++++++
 System/Time/TAI.hs      |  33 ++++++++++++++
 TestTime.hs             |  11 +++++
 5 files changed, 251 insertions(+)

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..4a6709f
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,30 @@
+default: TestTime.run
+
+#TestTime: TestTime.o System/Time/Clock.o System/Time/TAI.o System/Time/Calendar.o
+TestTime: TestTime.o System/Time/Clock.o
+	ghc $^ -o $@
+
+
+clean:
+	rm -f TestTime *.o *.hi System/Time/*.o System/Time/*.hi Makefile.bak
+
+
+%.run: %
+	./$<
+
+%.hi: %.o
+	@:
+
+%.o: %.hs
+	ghc -c $< -o $@
+
+depend: TestTime.hs System/Time/Clock.hs System/Time/TAI.hs System/Time/Calendar.hs
+	ghc -M $^
+# DO NOT DELETE: Beginning of Haskell dependencies
+TestTime.o : TestTime.hs
+TestTime.o : ./System/Time/Clock.hi
+System/Time/Clock.o : System/Time/Clock.hs
+System/Time/TAI.o : System/Time/TAI.hs
+System/Time/TAI.o : System/Time/Clock.hi
+System/Time/Calendar.o : System/Time/Calendar.hs
+# DO NOT DELETE: End of Haskell dependencies
diff --git a/System/Time/Calendar.hs b/System/Time/Calendar.hs
new file mode 100644
index 0000000..944f4fb
--- /dev/null
+++ b/System/Time/Calendar.hs
@@ -0,0 +1,61 @@
+module System.Time.Calendar
+(
+	-- time zones
+	TimeZone,
+
+	-- getting the locale time zone
+
+	-- converting times to Gregorian "calendrical" format
+	TimeOfDay,CalendarDay,CalendarTime
+
+	-- calendrical arithmetic
+    -- e.g. "one month after March 31st"
+
+	-- parsing and showing dates and times
+) where
+
+-- | count of minutes
+newtype TimeZone = MkTimeZone Int deriving (Eq,Ord,Num)
+
+
+data TimeOfDay = TimeOfDay
+{
+	todHour    :: Int,
+	todMin     :: Int,
+	todSec     :: Int,
+	todPicosec :: Integer
+} deriving (Eq,Ord)
+
+instance Show TimeOfDay where
+	show (TimeOfDay h m s ps) = 
+
+data CalendarDay = CalendarDay
+{
+	cdYear    :: Integer,
+	cdMonth   :: Int,
+	cdDay     :: Int
+} deriving (Eq,Ord)
+
+data CalendarTime = CalendarTime
+{
+	ctDay    :: CalendarDay,
+	ctTime   :: TimeOfDay
+} deriving (Eq,Ord)
+
+
+
+-- ((365 * 3 + 366) * 24 + 365 * 4) * 3 + (365 * 3 + 366) * 25
+dayToCalendar :: ModJulianDay -> CalendarDay
+dayToCalendar mjd = let
+	a = mjd + 2000	-- ?
+	quadcent = a / 146097
+	b = a % 146097
+	cent = min (b / 36524) 3
+	...to be continued
+
+
+utcToCalendar :: TimeZone -> UTCTime -> CalendarTime
+
+calendarToUTC :: TimeZone -> CalendarTime -> UTCTime
+
+
diff --git a/System/Time/Clock.hs b/System/Time/Clock.hs
new file mode 100644
index 0000000..386c920
--- /dev/null
+++ b/System/Time/Clock.hs
@@ -0,0 +1,116 @@
+{-# OPTIONS -ffi #-}
+
+module System.Time.Clock
+(
+	-- Modified Julian days and dates (for UT1)
+	ModJulianDay,ModJulianDate,
+
+	-- absolute time intervals
+	DiffTime,timeToSISeconds,siSecondsToTime,
+
+	-- UTC arithmetic
+	UTCTime(..),UTCDiffTime,utcTimeToUTCSeconds,utcSecondsToUTCTime,
+
+	-- getting the current UTC time
+	getCurrentTime
+) where
+
+import Foreign
+import Foreign.C
+
+-- | standard Julian count of Earth days
+type ModJulianDay = Integer
+
+-- | standard Julian dates for UT1, 1 = 1 day
+type ModJulianDate = Rational
+
+secondPicoseconds :: (Num a) => a
+secondPicoseconds = 1000000000000
+
+newtype DiffTime = MkDiffTime Integer deriving (Eq,Ord,Show)
+
+timeToSIPicoseconds :: DiffTime -> Integer
+timeToSIPicoseconds (MkDiffTime ps) = ps
+
+siPicosecondsToTime :: Integer -> DiffTime
+siPicosecondsToTime = MkDiffTime
+
+timeToSISeconds :: (Fractional a) => DiffTime -> a
+timeToSISeconds t = fromRational ((toRational (timeToSIPicoseconds t)) / (toRational secondPicoseconds));
+
+siSecondsToTime :: (Real a) => a -> DiffTime
+siSecondsToTime t = siPicosecondsToTime (round ((toRational t) * secondPicoseconds))
+
+data UTCTime = UTCTime {
+	utctDay :: ModJulianDay,
+	utctDayTime :: DiffTime
+}
+
+newtype UTCDiffTime = MkUTCDiffTime Integer
+
+utcTimeToUTCPicoseconds :: UTCDiffTime -> Integer
+utcTimeToUTCPicoseconds (MkUTCDiffTime ps) = ps
+
+utcPicosecondsToUTCTime :: Integer -> UTCDiffTime
+utcPicosecondsToUTCTime = MkUTCDiffTime
+
+utcTimeToUTCSeconds :: (Fractional a) => UTCDiffTime -> a
+utcTimeToUTCSeconds t = fromRational ((toRational (utcTimeToUTCPicoseconds t)) / (toRational secondPicoseconds))
+
+utcSecondsToUTCTime :: (Real a) => a -> UTCDiffTime
+utcSecondsToUTCTime t = utcPicosecondsToUTCTime (round ((toRational t) * secondPicoseconds))
+
+posixDaySeconds :: (Num a) => a
+posixDaySeconds = 86400
+
+posixDayPicoseconds :: Integer
+posixDayPicoseconds = posixDaySeconds * secondPicoseconds
+
+unixEpochMJD :: ModJulianDay
+unixEpochMJD = 40587
+
+posixPicosecondsToUTCTime :: Integer -> UTCTime
+posixPicosecondsToUTCTime i = let
+	(d,t) = divMod i posixDayPicoseconds
+ in UTCTime (d + unixEpochMJD) (siPicosecondsToTime t)
+
+utcTimeToPOSIXPicoseconds :: UTCTime -> Integer
+utcTimeToPOSIXPicoseconds (UTCTime d t) =
+ ((d - unixEpochMJD) * posixDayPicoseconds) + min posixDayPicoseconds (timeToSIPicoseconds t)
+
+addUTCTime :: UTCDiffTime -> UTCTime -> UTCTime
+addUTCTime x t = posixPicosecondsToUTCTime ((utcTimeToUTCPicoseconds x) + (utcTimeToPOSIXPicoseconds t))
+
+diffUTCTime :: UTCTime -> UTCTime -> UTCDiffTime
+diffUTCTime a b = utcPicosecondsToUTCTime ((utcTimeToPOSIXPicoseconds a) - (utcTimeToPOSIXPicoseconds b))
+
+
+-- Get current time
+
+data CTimeval = MkCTimeval CLong CLong
+
+ctimevalToPosixPicoseconds :: CTimeval -> Integer
+ctimevalToPosixPicoseconds (MkCTimeval s mus) = ((fromIntegral s) * 1000000 + (fromIntegral mus)) * 1000000
+
+instance Storable CTimeval where
+	sizeOf _ = (sizeOf (undefined :: CLong)) * 2
+	alignment _ = alignment (undefined :: CLong)
+	peek p = do
+		s   <- peekElemOff (castPtr p) 0
+		mus <- peekElemOff (castPtr p) 1
+		return (MkCTimeval s mus)
+	poke p (MkCTimeval s mus) = do
+		pokeElemOff (castPtr p) 0 s
+		pokeElemOff (castPtr p) 1 mus
+
+foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt
+
+getCurrentTime :: IO UTCTime
+getCurrentTime = with (MkCTimeval 0 0) (\ptval -> do
+	result <- gettimeofday ptval nullPtr
+	if (result == 0)
+	 then do
+	 	tval <- peek ptval
+	 	return (posixPicosecondsToUTCTime (ctimevalToPosixPicoseconds tval))
+	 else fail ("error in gettimeofday: " ++ (show result))
+	)
diff --git a/System/Time/TAI.hs b/System/Time/TAI.hs
new file mode 100644
index 0000000..fb5df5a
--- /dev/null
+++ b/System/Time/TAI.hs
@@ -0,0 +1,33 @@
+-- | most people won't need this module
+module System.Time.TAI
+(
+	-- TAI arithmetic
+	AbsoluteTime,addAbsoluteTime,diffAbsoluteTime,
+
+	-- leap-second table type
+	LeapSecondTable,
+
+	-- conversion between UTC and TAI with table
+	utcDayLength,utcToTAITime,taiToUTCTime
+) where
+
+import System.Time.Clock
+
+-- | TAI
+type AbsoluteTime = MkAbsoluteTime Integer
+
+addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
+
+diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
+
+-- | TAI - UTC during this day
+type LeapSecondTable = ModJulianDay -> Int
+
+utcDayLength :: LeapSecondTable -> ModJulianDay -> DiffTime
+utcDayLength table day = siSecondsToTime (86400 + (table (day + 1)) - (table day))
+
+utcToTAITime :: LeapSecondTable -> UTCTime -> TAITime
+utcToTAITime table (UTCTime day dtime) = siSecondsToTime (table day) + 
+
+taiToUTCTime :: LeapSecondTable -> TAITime -> UTCTime
+
diff --git a/TestTime.hs b/TestTime.hs
new file mode 100644
index 0000000..77dff58
--- /dev/null
+++ b/TestTime.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import System.Time.Clock
+--import System.Time.TAI
+--import System.Time.Calendar
+
+main :: IO ()
+main = do
+	now <- getCurrentTime
+	putStrLn (show (utctDay now) ++ "," ++ show (utctDayTime now))
+--	putStrLn (show (utcToCalendar (60 * -8) now))

More information about the ghc-commits mailing list