relative-date (empty) → 0.0.0

raw patch · 6 files changed

+246/−0 lines, 6 filesdep +basedep +concatenativedep +datetimesetup-changed

Dependencies added: base, concatenative, datetime, mtl, parsec, time

Files

Data/DateTime/Parser.hs +117/−0
Data/Duration.hs +53/−0
LICENSE +20/−0
Setup.lhs +3/−0
relative-date.cabal +18/−0
tests.hs +35/−0

+ Data/DateTime/Parser.hs view

@@ -0,0 +1,117 @@+module Data.DateTime.Parser(+    Format(..), expr, time, weekday, month,+    duration, date, parseDate, repetition,+    exprs, limExpr) where+import Text.Parsec+import Data.DateTime+import Data.Time.Clock (utctDayTime)+import Data.Duration+import Control.Concatenative+import Control.Monad+import Control.Monad.Reader++data Format = US | World deriving (Eq, Show, Read)+type Parser = ParsecT String () (Reader (Format,DateTime))+a <<| b = a >> (return b)++exprs :: Parser [DateTime]+exprs = liftM2 (++) expr (liftM concat $ many (char ',' >> expr))++expr :: Parser [DateTime]+expr = do+    t <- option 0 (try time)+    optional spaces+    d <- optionMaybe (try date)+    d' <- case d of+            Nothing -> asks (\x-> (snd x){utctDayTime=fromInteger 0})+            (Just a) -> return a+    t' <- option t (optional spaces >> try time)+    let dt = addMinutes t' d'+    optional spaces+    r <- optionMaybe (repetition dt)+    return $ case r of+        Nothing -> [dt]+        (Just a) -> a++limExpr :: Parser [DateTime]+limExpr = do+     t <- option 0 (try time)+     d <- asks (\x-> (snd x){utctDayTime=fromInteger 0})+     let dt = addMinutes t d+     optional spaces+     r <- optionMaybe (repetition dt)+     return $ case r of+        Nothing -> [dt]+        (Just a) -> a++time :: Parser Integer+time = do+    a <- digit+    b <- optionMaybe digit+    let hours = ifte (==12) (const 0) id (case b of {(Just i)-> read [a,i]; Nothing -> read [a]}) *60+    char ':'+    c <- digit+    d <- digit+    let minutes = read [c,d]+    amPm <- optionMaybe . try $+        spaces >> (((string "AM" <|> string "am") <<| 0) <|> ((string "PM" <|> string "pm") <<|720))+    return $ case amPm of+        (Just a) -> hours + minutes + a+        Nothing -> ifte (<= 360) (+720) id (hours + minutes)++weekday :: Parser Int+weekday = (string "Monday" <<|1) <|> try (string "Tuesday" <<|2) <|> (string "Wednesday" <<|3)+            <|> (string "Thursday" <<|4) <|> (string "Friday" <<|5)+            <|> try (string "Saturday" <<|6) <|> (string "Sunday" <<|0)++month :: Parser Int+month = try (string "January" <<|1) <|> (string "February" <<|2) <|> try (string "March" <<|3)+        <|> try (string "April" <<|4) <|> (string "May" <<|5) <|> try (string "June" <<|6)+        <|> (string "July" <<|7) <|> (string "August" <<|8) <|> (string "September" <<|9)+        <|> (string "October" <<|10) <|> (string "November" <<|11) <|> (string "December" <<|12)++duration :: Parser Days+duration = (string "day" <<|Day) <|> (string "week" <<|Week) <|> (string "month" <<|Month) <|> (string "year" <<|Year)++date :: Parser DateTime+date = do+    c <- asks snd+    let dur = duration >>= (return . toDuration 1) >>= (\x-> return $ x c)+    let day = liftM (fixTime (addWeeks 1 c)) weekday+    (string "next " >> (day <|> dur)) <|> parseDate++parseDate = slashed <|> long where+    digits :: (Read a, Integral a) => Parser a+    digits = liftM read (many1 digit)+    slashed = do+        a <- digits :: Parser Int+        b <- char '/' >> digits :: Parser Int+        c <- char '/' >> digits :: Parser Integer+        (y,_,_) <- asks (toGregorian' . snd)+        f <- asks ((==US) . fst)+        return $ uncurry (fromGregorian' (y - (y `mod` 1000) + c)) $ if f then (a,b) else (b,a)+    long = do+        optional $ try (weekday >> spaces)+        m <- month+        d <- spaces >> digits+        y <- optionMaybe (char ',' >> spaces >> digits)+        (c,_,_) <- asks (toGregorian' . snd)+        return $ fromGregorian' (maybe c id y) m d++repetition :: DateTime -> Parser [DateTime]+repetition t = do+    (c,t') <- weekRep <|> everyRep+    l <- optionMaybe $ (string " for " >> numbered) <|> (string " until " >> date >>= (\x-> return (const x,t)))+    l' <- return $ case l of {Nothing -> Nothing; (Just (a,_)) -> Just a}+    return (assemble t' c l') where+        weekRep = do {a <- nDay 1; char 's' >> return a}+        everyRep = string "every " >> (numbered <|> othDur <|> nDay 1 <|> nDur 1)+        nDur n = duration >>= (\x-> return (toDuration n x,t))+        nDay n = weekday >>= (\x->return (toDuration n Week, fixTime t x))+        othDur = string "other " >> (nDay 2 <|> nDur 2)+        numbered = do+            a <- many1 digit+            a' <- return $ read a+            b <- spaces >> (nDur a' <|> nDay a')+            optional (char 's')+            return b

+ Data/Duration.hs view

@@ -0,0 +1,53 @@+module Data.Duration (+    Duration, Days(..),+    toDuration, fixTime, zellerCongruence, assemble,+    addDays, addWeeks, addMonths, addYears+    ) where+import Data.DateTime++type Duration = (DateTime -> DateTime)++-- |Used as values for 'toDuration'+data Days = Day | Week | Month | Year deriving (Eq, Show, Ord)++-- |Creates a duration for the number of periods of days specified+toDuration :: Integer -> Days -> Duration+toDuration amount days start =+    case days of+        Month -> let (y,m,d) = toGregorian' start+                     (y',m') = divMod (toInteger m + amount) 12+                 in fromGregorian' (y+y') (m + fromInteger m') d+        Year  -> let (y,m,d) = toGregorian' start+                 in fromGregorian' (y+amount) m d+        Week -> toDuration (7*amount) Day start+        Day   -> addMinutes (1440*amount) start++-- |Increments a DateTime to be on the weekday (0-6) given+fixTime :: DateTime -> Int -> DateTime+fixTime d s = addDays (if s'>=n then (s'-n) else (s'-n+7)) d where+    (yi,mi,di) = toGregorian' d+    n = zellerCongruence yi mi di+    s' = toInteger s++-- |Given year, month and day, gives the (0 based) day of the week+zellerCongruence :: Integer -> Int -> Int -> Integer+zellerCongruence y m d = (toInteger d+a) `mod` 7 where+    (y',m') = if m <= 2 then (y-1, m+12) else (y, m)+    a = y' + (y' `div` 4) - (y' `div` 100) + (y' `div` 400) + toInteger (div ((m'+1)*3) 5) + toInteger (2*m'+ 1)++-- |Creates a list of DateTimes given a start date, an interval duration, and an end duration from the start date+assemble :: DateTime -> Duration -> Maybe Duration -> [DateTime]+assemble date intDur endDur =+    maybe id (\x-> (takeWhile (<= (x date)))) endDur $ iterate intDur date++addYears :: Integer -> DateTime -> DateTime+addYears x = toDuration x Year++addWeeks :: Integer -> DateTime -> DateTime+addWeeks x = toDuration x Week++addMonths :: Integer -> DateTime -> DateTime+addMonths x = toDuration x Month++addDays :: Integer -> DateTime -> DateTime+addDays x = toDuration x Day

+ LICENSE view

@@ -0,0 +1,20 @@+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. 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.++THIS SOFTWARE IS PROVIDED ``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+DEVELOPERS AND 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.

+ Setup.lhs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ relative-date.cabal view

@@ -0,0 +1,18 @@+name:                relative-date+version:             0.0.0+synopsis:            Durations and generalized time parsing+description:         Relative-date provides two modules.  Data.Duration gives+					 functions for the creation of durations of time, represented+					 as functions from DateTime to DateTime.  Data.DateTime.Parser+					 presents miscellaneous parsers for handling time descriptions+					 of varying levels of detail.  The library also can parse+					 descriptions of repeated times, returning a (possibly infinite)+					 list of DateTimes.  +category:            Data+license:             BSD3+license-file:        LICENSE+author:              Sam Anklesaria+maintainer:          amsay@amsay.net+build-type:          Simple+Build-Depends:		 base >= 3 && < 5, mtl >=1.1 && <1.2, concatenative == 0.0, datetime == 0.2, parsec >= 3.0 && <= 3.1.0, time >= 1.1.2.2 && <1.2+Exposed-Modules:	 Data.DateTime.Parser, Data.Duration

+ tests.hs view

@@ -0,0 +1,35 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Tests where+import Test.QuickCheck+import Test.QuickCheck.Property as QC+import Text.Parsec.Error+import Control.Monad+import Control.Monad.Reader+import Control.Concatenative+import Text.Parsec.Prim+import Text.Parsec.Pos+import Data.DateTime.Parser+import Data.DateTime++testParser p i = runReader (runPT p () "" i) (US,fromSeconds 1293840000) -- the year I graduate++formatProperty :: DateTime -> [String] -> QC.Result+formatProperty d fs = toResult $ foldl f (Right d) (map (runTestParser expr) $ map (flip formatDateTime d) fs) where+    f (Left a) _ = Left a+    f _ (Left a) = Left a+    f (Right a) (Right b) = if a==b then Right a+        else Left (newErrorMessage (Message ("Formatted parsing inconsistant: " ++ show a ++ " is not " ++ show b)) (initialPos ""), Nothing)+    runTestParser p i = getUTC (testParser p i) where+            getUTC (Right (a:_)) = Right a+            getUTC (Left a) = (Left (a,Just i))+    toResult (Right a) = succeeded+    toResult (Left (a,Just b)) = failed {QC.reason = show a ++ " parsing string " ++ b }+    toResult (Left (a,Nothing)) = failed {QC.reason = show a }++formatDateProperty d = formatProperty (fixDate d) ["%A %B %e, %Y", "%B %e, %Y", "%D"] where+    fixDate d = let (y,m,i) = toGregorian' d in fromGregorian' (2000 + (y`mod`100)) m i++formatTimeProperty d = formatProperty (fixTime d) ["%A %B %e, %Y %I:%M %p", "%B %e, %Y %I:%M %p"] where+    fixTime = fromSeconds . bi id (`mod`60) (-) . toSeconds++main = mapM (quickCheckWith (Args Nothing 1000 1000 1000)) [formatDateProperty, formatTimeProperty]