module Text.ICalendar.Parser
(
ComponentName(..)
, PropertyName(..)
, ParamName(..)
, ParamValue(..)
, Property
, Value
, ICalendar(..)
, Component(..)
, Param(..)
, parser
) where
import Data.Char
import Control.Monad
import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
instance Applicative (GenParser s a) where
pure = return
(<*>) = ap
instance Alternative (GenParser s a) where
empty = mzero
(<|>) = mplus
data ComponentName =
VEVENT
| VTODO
| VJOURNAL
| VFREEBUSY
| VTIMEZONE
| X_c String
| STANDARD
| DAYLIGHT
| VALARM
deriving (Eq, Show)
data PropertyName =
CALSCALE
| METHOD
| PRODID
| VERSION
| ATTACH
| CATEGORIES
| CLASS
| COMMENT
| DESCRIPTION
| GEO
| LOCATION
| PERCENT_COMPLETE
| PRIORITY
| RESOURCES
| STATUS
| SUMMARY
| COMPLETED
| DTEND
| DUE
| DTSTART
| DURATION
| FREEBUSY
| TRANSP
| TZID
| TZNAME
| TZOFFSETFROM
| TZOFFSETTO
| TZURL
| ATTENDEE
| CONTACT
| ORGANIZER
| RECURRENCE_ID
| RELATED_TO
| URL
| UID
| EXDATE
| EXRULE
| RDATE
| RRULE
| ACTION
| REPEAT
| TRIGGER
| CREATED
| DTSTAMP
| LAST_MODIFIED
| SEQUENCE
| X_ String
| REQUEST_STATUS
deriving (Eq, Show)
data ParamName = ALTREP
| CN
| CUTYPE
| DELEGATED_FROM
| DELEGATED_TO
| DIR
| ENCODING
| FMTYPE
| FBTYPE
| LANGUAGE
| MEMBER
| PARTSTAT
| RANGE
| RELATED
| RELTYPE
| ROLE
| RSVP
| SENT_BY
| TZIDp
| VALUE
| X_p String
deriving (Eq, Show)
data ParamValue = Paramtext String
| QuotedString String
deriving (Eq, Show)
type Value = String
type Property = (PropertyName, [Param], Value)
data ICalendar = ICalendar { calendarProperties :: [Property]
, components :: [Component]
} deriving (Eq, Show)
mkICalendar = ICalendar [] []
addCalendarProperty prop calendar = calendar { calendarProperties = prop : calendarProperties calendar }
addComponent comp calendar = calendar { components = comp : components calendar }
data Component = Component { cName :: ComponentName
, properties :: [Property]
, subcomponents :: [Component]
} deriving (Eq, Show)
mkComponent name = Component name [] []
addProperty prop component = component { properties = prop : properties component }
addSubcomponent comp component = component { subcomponents = comp : subcomponents component }
data Param = Param { pName :: ParamName
, pValues :: [ParamValue]
} deriving (Eq, Show)
ciString = try . sequence . (map (\c -> char (toUpper c) <|> char (toLower c)))
crlf = string "\r\n"
pQsafeChar = oneOf $ wsp ++ map chr (0x21 : [0x23..0x7e]) ++ nonUsAscii
pSafeChar = oneOf $ wsp ++ map chr (0x21 : [0x23..0x2b] ++ [0x2d..0x39] ++ [0x3c..0x7e]) ++ nonUsAscii
pValueChar = oneOf $ wsp ++ map chr [0x21..0x7e] ++ nonUsAscii
nonUsAscii = map chr [0x80..0xF8]
wsp = " \t"
parser = do input <- getInput
setInput (foldLines input)
pICalendar
foldLines [] = []
foldLines ('\r':'\n':' ' :lines) = foldLines lines
foldLines ('\r':'\n':'\t':lines) = foldLines lines
foldLines (l:lines) = l : foldLines lines
pICalendar = pBegin <* pVCalendar
*> pCalendarPropertiesAndComponents
<* eof
pVCalendar = ciString "VCALENDAR" <* crlf
pCalendarPropertiesAndComponents =
addCalendarProperty <$> pProperty <*> pCalendarPropertiesAndComponents
<|> addComponent <$> pComponent <*> pCalendarPropertiesAndComponents
<|> mkICalendar <$ pEnd <* pVCalendar
pComponent = do component <- pComponentBegin
pPropertiesAndSubcomponents component
pComponentBegin = mkComponent <$ pBegin <*> pComponentName
pPropertiesAndSubcomponents component =
addProperty <$> pProperty <*> pPropertiesAndSubcomponents component
<|> addSubcomponent <$> pComponent <*> pPropertiesAndSubcomponents component
<|> component <$ pComponentEnd component
pProperty = (,,) <$> pPropertyName <*> many pParam <*> pValue
pParam = Param <$ char ';' <*> pParamName <*> sepBy pParamValue (char ',')
pParamValue = pQuotedString <|> pParamtext
pParamtext = Paramtext <$> many pSafeChar
pQuotedString = QuotedString <$ char '"' <*> many pQsafeChar <* char '"'
pValue = char ':' *> many pValueChar <* crlf
pComponentEnd c = do pEnd
component <- pComponentName
if component == cName c
then return component
else unexpected $ "END:" ++ show (cName c)
pBegin = ciString "BEGIN:"
pEnd = ciString "END:"
pComponentName = ( VEVENT <$ ciString "VEVENT"
<|> VTODO <$ ciString "VTODO"
<|> VJOURNAL <$ ciString "VJOURNAL"
<|> VFREEBUSY <$ ciString "VFREEBUSY"
<|> VTIMEZONE <$ ciString "VTIMEZONE"
<|> X_c <$ ciString "X-" <*> many1 (alphaNum <|> char '-')
<|> STANDARD <$ ciString "STANDARD"
<|> DAYLIGHT <$ ciString "DAYLIGHT"
<|> VALARM <$ ciString "VALARM"
) <* crlf
pPropertyName = CALSCALE <$ ciString "CALSCALE"
<|> METHOD <$ ciString "METHOD"
<|> PRODID <$ ciString "PRODID"
<|> VERSION <$ ciString "VERSION"
<|> ATTACH <$ ciString "ATTACH"
<|> CATEGORIES <$ ciString "CATEGORIES"
<|> CLASS <$ ciString "CLASS"
<|> COMMENT <$ ciString "COMMENT"
<|> DESCRIPTION <$ ciString "DESCRIPTION"
<|> GEO <$ ciString "GEO"
<|> LOCATION <$ ciString "LOCATION"
<|> PERCENT_COMPLETE <$ ciString "PERCENT-COMPLETE"
<|> PRIORITY <$ ciString "PRIORITY"
<|> RESOURCES <$ ciString "RESOURCES"
<|> STATUS <$ ciString "STATUS"
<|> SUMMARY <$ ciString "SUMMARY"
<|> COMPLETED <$ ciString "COMPLETED"
<|> DTEND <$ ciString "DTEND"
<|> DUE <$ ciString "DUE"
<|> DTSTART <$ ciString "DTSTART"
<|> DURATION <$ ciString "DURATION"
<|> FREEBUSY <$ ciString "FREEBUSY"
<|> TRANSP <$ ciString "TRANSP"
<|> TZID <$ ciString "TZID"
<|> TZNAME <$ ciString "TZNAME"
<|> TZOFFSETFROM <$ ciString "TZOFFSETFROM"
<|> TZOFFSETTO <$ ciString "TZOFFSETTO"
<|> TZURL <$ ciString "TZURL"
<|> ATTENDEE <$ ciString "ATTENDEE"
<|> CONTACT <$ ciString "CONTACT"
<|> ORGANIZER <$ ciString "ORGANIZER"
<|> RECURRENCE_ID <$ ciString "RECURRENCE-ID"
<|> RELATED_TO <$ ciString "RELATED-TO"
<|> URL <$ ciString "URL"
<|> UID <$ ciString "UID"
<|> EXDATE <$ ciString "EXDATE"
<|> EXRULE <$ ciString "EXRULE"
<|> RDATE <$ ciString "RDATE"
<|> RRULE <$ ciString "RRULE"
<|> ACTION <$ ciString "ACTION"
<|> REPEAT <$ ciString "REPEAT"
<|> TRIGGER <$ ciString "TRIGGER"
<|> CREATED <$ ciString "CREATED"
<|> DTSTAMP <$ ciString "DTSTAMP"
<|> LAST_MODIFIED <$ ciString "LAST-MODIFIED"
<|> SEQUENCE <$ ciString "SEQUENCE"
<|> X_ <$ ciString "X-" <*> many1 (alphaNum <|> char '-')
<|> REQUEST_STATUS <$ ciString "REQUEST-STATUS"
pParamName = ( ALTREP <$ ciString "ALTREP"
<|> CN <$ ciString "CN"
<|> CUTYPE <$ ciString "CUTYPE"
<|> DELEGATED_FROM <$ ciString "DELEGATED-FROM"
<|> DELEGATED_TO <$ ciString "DELEGATED-TO"
<|> DIR <$ ciString "DIR"
<|> ENCODING <$ ciString "ENCODING"
<|> FMTYPE <$ ciString "FMTYPE"
<|> FBTYPE <$ ciString "FBTYPE"
<|> LANGUAGE <$ ciString "LANGUAGE"
<|> MEMBER <$ ciString "MEMBER"
<|> PARTSTAT <$ ciString "PARTSTAT"
<|> RANGE <$ ciString "RANGE"
<|> RELATED <$ ciString "RELATED"
<|> RELTYPE <$ ciString "RELTYPE"
<|> ROLE <$ ciString "ROLE"
<|> RSVP <$ ciString "RSVP"
<|> SENT_BY <$ ciString "SENT-BY"
<|> TZIDp <$ ciString "TZID"
<|> VALUE <$ ciString "VALUE"
<|> X_p <$ ciString "X-" <*> many1 (alphaNum <|> char '-')
) <* char '='