diff --git a/Data/Time/Format/Human.hs b/Data/Time/Format/Human.hs deleted file mode 100644 --- a/Data/Time/Format/Human.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -------------------------------------------------------------------------------- --- | --- Module : Data.Time.Format.Human --- Copyright : (c) Patrick Brisbin 2010 --- License : as-is --- --- Maintainer : pbrisbin@gmail.com --- Stability : unstable --- Portability : unportable --- --- Prints a @'UTCTime'@ as "a few seconds ago" or "3 days ago" and similar. --- -------------------------------------------------------------------------------- -module Data.Time.Format.Human - ( humanReadableTime - , humanReadableTime' - , humanReadableTimeI18N - , humanReadableTimeI18N' - , HumanTimeLocale(..) - , defaultHumanTimeLocale - ) where - -import Data.Time - -import Data.Char (isSpace) -import System.Locale - -data HumanTimeLocale = HumanTimeLocale - { justNow :: String - , secondsAgo :: String -> String - , oneMinuteAgo :: String - , minutesAgo :: String -> String - , oneHourAgo :: String - , aboutHoursAgo :: String -> String - -- | Used when time difference is more than 24 hours but less than 5 days. - -- First argument is the day of week of the older time, second is string - -- formatted with `dayOfWeekFmt`. - , at :: Int -> String -> String - , daysAgo :: String -> String - , weekAgo :: String -> String - , weeksAgo :: String -> String - , onYear :: String -> String - , locale :: TimeLocale - -- | Time format used with `at` member. See @Data.Time.Format@ for - -- details on formatting sequences. - , dayOfWeekFmt :: String - -- | Time format used when time difference is less than a year but more - -- than a month. Time formatted using this string will be passed - -- to `onYear`. - , thisYearFmt :: String - -- | Time format used when time difference is at least one year. Time - -- formatted using this string will be passed to `onYear`. - , prevYearFmt :: String - } - --- | Default human time locale uses English. -defaultHumanTimeLocale :: HumanTimeLocale -defaultHumanTimeLocale = HumanTimeLocale - { justNow = "just now" - , secondsAgo = (++ " seconds ago") - , oneMinuteAgo = "one minute ago" - , minutesAgo = (++ " minutes ago") - , oneHourAgo = "one hour ago" - , aboutHoursAgo = \x -> "about " ++ x ++ " hours ago" - , at = \_ -> ("at " ++) - , daysAgo = (++ " days ago") - , weekAgo = (++ " week ago") - , weeksAgo = (++ " weeks ago") - , onYear = ("on " ++) - , locale = defaultTimeLocale - , dayOfWeekFmt = "%l:%M %p on %A" - , thisYearFmt = "%b %e" - , prevYearFmt = "%b %e, %Y" - } - --- | Based on @humanReadableTimeDiff@ found in --- , --- -humanReadableTime :: UTCTime -> IO String -humanReadableTime = humanReadableTimeI18N defaultHumanTimeLocale - --- | A pure form, takes current time as an argument -humanReadableTime' :: UTCTime -- ^ current time - -> UTCTime -> String -humanReadableTime' = humanReadableTimeI18N' defaultHumanTimeLocale - --- | I18N version of `humanReadableTime` -humanReadableTimeI18N :: HumanTimeLocale -> UTCTime -> IO String -humanReadableTimeI18N tl t = do - now <- getCurrentTime - return $ humanReadableTimeI18N' tl now t - --- | I18N version of `humanReadableTime'` -humanReadableTimeI18N' :: HumanTimeLocale - -> UTCTime -- ^ current time - -> UTCTime -> String -humanReadableTimeI18N' (HumanTimeLocale {..}) cur t = helper $ diffUTCTime cur t - where - minutes :: NominalDiffTime -> Double - minutes n = realToFrac $ n / 60 - - hours :: NominalDiffTime -> Double - hours n = minutes n / 60 - - days :: NominalDiffTime -> Double - days n = hours n / 24 - - weeks :: NominalDiffTime -> Double - weeks n = days n / 7 - - years :: NominalDiffTime -> Double - years n = days n / 365 - - i2s :: RealFrac a => a -> String - i2s n = show m where m = truncate n :: Int - - trim = f . f where f = reverse . dropWhile isSpace - - oldDayOfWeek :: Int - oldDayOfWeek = read $ formatTime defaultTimeLocale "%u" t - - old = utcToLocalTime utc t - format = formatTime locale - dow = trim $! format dayOfWeekFmt old - thisYear = trim $! format thisYearFmt old - previousYears = trim $! format prevYearFmt old - - helper d - | d < 1 = justNow - | d < 60 = secondsAgo $ i2s d - | minutes d < 2 = oneMinuteAgo - | minutes d < 60 = minutesAgo $ i2s (minutes d) - | hours d < 2 = oneHourAgo - | hours d < 24 = aboutHoursAgo $ i2s (hours d) - | days d < 5 = at oldDayOfWeek dow - | days d < 10 = daysAgo $ i2s (days d) - | weeks d < 2 = weekAgo $ i2s (weeks d) - | weeks d < 5 = weeksAgo $ i2s (weeks d) - | years d < 1 = onYear thisYear - | otherwise = onYear previousYears diff --git a/friendly-time.cabal b/friendly-time.cabal --- a/friendly-time.cabal +++ b/friendly-time.cabal @@ -1,36 +1,36 @@ -name: friendly-time -version: 0.3 -description: Print time information in friendly ways -synopsis: Print time information in friendly ways -homepage: http://github.com/pbrisbin/friendly-time -license: BSD3 -license-file: LICENSE -author: Patrick Brisbin -maintainer: me@pbrisbin.com -category: Web, Yesod -build-type: Simple -cabal-version: >=1.8 +name: friendly-time +version: 0.4 +author: Pat Brisbin +maintainer: Pat Brisbin +category: Web, Yesod +license: BSD3 +license-file: LICENSE +synopsis: Print time information in friendly ways +description: Print time information in friendly ways +build-type: Simple +cabal-version: >= 1.10 +build-type: Simple library - exposed-modules: Data.Time.Format.Human - - build-depends: base >= 4 && < 5 - , time - , old-locale - - ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Data.Time.Format.Human + build-depends: base >= 4 && < 5 + , time >= 1.4 + , old-locale -test-suite tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests, . - main-is: tests/Main.hs - build-depends: HUnit - , test-framework - , test-framework-hunit - , base - , time - , old-locale +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hspec + , friendly-time + , time >= 1.4 + , old-locale source-repository head - type: git - location: git://github.com/pbrisbin/friendly-time.git + type: git + location: git://github.com/pbrisbin/friendly-time.git diff --git a/src/Data/Time/Format/Human.hs b/src/Data/Time/Format/Human.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Format/Human.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +------------------------------------------------------------------------------- +-- | +-- +-- Print a @'UTCTime'@ as "a few seconds ago" or "3 days ago" and similar. +-- +------------------------------------------------------------------------------- +module Data.Time.Format.Human + ( humanReadableTime + , humanReadableTime' + , humanReadableTimeI18N + , humanReadableTimeI18N' + , HumanTimeLocale(..) + , defaultHumanTimeLocale + ) where + +import Data.Time + +import Data.Char (isSpace) + +#if !MIN_VERSION_time(1,5,0) +import System.Locale (TimeLocale, defaultTimeLocale) +#endif + + +data HumanTimeLocale = HumanTimeLocale + { justNow :: String + , secondsAgo :: Bool -> String -> String + , oneMinuteAgo :: Bool -> String + , minutesAgo :: Bool -> String -> String + , oneHourAgo :: Bool -> String + , aboutHoursAgo :: Bool -> String -> String + -- | Used when time difference is more than 24 hours but less than 5 days. + -- First argument is the day of week of the older time, second is string + -- formatted with `dayOfWeekFmt`. + , at :: Int -> String -> String + , daysAgo :: Bool -> String -> String + , weekAgo :: Bool -> String -> String + , weeksAgo :: Bool -> String -> String + , onYear :: String -> String + , locale :: TimeLocale + , timeZone :: TimeZone + -- | Time format used with `at` member. See @Data.Time.Format@ for + -- details on formatting sequences. + , dayOfWeekFmt :: String + -- | Time format used when time difference is less than a year but more + -- than a month. Time formatted using this string will be passed + -- to `onYear`. + , thisYearFmt :: String + -- | Time format used when time difference is at least one year. Time + -- formatted using this string will be passed to `onYear`. + , prevYearFmt :: String + } + +-- | Default human time locale uses English. +defaultHumanTimeLocale :: HumanTimeLocale +defaultHumanTimeLocale = HumanTimeLocale + { justNow = "just now" + , secondsAgo = \f -> (++ " seconds" ++ dir f) + , oneMinuteAgo = \f -> "one minute" ++ dir f + , minutesAgo = \f -> (++ " minutes" ++ dir f) + , oneHourAgo = \f -> "one hour" ++ dir f + , aboutHoursAgo = \f x -> "about " ++ x ++ " hours" ++ dir f + , at = \_ -> ("at " ++) + , daysAgo = \f -> (++ " days" ++ dir f) + , weekAgo = \f -> (++ " week" ++ dir f) + , weeksAgo = \f -> (++ " weeks" ++ dir f) + , onYear = ("on " ++) + , locale = defaultTimeLocale + , timeZone = utc + , dayOfWeekFmt = "%l:%M %p on %A" + , thisYearFmt = "%b %e" + , prevYearFmt = "%b %e, %Y" + } + where dir True = " from now" + dir False = " ago" + +-- | Based on @humanReadableTimeDiff@ found in +-- , +-- +humanReadableTime :: UTCTime -> IO String +humanReadableTime = humanReadableTimeI18N defaultHumanTimeLocale + +-- | A pure form, takes current time as an argument +humanReadableTime' :: UTCTime -- ^ current time + -> UTCTime -> String +humanReadableTime' = humanReadableTimeI18N' defaultHumanTimeLocale + +-- | I18N version of `humanReadableTime` +humanReadableTimeI18N :: HumanTimeLocale -> UTCTime -> IO String +humanReadableTimeI18N tl t = do + now <- getCurrentTime + return $ humanReadableTimeI18N' tl now t + +-- | I18N version of `humanReadableTime'` +humanReadableTimeI18N' :: HumanTimeLocale + -> UTCTime -- ^ current time + -> UTCTime -> String +humanReadableTimeI18N' (HumanTimeLocale {..}) cur t = helper $ diffUTCTime cur t + where + minutes :: NominalDiffTime -> Double + minutes n = realToFrac $ n / 60 + + hours :: NominalDiffTime -> Double + hours n = minutes n / 60 + + days :: NominalDiffTime -> Double + days n = hours n / 24 + + weeks :: NominalDiffTime -> Double + weeks n = days n / 7 + + years :: NominalDiffTime -> Double + years n = days n / 365 + + i2s :: RealFrac a => a -> String + i2s n = show m where m = truncate n :: Int + + trim = f . f where f = reverse . dropWhile isSpace + + oldDayOfWeek :: Int + oldDayOfWeek = read $ formatTime defaultTimeLocale "%u" t + + old = utcToLocalTime timeZone t + format = formatTime locale + dow = trim $! format dayOfWeekFmt old + thisYear = trim $! format thisYearFmt old + previousYears = trim $! format prevYearFmt old + + helper d = helper' (d < 0) (abs d) + + helper' future d + | d < 1 = justNow + | d < 60 = secondsAgo future $ i2s d + | minutes d < 2 = oneMinuteAgo future + | minutes d < 60 = minutesAgo future $ i2s (minutes d) + | hours d < 2 = oneHourAgo future + | hours d < 24 = aboutHoursAgo future $ i2s (hours d) + | days d < 5 = at oldDayOfWeek dow + | days d < 10 = daysAgo future $ i2s (days d) + | weeks d < 2 = weekAgo future $ i2s (weeks d) + | weeks d < 5 = weeksAgo future $ i2s (weeks d) + | years d < 1 = onYear thisYear + | otherwise = onYear previousYears diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Main where - -import Test.Framework -import Test.Framework.Providers.HUnit - -import Test.HUnit - -import Data.Maybe (fromJust) -import Data.Time.Clock -import Data.Time.Format -import Data.Time.Format.Human -import System.Locale - -p :: String -> UTCTime -p = fromJust . parseTime defaultTimeLocale "%F %T" - -helper :: String -> String -> String -helper future past = humanReadableTime' (p future) (p past) - -testJustNow = "just now" @=? helper "2013-08-04 22:30:00" - "2013-08-04 22:30:00" - -testSecondsAgo = "13 seconds ago" @=? helper "2013-08-04 22:30:13" - "2013-08-04 22:30:00" - -testMinuteAgo = "one minute ago" @=? helper "2013-08-04 22:31:20" - "2013-08-04 22:30:00" - -testMinutesAgo = "10 minutes ago" @=? helper "2013-08-04 22:40:00" - "2013-08-04 22:30:00" - -testHourAgo = "one hour ago" @=? helper "2013-08-04 23:40:00" - "2013-08-04 22:30:00" - -testHoursAgo = "about 4 hours ago" @=? helper "2013-08-05 02:40:00" - "2013-08-04 22:30:00" - -testDow = "at 10:30 PM on Sunday" @=? helper "2013-08-08 10:10:10" - "2013-08-04 22:30:00" - -testDaysAgo = "6 days ago" @=? helper "2013-08-10 22:40:00" - "2013-08-04 22:30:00" - -testWeekAgo = "1 week ago" @=? helper "2013-08-16 22:40:00" - "2013-08-04 22:30:00" - -testWeeksAgo = "4 weeks ago" @=? helper "2013-09-04 22:40:00" - "2013-08-04 22:30:00" - -testThisYear = "on Aug 4" @=? helper "2013-11-04 22:40:00" - "2013-08-04 22:30:00" - -testPrevYear = "on Aug 4, 2013" @=? helper "2014-11-04 22:40:00" - "2013-08-04 22:30:00" - -tests = [ - testGroup "English friendly time" - [ testCase "render now" testJustNow - , testCase "seconds ago" testSecondsAgo - , testCase "minute ago" testMinuteAgo - , testCase "minutes ago" testMinutesAgo - , testCase "hour ago" testHourAgo - , testCase "hours ago" testHoursAgo - , testCase "day of week" testDow - , testCase "days ago" testDaysAgo - , testCase "week ago" testWeekAgo - , testCase "weeks ago" testWeeksAgo - , testCase "this year" testThisYear - , testCase "previous year" testPrevYear - ] - ] - -main :: IO () -main = defaultMain tests