module Data.OrgMode.Parse.Attoparsec.Time where
import Control.Applicative (pure, some,
(*>), (<$>), (<*), (<*>), (<|>))
import Control.Monad (liftM)
import qualified Data.Attoparsec.ByteString as AB
import Data.Attoparsec.Text as T
import Data.Attoparsec.Types as TP (Parser)
import Data.Attoparsec.Combinator as TP
import qualified Data.ByteString.Char8 as BS
import Data.HashMap.Strict (HashMap, fromList)
import Data.Maybe (listToMaybe)
import Data.Text as Text (Text, pack, unpack,
unwords)
import Data.Thyme.Format (buildTime, timeParser)
import Data.Thyme.LocalTime (Hours, Minutes)
import Prelude hiding (concat, null, takeWhile,
unwords, words)
import System.Locale (defaultTimeLocale)
import Data.OrgMode.Parse.Types
parsePlannings :: TP.Parser Text (HashMap PlanningKeyword Timestamp)
parsePlannings = fromList <$> (many' (skipSpace *> planning <* skipSpace))
where planning :: TP.Parser Text (PlanningKeyword, Timestamp)
planning = (,) <$> pType <* char ':' <*> (skipSpace *> parseTimestamp)
pType = choice [string "SCHEDULED" *> pure SCHEDULED
,string "DEADLINE" *> pure DEADLINE
,string "CLOSED" *> pure CLOSED
]
parseClock :: TP.Parser Text (Maybe Timestamp, Maybe Duration)
parseClock = (,) <$> (skipSpace *> string "CLOCK: " *> ts) <*> dur
where
ts = option Nothing (Just <$> parseTimestamp)
dur = option Nothing (Just <$> (string " => "
*> skipSpace *> parseHM))
parseTimestamp :: TP.Parser Text Timestamp
parseTimestamp = do
(ts1, tsb1, act) <- transformBracketedDateTime <$> parseBracketedDateTime
blk2 <- liftM (maybe Nothing (Just . transformBracketedDateTime))
optionalBracketedDateTime
case (tsb1, blk2) of
(Nothing, Nothing) ->
return (Timestamp ts1 act Nothing)
(Nothing, Just (ts2, Nothing, _)) ->
return (Timestamp ts1 act (Just ts2))
(Nothing, Just _) ->
fail "Illegal time range in second timerange timestamp"
(Just (h',m'), Nothing) ->
return (Timestamp ts1 act
(Just $ ts1 {hourMinute = Just (h',m')
,repeater = Nothing
,delay = Nothing}))
(Just _, Just _) -> fail "Illegal mix of time range and timestamp range"
where
optionalBracketedDateTime =
option Nothing (Just <$> (string "--" *> parseBracketedDateTime))
type Weekday = Text
data BracketedDateTime =
BracketedDateTime
{ datePart :: YearMonthDay
, dayNamePart :: Maybe Weekday
, timePart :: Maybe TimePart
, repeat :: Maybe Repeater
, delayPart :: Maybe Delay
, isActive :: Bool
} deriving (Show, Eq)
parseBracketedDateTime :: TP.Parser Text BracketedDateTime
parseBracketedDateTime = do
openingBracket <- char '<' <|> char '['
brkDateTime <- BracketedDateTime <$>
parseDate <* skipSpace
<*> optionalParse parseDay
<*> optionalParse parseTime'
<*> maybeListParse parseRepeater
<*> maybeListParse parseDelay
<*> pure (activeBracket openingBracket)
closingBracket <- char '>' <|> char ']'
finally brkDateTime openingBracket closingBracket
where
optionalParse p = option Nothing (Just <$> p) <* skipSpace
maybeListParse p = listToMaybe <$> many' p <* skipSpace
activeBracket = (=='<')
finally bkd ob cb | complementaryBracket ob /= cb =
fail "Mismatched timestamp brackets"
| otherwise = return bkd
complementaryBracket '<' = '>'
complementaryBracket '[' = ']'
complementaryBracket x = x
transformBracketedDateTime :: BracketedDateTime -> (DateTime, Maybe (Hours, Minutes), Bool)
transformBracketedDateTime
(BracketedDateTime dp dn tp rp dly act) =
case tp of
Just (TimePart (Left (h,m))) ->
( DateTime (YMD' dp) dn (Just (h,m)) rp dly
, Nothing
, act)
Just (TimePart (Right (t1, t2))) ->
( DateTime (YMD' dp) dn (Just t1) rp dly
, Just t2
, act)
Nothing ->
( DateTime (YMD' dp) dn Nothing rp dly
, Nothing
, act)
parseDay :: TP.Parser Text Text
parseDay = pack <$> some (TP.satisfyElem isDayChar)
where
isDayChar :: Char -> Bool
isDayChar = (`notElem` nonDayChars)
nonDayChars :: String
nonDayChars = "]+0123456789>\r\n -"
type AbsoluteTime = (Hours, Minutes)
type TimestampRange = (AbsoluteTime, AbsoluteTime)
newtype TimePart = TimePart (Either AbsoluteTime TimestampRange)
deriving (Eq, Ord, Show)
parseTime' :: TP.Parser Text TimePart
parseTime' =
TimePart <$> choice [ Right <$> ((,) <$> parseHM <* char '-' <*> parseHM)
, Left <$> parseHM
]
parseDate :: TP.Parser Text YearMonthDay
parseDate = consumeDate >>= either failure success . dateParse
where
failure e = fail . unpack $ unwords ["Failure parsing date: ", pack e]
success t = return $ buildTime t
consumeDate = manyTill anyChar (char ' ')
dateParse = AB.parseOnly dpCombinator . BS.pack
dpCombinator = timeParser defaultTimeLocale "%Y-%m-%d"
parseHM :: TP.Parser Text (Hours, Minutes)
parseHM = (,) <$> decimal <* char ':' <*> decimal
parseTimeUnit :: TP.Parser Text TimeUnit
parseTimeUnit =
choice [ char 'h' *> pure UnitHour
, char 'd' *> pure UnitDay
, char 'w' *> pure UnitWeek
, char 'm' *> pure UnitMonth
, char 'y' *> pure UnitYear
]
parseRepeater :: TP.Parser Text Repeater
parseRepeater =
Repeater
<$> choice[ string "++" *> pure RepeatCumulate
, char '+' *> pure RepeatCatchUp
, string ".+" *> pure RepeatRestart
]
<*> decimal
<*> parseTimeUnit
parseDelay :: TP.Parser Text Delay
parseDelay =
Delay
<$> choice [ string "--" *> pure DelayFirst
, char '-' *> pure DelayAll
]
<*> decimal
<*> parseTimeUnit