{-# LANGUAGE OverloadedStrings #-}
module Text.ICalendar.Parser.Parameters where

import           Control.Applicative
import           Control.Monad.Error
import           Control.Monad.RWS          (MonadWriter (tell))
import           Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import           Data.CaseInsensitive       (CI)
import           Data.Char
import           Data.Default
import           Data.Maybe
import           Data.Text.Lazy             (Text)
import qualified Data.Text.Lazy             as T

import           Codec.MIME.Parse       (parseMIMEType)
import           Codec.MIME.Type        (MIMEType, mimeType)
import qualified Text.Parsec            as P
import           Text.Parsec.Combinator hiding (optional)
import           Text.Parsec.Perm
import           Text.Parsec.Prim       hiding ((<|>))

import Text.ICalendar.Parser.Common
import Text.ICalendar.Types

parseAlarmTriggerRelationship :: CI Text
                              -> ContentParser AlarmTriggerRelationship
parseAlarmTriggerRelationship "START" = return Start
parseAlarmTriggerRelationship "END" = return End
parseAlarmTriggerRelationship x =
    throwError $ "parseAlarmTriggerRelationship: " ++ show x

-- | Parse relationship type. 3.2.15
parseRelationshipType :: CI Text -> RelationshipType
parseRelationshipType "PARENT"  = Parent
parseRelationshipType "CHILD"   = Child
parseRelationshipType "SIBLING" = Sibling
parseRelationshipType x = RelationshipTypeX x

-- | Parse bool. 3.3.2
parseBool :: CI Text -> ContentParser Bool
parseBool "TRUE" = return True
parseBool "FALSE" = return False
parseBool x = throwError $ "parseBool: " ++ show x

-- | Parse recurrence identifier range. 3.2.13
parseRange :: CI Text -> ContentParser Range
parseRange "THISANDFUTURE" = return ThisAndFuture
parseRange "THISANDPRIOR"  = do tell ["THISANDPRIOIR RANGE is deprecated."]
                                return ThisAndPrior
parseRange x = throwError $ "parseRange: " ++ show x

-- | Parse free/busy time type. 3.2.9.
parseFBType :: CI Text -> FBType
parseFBType "FREE"             = Free
parseFBType "BUSY"             = Busy
parseFBType "BUSY-UNAVAILABLE" = BusyUnavailable
parseFBType "BUSY-TENTATIVE"   = BusyTentative
parseFBType x                  = FBTypeX x

-- | Parse participation status. 3.2.12
parsePartStat :: CI Text -> PartStat
parsePartStat "NEEDS-ACTION" = PartStatNeedsAction
parsePartStat "ACCEPTED" = Accepted
parsePartStat "DECLINED" = Declined
parsePartStat "TENTATIVE" = Tentative
parsePartStat "DELEGATED" = Delegated
parsePartStat "COMPLETED" = PartStatCompleted
parsePartStat "IN-PROCESS" = InProcess
parsePartStat x = PartStatX x

-- | Parse role.
parseRole :: CI Text -> Role
parseRole "CHAIR" = Chair
parseRole "REQ-PARTICIPANT" = ReqParticipant
parseRole "OPT-PARTICIPANT" = OptParticipant
parseRole "NON-PARTICIPANT" = NonParticipant
parseRole x = RoleX x


parseCUType :: CI Text -> CUType
parseCUType "INDIVIDUAL" = Individual
parseCUType "GROUP" = Group
parseCUType "RESOURCE" = Resource
parseCUType "ROOM" = Room
parseCUType "UNKNOWN" = Unknown
parseCUType x = CUTypeX x

parseMime :: Text -> ContentParser MIMEType
parseMime t = let m = mimeType .: parseMIMEType $ T.toStrict t
               in maybe (throwError $ "parseMime: " ++ show t) return m

-- | Parse Duration. 3.3.6
parseDuration :: String -- ^ Parser context.
              -> ByteString -- ^ What to parse.
              -> ContentParser Duration
parseDuration what bs =
    case runParser dur def what bs of
         Left e -> throwError $ "Invalid duration: "
                              ++ unlines [show bs, show e]
         Right x -> return x
  where dur = do si <- sign
                 _ <- P.char 'P'
                 day <- optional . try $ digits <* P.char 'D'
                 time <- optional $ do
                    _ <- P.char 'T'
                    h <- optional . try $ digits <* P.char 'H'
                    m <- optional . try $ digits <* P.char 'M'
                    s <- optional . try $ digits <* P.char 'S'
                    return (h, m, s)
                 week <- optional . try $ digits <* P.char 'W'
                 P.eof
                 case (day, time, week) of
                      (Just d, x, Nothing) ->
                           let (h, m, s) = deMHms x
                            in return $ DurationDate si d h m s
                      (Nothing, x@(Just _), Nothing) ->
                           let (h, m, s) = deMHms x
                            in return $ DurationTime si h m s
                      (Nothing, Nothing, Just w) ->
                           return $ DurationWeek si w
                      (_, _, _) -> fail "Invalid."

        sign = fromMaybe Positive <$> optional (Positive <$ P.char '+'
                                            <|> Negative <$ P.char '-')

        deMHms (Just (h, m, s)) = (fromMaybe 0 h, fromMaybe 0 m, fromMaybe 0 s)
        deMHms Nothing = (0, 0, 0)

-- | Parse Recur-value. 3.3.10.
-- Partly implemented in parsec.
parseRecur :: DTStart -> TextParser (ContentParser Recur)
parseRecur dts =
    permute (mkRecur <$$> (freq <* term)
                     <|?> (Nothing, untilCount <* term)
                     <|?> (1, istring "INTERVAL=" *> digits <* term)
                     <|?> ([], istring "BYSECOND=" *> digitsN <* term)
                     <|?> ([], istring "BYMINUTE=" *> digitsN <* term)
                     <|?> ([], istring "BYHOUR=" *> digitsN <* term)
                     <|?> ([], istring "BYDAY=" *> sepBy wday (P.char ',')
                                                     <* term)
                     <|?> ([], istring "BYMONTHDAY=" *> onum <* term)
                     <|?> ([], istring "BYYEARDAY=" *> onum <* term)
                     <|?> ([], istring "BYWEEKNO=" *> onum <* term)
                     <|?> ([], istring "BYMONTH=" *> digitsN <* term)
                     <|?> ([], istring "BYSETPOS=" *> onum <* term)
                     <|?> (Monday, istring "WKST=" *> weekday <* term))
      <* P.eof

  where freq = istring "FREQ=" *> frequency
        frequency = Secondly <$ istring "SECONDLY"
                <|> Minutely <$ istring "MINUTELY"
                <|> Hourly   <$ istring "HOURLY"
                <|> Daily    <$ istring "DAILY"
                <|> Weekly   <$ istring "WEEKLY"
                <|> Monthly  <$ istring "MONTHLY"
                <|> Yearly   <$ istring "YEARLY"
        weekday = Sunday    <$ istring "SU"
              <|> Monday    <$ istring "MO"
              <|> Tuesday   <$ istring "TU"
              <|> Wednesday <$ istring "WE"
              <|> Thursday  <$ istring "TH"
              <|> Friday    <$ istring "FR"
              <|> Saturday  <$ istring "SA"
        wday = Right <$> weekday
           <|> (Left .) . (,) <$> (neg <*> digits) <*> weekday
        onum = sepBy1 (neg <*> digits) (P.char ',')
        untilCount = istring "UNTIL=" *> until'
                 <|> istring "COUNT=" *> (Just . Right <$> digits)
        until' = do txt <- manyTill P.anyChar (void (P.char ';') <|> P.eof)
                    return . Just . Left $
                        case dts of
                             DTStartDateTime _ _ ->
                                 Right <$> parseDateTime Nothing (B.pack txt)
                             DTStartDate _ _ ->
                                 Left <$> parseDate (B.pack txt)
        term = optional (P.char ';')
        istring :: String -> TextParser ()
        istring = void . try . mapM (\c -> P.char c <|> P.char (toLower c))

        mkRecur f uc i s m h d md yd wn mo sp wkst = do
            uc' <- case uc of
                        Just (Left x) -> Just . Left <$> x
                        Just (Right y) -> return . Just $ Right y
                        Nothing -> return Nothing
            return $ Recur f uc' i s m h d md yd wn mo sp wkst



parseUTCPeriod :: ByteString -> ContentParser UTCPeriod
parseUTCPeriod bs = do
    let (dateTime', x) = B.drop 1 <$> B.break (=='/') bs
    when (B.null x) . throwError $ "Invalid UTCperiod: " ++ show bs
    dateTime <- mustBeUTC =<< parseDateTime Nothing dateTime'
    case B.head x of
         z | z `elem` ("+-P"::String) -> UTCPeriodDuration dateTime
                                    <$> parseDuration "period" x
         _ -> UTCPeriodDates dateTime <$> (mustBeUTC =<< parseDateTime Nothing x)

parsePeriod :: Maybe Text -> ByteString -> ContentParser Period
parsePeriod tzid bs = do
    let (dateTime', x) = B.drop 1 <$> B.break (=='/') bs
    when (B.null x) . throwError $ "Invalid period: " ++ show bs
    dateTime <- parseDateTime tzid dateTime'
    case B.head x of
         z | z `elem` ("+-P"::String) -> PeriodDuration dateTime
                                    <$> parseDuration "period" x
         _ -> PeriodDates dateTime <$> parseDateTime tzid x
