ical (empty) → 0.0.0
raw patch · 10 files changed
+569/−0 lines, 10 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, containers, either, ical, mtl, text, time, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- ical.cabal +51/−0
- src/ICal.hs +14/−0
- src/ICal/Org.hs +164/−0
- src/ICal/Parser.hs +150/−0
- src/ICal/Tokenizer.hs +105/−0
- src/ICal/Types.hs +28/−0
- src/main/Org.hs +23/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Chris Done (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Chris Done nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER OR 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.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ical.cabal view
@@ -0,0 +1,51 @@+name: ical+version: 0.0.0+synopsis: iCalendar format parser and org-mode converter.+description: Please see README.md+homepage: http://github.com/chrisdone/ical#readme+license: BSD3+license-file: LICENSE+author: Chris Done+maintainer: chrisdone@gmail.com+copyright: 2015 Chris Done+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: ICal, ICal.Types, ICal.Org, ICal.Tokenizer, ICal.Parser+ build-depends: aeson >= 0.8.0.2+ , attoparsec >= 0.12.1.6+ , base >= 4.7 && < 5+ , containers >= 0.5.6.2+ , either >= 4.4.1+ , mtl >= 2.2.1+ , text >= 1.2.1.3+ , time >= 1.5.0.1+ , transformers >= 0.4.2.0+ default-language: Haskell2010++executable ical-org+ hs-source-dirs: src/main+ ghc-options: -Wall+ main-is: Org.hs+ build-depends: base >= 4.7 && < 5+ , ical+ , time+ default-language: Haskell2010++test-suite ical-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , ical+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/chrisdone/ical
+ src/ICal.hs view
@@ -0,0 +1,14 @@+-- | Basic parser for ICalendar format.++module ICal+ (-- * Top-level functions+ tokenizeObjectFromFile+ ,tokenizeObjectFromText+ ,tokenizeAesonFromText+ -- * Types+ ,Object(..)+ ,Line(..))+ where++import ICal.Types+import ICal.Tokenizer
+ src/ICal/Org.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- | Export to Org mode for Emacs.++module ICal.Org+ (-- * Handy export functions+ exportFromToFile+ ,parseFromObject+ -- * Conversions+ ,documentParser+ ,buildDocument+ -- * Types+ ,Event (..)+ )+ where++import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Identity+import Data.Ord+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as LT+import qualified Data.Text.Lazy.IO as LT+import Data.Time+import ICal+import ICal.Parser+import ICal.Types++-- | An Org mode section.+data Event =+ Event {eventTitle :: !Text -- ^ Title of the section.+ ,eventStart :: !UTCTime -- ^ Date starts.+ ,eventDescription :: !(Maybe Text) -- ^ Contents of the section.+ ,eventEnd :: !(Maybe UTCTime) -- ^ Date ends.+ ,eventCreated :: !UTCTime -- ^ Date created.+ }+ deriving (Show)++-- | Handy exporting function.+exportFromToFile :: Day -> FilePath -> FilePath -> IO ()+exportFromToFile base from to =+ do obj <- tokenizeObjectFromFile from+ today <- getCurrentTime+ case parseFromObject obj of+ Left er -> error (show er)+ Right es ->+ LT.writeFile to+ (LT.toLazyText (buildDocument base today es))++-- | Parse an iCalendar object into an Org mode document.+parseFromObject :: Object -> Either ParseError [Event]+parseFromObject s = runIdentity (parseEither s documentParser)++-- | Build an org-mode document.+buildDocument :: Day -> UTCTime -> [Event] -> Builder+buildDocument base today =+ mconcat .+ map build .+ dropWhile (\e ->+ utctDay (fromMaybe (eventStart e)+ (eventEnd e)) <+ base) .+ sortBy (comparing eventStart)+ where build event =+ mconcat ["* " <> todo <> LT.fromText (eventTitle event)+ ,"\n"+ ," SCHEDULED: <" <> formatDate (eventStart event) <> ">"+ ,if fromMaybe (eventStart event)+ (eventEnd event) >+ today+ then ""+ else "\n - State \"DONE\" from \"TODO\" [" <>+ formatDate+ (fromMaybe (eventStart event)+ (eventEnd event)) <>+ "]\n"+ ,"\n"]+ where formatDate =+ LT.fromText .+ T.pack . formatTime defaultTimeLocale "%Y-%m-%d"+ todo =+ if fromMaybe (eventStart event)+ (eventEnd event) >+ today+ then "TODO "+ else "DONE "++-- | Parse an org-mode document from the object.+documentParser :: Parser Identity Object [Event]+documentParser =+ begin "VCALENDAR"+ (do version <- property "VERSION"+ unless (version == "2.0")+ (parseError (GeneralProblem "Expected document version 2.0."))+ scale <- property "CALSCALE"+ unless (scale == "GREGORIAN")+ (parseError (GeneralProblem "Need time gregorian scale."))+ timezones <- fmap M.fromList (objects "VTIMEZONE" timeZoneParser)+ events <- objects "VEVENT" (eventParser timezones)+ return events)++-- | Parse a time zone.+timeZoneParser :: Parser Identity [Object] (Text,TimeZone)+timeZoneParser =+ do key <- property "TZID"+ return (key,utc)++-- | Parse an event.+eventParser :: Map Text TimeZone -> Parser Identity [Object] Event+eventParser timezones =+ do start <- property "DTSTART" >>= utcTimeParser timezones+ end <- optional (property "DTEND" >>= utcTimeParser timezones)+ created <- property "CREATED" >>= utcTimeParser timezones+ description <- optional (property "DESCRIPTION")+ summary <- property "SUMMARY"+ return (Event {eventTitle = summary+ ,eventStart = start+ ,eventEnd = end+ ,eventDescription = description+ ,eventCreated = created})++-- | Parse a time field into a UTCTime.+utcTimeParser :: Map Text TimeZone -> Text -> Parser Identity s UTCTime+utcTimeParser timezones s =+ case T.stripPrefix "VALUE=DATE:" s of+ Just s' ->+ case justdate s' of+ Nothing ->+ parseError (GeneralProblem ("Unable to parse date from " <> s'))+ Just t -> return t+ Nothing ->+ case T.stripPrefix "TZID=" s of+ Just tzPlusDate ->+ case T.break (== ':') tzPlusDate of+ (tz,T.drop 1 -> date) ->+ case datetime "" date of+ Just t -> return t+ Nothing ->+ parseError (GeneralProblem ("Couldn't parse: " <> date))+ Nothing ->+ case datetime "Z" s of+ Just t -> return t+ Nothing ->+ parseError (GeneralProblem ("Invalid date property: " <> s))+ where datetime z s' =+ parseTimeM True+ defaultTimeLocale+ ("%Y%m%dT%H%M%S" ++ z)+ (T.unpack s')+ justdate s' =+ fmap (\d -> UTCTime d 0)+ (parseTimeM True+ defaultTimeLocale+ "%Y%m%d"+ (T.unpack s'))
+ src/ICal/Parser.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}++-- | The basic parser.++module ICal.Parser+ (-- * Types+ Parser+ ,ParseError(..)+ -- * Handy starter functions+ ,parseEither+ -- * Combinators+ ,begin+ ,object+ ,objects+ ,property+ ,properties+ -- * Parser library+ ,local+ ,parseError+ ,getState+ ,putState)+ where++import Control.Applicative+import Control.Monad.State.Strict+import Control.Monad.Trans.Either+import Data.List+import Data.Maybe+import Data.Text (Text)+import ICal.Types++-- | A parse error.+data ParseError+ = ExpectedObject !Text+ | ExpectedProperty !Text+ | GeneralProblem !Text+ deriving (Show)++-- | Parse some iCalendar thing.+parseEither+ :: Monad m+ => s -> Parser m s a -> m (Either ParseError a)+parseEither s p =+ evalStateT (runEitherT (runParser p))+ s++-- | Parser type.+newtype Parser m s a =+ Parser {runParser :: EitherT ParseError (StateT s m) a}+ deriving (Monad,Applicative,Functor)++-- | Left branch failing resets the state.+instance Monad m => Alternative (Parser m s) where+ Parser x <|> Parser y =+ Parser (do s <- get+ r <-+ EitherT (do r <- runEitherT x+ return (Right r))+ case r of+ Left{} -> do put s+ y+ Right ok -> return ok)+ empty = parseError (GeneralProblem "empty parser")++-- | Lookup a property.+property :: Monad m+ => Text -- ^ Key+ -> Parser m [Object] Text -- ^ The value of that property.+property !key =+ do os <- getState+ case listToMaybe+ (mapMaybe (\case+ Property name value+ | name == key -> Just value+ _ -> Nothing)+ os) of+ Nothing -> parseError (ExpectedProperty key)+ Just x -> return x++-- | Get all values of a property.+properties :: Monad m+ => Text -- ^ Key+ -> Parser m [Object] [Text] -- ^ The values of that property.+properties !key =+ do os <- getState+ return (mapMaybe (\case+ Property name value+ | name == key -> Just value+ _ -> Nothing)+ os)++-- | Lookup an object with this name in the current object's children,+-- then run with that object as the context.+object :: Monad m => Text -> Parser m [Object] a -> Parser m [Object] a+object !name m =+ do os <- getState+ case find (\case+ Object name' _ -> name' == name+ _ -> False) os of+ Just (Object _ children) ->+ local children m+ _ -> parseError (ExpectedObject name)++-- | Lookup objects with this name in the current object's children,+-- then run with that object as the context.+objects :: Monad m => Text -> Parser m [Object] a -> Parser m [Object] [a]+objects !name m =+ do os <- getState+ case mapMaybe (\case+ Object name' children+ | name' == name -> Just children+ _ -> Nothing)+ os of+ cs -> mapM (\children -> local children m) cs++-- | Require the given object name to exist and run in that context.+begin :: Monad m => Text -> Parser m [Object] a -> Parser m Object a+begin !name m =+ do o <- getState+ case o of+ Object name' children ->+ if name' == name+ then local children m+ else parseError (ExpectedObject name)+ _ -> parseError (ExpectedObject name)++-- | Use a local state of a different type.+local :: Monad m+ => t -> Parser m t a -> Parser m s a+local temp m =+ Parser (EitherT (StateT (\orig ->+ do (result,_new) <-+ runStateT (runEitherT (runParser m)) temp+ return (result,orig))))++-- | Throw a parse error.+parseError :: Monad m => ParseError -> Parser m o a+parseError = Parser . left++-- | Get the current state.+getState :: Monad m => Parser m s s+getState = Parser get++-- | Put a new state.+putState :: Monad m => s -> Parser m s ()+putState = Parser . put
+ src/ICal/Tokenizer.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}++-- | The basic tokenizer.++module ICal.Tokenizer+ (-- * Top-level functions+ tokenizeObjectFromFile+ ,tokenizeObjectFromText+ ,tokenizeAesonFromText+ -- * Raw tokenizers+ ,objectTokenizer+ ,linesTokenizer+ ,lineTokenizer)+ where++import Control.Monad.Fix+import Data.Aeson (FromJSON(..),toJSON,fromJSON,Result(..))+import Data.Attoparsec.Text (Parser)+import qualified Data.Attoparsec.Text as P+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import ICal.Types++-- | Tokenizer a complete document from a .ics file.+tokenizeObjectFromFile :: FilePath -> IO Object+tokenizeObjectFromFile fp =+ fmap tokenizeObjectFromText (T.readFile fp) >>=+ \case+ Left err -> error err+ Right ok -> return ok++-- | Tokenizer a complete document.+tokenizeObjectFromText :: Text -> Either String Object+tokenizeObjectFromText t =+ do ls <- P.parseOnly linesTokenizer t+ (object,remainder) <- objectTokenizer ls+ if null remainder+ then return object+ else Left ("Unexpected extraneous input: " ++ show remainder)++-- | Tokenize an Aeson instance from the document.+tokenizeAesonFromText :: FromJSON a => Text -> Either String a+tokenizeAesonFromText t =+ do doc <- tokenizeObjectFromText t+ case fromJSON (toJSON doc) of+ Error e -> Left e+ Success a -> Right a++-- | Tokenize a list of lines into an object.+objectTokenizer :: [Line] -> Either String (Object,[Line])+objectTokenizer [] = Left "Unexpected end of input."+objectTokenizer (Begin name:linesInAndAfterObject) =+ do (values,linesAfterObject) <-+ fix (\loop ->+ \case+ [] -> return ([],[])+ nextLineSet@(next:linesAfterObject) ->+ case next of+ End{} -> return ([],linesAfterObject)+ _ ->+ do (x,linesAfterChildObject) <- objectTokenizer nextLineSet+ (xs,linesAfterRestOfChildren) <-+ loop linesAfterChildObject+ return (x : xs,linesAfterRestOfChildren))+ linesInAndAfterObject+ return (Object name values,linesAfterObject)+objectTokenizer (Pair key value:linesAfterPair) =+ return (Property key value,linesAfterPair)+objectTokenizer (End name:_) =+ Left ("Unexpected end of object: " ++ show name)++-- | Tokenize lines of iCalendar format.+linesTokenizer :: Parser [Line]+linesTokenizer = P.many1 lineTokenizer++-- | Tokenize a single line.+lineTokenizer :: Parser Line+lineTokenizer =+ do (key,value) <- propertyTokenizer+ case key of+ "BEGIN" -> return (Begin value)+ "END" -> return (End value)+ _ -> return (Pair key value)++-- | Tokenize a (possibly-mult-line) property.+propertyTokenizer :: Parser (Text,Text)+propertyTokenizer =+ do key <- P.takeWhile1 (not . propertySeparator)+ _ <- P.satisfy propertySeparator+ fmap ((key,) . T.concat)+ (fix (\loop ->+ do value <- P.takeTill newline+ _ <- P.takeWhile1 newline+ mnext <- P.peekChar+ case mnext of+ Just ' ' ->+ do _ <- P.anyChar+ rest <- loop+ return (value : rest)+ _ -> return [value]))+ where propertySeparator c = c == ':' || c == ';'+ newline c = c == '\r' || c == '\n'
+ src/ICal/Types.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++-- | All iCalendar types.++module ICal.Types where++import Data.Text (Text)+import Data.Aeson (ToJSON(..),object,(.=))++-- | Tree for representing iCal file.+data Object+ = Property !Text -- name+ !Text -- value+ | Object !Text -- name+ ![Object] -- values+ deriving (Show)++instance ToJSON Object where+ toJSON (Object name values) = object ["name" .= name,"values" .= values]+ toJSON (Property key value) = object ["key" .= key,"value" .= value]++-- | An iCalendar line.+data Line+ = Begin !Text -- object name+ | End !Text -- object name+ | Pair !Text -- name+ !Text -- value+ deriving (Show)
+ src/main/Org.hs view
@@ -0,0 +1,23 @@+-- | Export .org file from an iCalendar file.++import Data.List+import Data.Maybe+import Data.Time+import ICal.Org+import System.Environment++-- | Export .org file from an iCalendar file.+main :: IO ()+main =+ do args <- getArgs+ let files = filter (not . isPrefixOf "--") args+ opts = filter (isPrefixOf "--") args+ case files of+ [ics,org] ->+ do let base =+ fromMaybe (fromGregorian 1970 01 01)+ (do dateString <-+ listToMaybe (mapMaybe (stripPrefix "--base=") opts)+ parseTimeM True defaultTimeLocale "%Y-%m-%d" dateString)+ exportFromToFile base ics org+ _ -> error "expected <input.ics> <output.org> [--base=YYYY-MM-DD (default: 1970-01-01)]"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"