diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,19 @@ -*- mode: org -*- * Changelog +** 0.1.0.4 +*** Miscellany + - Comment improvement wibbles. + - Adding the =Attoparsec= combinator modules to the export module + list in the cabal package definition. +** 0.1.0.3 +*** Features + - Sub-headings are now parsed and tracked by its parent. + - Much more robust timestamp / clock / schedule parsing. + +*** Miscellany + - A good mount of code cleanup and comment improvement. + ** 0.0.2.1 *** Bugfixes - [X] Fixing the import for the =Internal= module (instead of diff --git a/orgmode-parse.cabal b/orgmode-parse.cabal --- a/orgmode-parse.cabal +++ b/orgmode-parse.cabal @@ -1,5 +1,5 @@ Name: orgmode-parse -Version: 0.1.0.3 +Version: 0.1.0.4 Author: Parnell Springmeyer Maintainer: Parnell Springmeyer License: BSD3 @@ -36,6 +36,11 @@ Exposed-Modules: Data.OrgMode.Parse Data.OrgMode.Parse.Types + Data.OrgMode.Parse.Attoparsec.Document + Data.OrgMode.Parse.Attoparsec.Headings + Data.OrgMode.Parse.Attoparsec.PropertyDrawer + Data.OrgMode.Parse.Attoparsec.Section + Data.OrgMode.Parse.Attoparsec.Time Build-Depends: base >= 4.4 && < 5 diff --git a/src/Data/OrgMode/Parse/Attoparsec/Document.hs b/src/Data/OrgMode/Parse/Attoparsec/Document.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Parse/Attoparsec/Document.hs @@ -0,0 +1,21 @@ +module Data.OrgMode.Parse.Attoparsec.Document ( + parseDocument +) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Attoparsec.Text +import Data.Attoparsec.Types as TP +import Prelude hiding (unlines) +import Data.Text (Text, pack, unlines) +import Data.OrgMode.Parse.Types +import Data.OrgMode.Parse.Attoparsec.Headings + +------------------------------------------------------------------------------ +parseDocument :: [Text] -> TP.Parser Text Document +parseDocument otherKeywords = + Document + <$> (unlines <$> many' nonHeaderLine) + <*> many' (headingBelowLevel otherKeywords 0) + +nonHeaderLine :: TP.Parser Text Text +nonHeaderLine = pack <$> manyTill (notChar '*') endOfLine diff --git a/src/Data/OrgMode/Parse/Attoparsec/Headings.hs b/src/Data/OrgMode/Parse/Attoparsec/Headings.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Parse/Attoparsec/Headings.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.OrgMode.Parse.Attoparsec.Headings +-- Copyright : © 2014 Parnell Springmeyer +-- License : All Rights Reserved +-- Maintainer : Parnell Springmeyer +-- Stability : stable +-- +-- Parsing combinators for org-list headings. +---------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.OrgMode.Parse.Attoparsec.Headings +( headingBelowLevel +, headingLevel +, headingPriority +, parseStats +, parseTags +) +where + +import Control.Applicative (pure, (*>), (<$>), (<*), + (<*>), (<|>)) +import Control.Monad (liftM5, void) +import Data.Attoparsec.Text as T +import Data.Attoparsec.Types as TP (Parser) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty) +import Data.Text as Text (Text, append, + init, last, + length, null, + splitOn, strip) +import Prelude hiding (concat, null, + sequence_, takeWhile, + unlines) +import Text.Printf + +import Data.OrgMode.Parse.Attoparsec.Section +import Data.OrgMode.Parse.Types + + +-- | Parse an org-mode heading and its contained entities (see ). +-- +-- Headers include a hierarchy level indicated by asterisks, optional +-- todo states, priority level, %-done stats, and tags. +-- +-- > ** TODO [#B] Polish Poetry Essay [25%] :HOMEWORK:POLISH:WRITING: +-- +-- Headings may contain: +-- +-- - A section with Planning and Clock entries +-- - A number of other not-yet-implemented entities (code blocks, lists) +-- - Unstructured text +-- - Other heading deeper in the hierarchy +-- +-- 'headingBelowLevel' takes a list of terms to consider, state +-- keywords, and a minumum hierarchy depth. Use 0 to parse any +-- heading. +headingBelowLevel :: [Text] -> LevelDepth -> TP.Parser Text Heading +headingBelowLevel stateKeywords depth = do + lvl <- headingLevel depth <* skipSpace' + td <- option Nothing (Just <$> parseStateKeyword stateKeywords <* skipSpace') + pr <- option Nothing (Just <$> headingPriority <* skipSpace') + + TitleMeta tl stats' (fromMaybe [] -> tags') <- takeTitleExtras + + sect <- parseSection + subs <- option [] $ many' (headingBelowLevel stateKeywords (depth + 1)) + + skipSpace + + return $ Heading lvl td pr tl stats' tags' sect subs + +-- | Parse the asterisk indicated heading level until a space is +-- reached. +-- +-- Constrain it to LevelDepth or its children. +headingLevel :: LevelDepth -> TP.Parser Text Level +headingLevel (LevelDepth d) = takeLevel >>= test + where + takeLevel = Text.length <$> takeWhile1 (== '*') + test l | l <= d = fail $ printf "Heading level of %d cannot be higher than depth %d" l d + | otherwise = return $ Level l + +-- | Parse the state indicator. +-- +-- > {`TODO` | `DONE` | custom } +-- +-- These can be custom so we're parsing additional state identifiers +-- as Text. +parseStateKeyword :: [Text] -> TP.Parser Text StateKeyword +parseStateKeyword (map string -> sk) = StateKeyword <$> choice sk + +-- | Parse the priority indicator. +-- +-- If anything but these priority indicators are used the parser will +-- fail: +-- +-- - @[#A]@ +-- - @[#B]@ +-- - @[#C]@ +headingPriority :: TP.Parser Text Priority +headingPriority = start *> zipChoice <* end + where + zipChoice = choice (zipWith mkPParser "ABC" [A,B,C]) + mkPParser c p = char c *> pure p + start = string "[#" + end = char ']' + +-- | Parse the title, optional stats block, and optional tag. +-- +-- Stats may be either [m/n] or [n%] and tags are colon-separated, e.g: +-- > :HOMEWORK:POETRY:WRITING: +takeTitleExtras :: TP.Parser Text TitleMeta +takeTitleExtras = + liftM5 mkTitleMeta + titleStart + (optionalMetadata parseStats) + (optionalMetadata parseTags) + leftovers + (void $ endOfLine <|> endOfInput) + where + titleStart = takeTill (\c -> inClass "[:" c || isEndOfLine c) + leftovers = option mempty $ takeTill (== '\n') + optionalMetadata p = option Nothing (Just <$> p <* skipSpace') + + +mkTitleMeta :: Text -> Maybe Stats -> Maybe [Tag] -> Text -> () -> TitleMeta +mkTitleMeta start stats' tags' leftovers _ = + TitleMeta (transformTitle start leftovers) stats' tags' + where + transformTitle t l | null leftovers = strip t + | otherwise = append t l + +-- | Parse a stats block. +-- +-- Accepts either form: "[m/n]" or "[n%]" and there is no restriction +-- on m or n other than that they are integers. +parseStats :: TP.Parser Text Stats +parseStats = sPct <|> sOf + where sPct = StatsPct + <$> (char '[' *> decimal <* string "%]") + sOf = StatsOf + <$> (char '[' *> decimal) + <*> (char '/' *> decimal <* char ']') + +-- | Parse a colon-separated list of Tags +-- +-- > :HOMEWORK:POETRY:WRITING: +parseTags :: TP.Parser Text [Tag] +parseTags = tags' >>= test + where + tags' = (char ':' *> takeWhile (/= '\n')) + test t | (Text.last t /= ':' || Text.length t < 2) = fail "Not a valid tag set" + | otherwise = return (splitOn ":" (Text.init t)) + +skipSpace' :: TP.Parser Text () +skipSpace' = void $ takeWhile spacePred + where + spacePred s = s == ' ' || s == '\t' diff --git a/src/Data/OrgMode/Parse/Attoparsec/PropertyDrawer.hs b/src/Data/OrgMode/Parse/Attoparsec/PropertyDrawer.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Parse/Attoparsec/PropertyDrawer.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.OrgMode.Parse.Attoparsec.PropertyDrawer +-- Copyright : © 2014 Parnell Springmeyer +-- License : All Rights Reserved +-- Maintainer : Parnell Springmeyer +-- Stability : stable +-- +-- Parsing combinators for org-mode entry property drawers. +---------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} + + +module Data.OrgMode.Parse.Attoparsec.PropertyDrawer +( parseDrawer +, property +) +where + +import Control.Applicative ((*>), (<*)) +import Data.Attoparsec.Text as T +import Data.Attoparsec.Types as TP +import Data.HashMap.Strict (fromList) +import Data.Text as Text (Text, strip) +import Prelude hiding (concat, null, takeWhile) + +import Data.OrgMode.Parse.Types + +type PropertyKey = Text +type PropertyVal = Text + +-- | Parse a property drawer. +-- +-- > :PROPERTIES: +-- > :DATE: [2014-12-14 11:00] +-- > :NOTE: Something really crazy happened today! +-- > :END: +parseDrawer :: TP.Parser Text Properties +parseDrawer = return . fromList =<< begin *> manyTill property end + where + begin = ident "PROPERTIES" + end = ident "END" + ident v = skipSpace *> skip (== ':') *> + asciiCI v <* + skip (== ':') <* skipSpace + +-- | Parse a property of a drawer. +-- +-- Properties *must* be a `:KEY: value` pair, the key can be of any +-- case and contain any characters except for newlines and colons +-- (since they delimit the start and end of the key). +property :: TP.Parser Text (PropertyKey, PropertyVal) +property = do + key <- skipSpace *> skip (== ':') *> takeWhile1 (/= ':') <* skip (== ':') + val <- skipSpace *> takeValue + return (key, strip val) + where + takeValue = takeWhile1 (not . isEndOfLine) diff --git a/src/Data/OrgMode/Parse/Attoparsec/Section.hs b/src/Data/OrgMode/Parse/Attoparsec/Section.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Parse/Attoparsec/Section.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.OrgMode.Parse.Attoparsec.Section +-- Copyright : © 2015 Parnell Springmeyer +-- License : All Rights Reserved +-- Maintainer : Parnell Springmeyer +-- Stability : stable +-- +-- Parsing combinators for org-mode sections. +---------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} + +module Data.OrgMode.Parse.Attoparsec.Section where + +import Control.Applicative ((<$>), (<*>)) +import Data.Attoparsec.Text as T +import Data.Attoparsec.Types as TP +import Data.Monoid (mempty) +import Data.Text (Text, pack, + unlines) +import Prelude hiding (unlines) + +import Data.OrgMode.Parse.Attoparsec.PropertyDrawer +import Data.OrgMode.Parse.Attoparsec.Time +import Data.OrgMode.Parse.Types + +-- | Parse a heading section +-- +-- Heading sections contain optionally a property drawer, +-- a list of clock entries, code blocks (not yet implemented), +-- plain lists (not yet implemented), and unstructured text. +parseSection :: TP.Parser Text Section +parseSection = Section + <$> (Plns <$> parsePlannings) + <*> many' parseClock + <*> option mempty parseDrawer + <*> (unlines <$> many' nonHeaderLine) + where + nonHeaderLine = pack <$> manyTill (notChar '*') endOfLine diff --git a/src/Data/OrgMode/Parse/Attoparsec/Time.hs b/src/Data/OrgMode/Parse/Attoparsec/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Parse/Attoparsec/Time.hs @@ -0,0 +1,234 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.OrgMode.Parse.Attoparsec.Time +-- Copyright : © 2014 Parnell Springmeyer +-- License : All Rights Reserved +-- Maintainer : Parnell Springmeyer +-- Stability : stable +-- +-- Parsing combinators for org-mode active and inactive timestamps. +---------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.OrgMode.Parse.Attoparsec.Time where + +import Control.Applicative (pure, (*>), (<$>), (<*), (<*>), + (<|>)) +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 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 + +-- | Parse a planning line. +-- +-- Plannings inhabit a heading section and are formatted as a keyword +-- and a timestamp. There can be more than one, but they are all on +-- the same line e.g: +-- +-- > DEADLINE: <2015-05-10 17:00> CLOSED: <2015-04-1612:00> +parsePlannings :: TP.Parser Text (HashMap PlanningKeyword Timestamp) +parsePlannings = fromList <$> (many' (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 + ] + +-- | Parse a clock line. +-- +-- A heading's section contains one line per clock entry. Clocks may +-- have a timestamp, a duration, both, or neither e.g.: +-- +-- > CLOCK: [2014-12-10 Fri 2:30]--[2014-12-10 Fri 10:30] => 08:00 +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)) + +-- | Parse a timestamp. +-- +-- Timestamps may be timepoints or timeranges, and they indicate +-- whether they are active or closed by using angle or square brackets +-- respectively. +-- +-- Time ranges are formatted by infixing two timepoints with a double +-- hyphen, @--@; or, by appending two @hh:mm@ timestamps together in a +-- single timepoint with one hyphen @-@. +-- +-- Each timepoint includes an optional repeater flag and an optional +-- delay flag. +parseTimestamp :: TP.Parser Text Timestamp +parseTimestamp = do + (ts1, tsb1, act) <- transformBracketedDateTime <$> parseBracketedDateTime + + -- Such ew, so gross, much clean, very needed + blk2 <- liftM (maybe Nothing (Just . transformBracketedDateTime)) + optionalBracketedDateTime + + -- TODO: this is grody, I'd like to refactor this truth table logic + -- and make the transformations chainable and composable as opposed + -- to depending on case matching blocks. - Parnell + 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) + +-- | Parse a single time part. +-- +-- > [2015-03-27 Fri 10:20 +4h] +-- +-- Returns: +-- +-- - The basic timestamp +-- - Whether there was a time interval in place of a single time +-- (this will be handled upstream by parseTimestamp) +-- - Whether the time is active or inactive +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 + +-- TODO: this function is also grody but it's better than having this +-- logic in the primary parseBracketedDateTime function. - Parnell +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) + +-- | Parse a 3-character day name. +parseDay :: TP.Parser Text Text +parseDay = choice (map string ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]) + +type AbsoluteTime = (Hours, Minutes) +type TimestampRange = (AbsoluteTime, AbsoluteTime) + +newtype TimePart = TimePart (Either AbsoluteTime TimestampRange) + deriving (Eq, Ord, Show) + +-- | Parse the time-of-day part of a time part, as a single point or a +-- time range. +parseTime' :: TP.Parser Text TimePart +parseTime' = + TimePart <$> choice [ Right <$> ((,) <$> parseHM <* char '-' <*> parseHM) + , Left <$> parseHM + ] + +-- | Parse the YYYY-MM-DD part of a time part. +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" + +-- | Parse a single @HH:MM@ point. +parseHM :: TP.Parser Text (Hours, Minutes) +parseHM = (,) <$> decimal <* char ':' <*> decimal + +-- | Parse the Timeunit part of a delay or repeater flag. +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 + ] + +-- | Parse a repeater flag, e.g. @.+4w@, or @++1y@. +parseRepeater :: TP.Parser Text Repeater +parseRepeater = + Repeater + <$> choice[ string "++" *> pure RepeatCumulate + , char '+' *> pure RepeatCatchUp + , string ".+" *> pure RepeatRestart + ] + <*> decimal + <*> parseTimeUnit + +-- | Parse a delay flag, e.g. @--1d@ or @-2w@. +parseDelay :: TP.Parser Text Delay +parseDelay = + Delay + <$> choice [ string "--" *> pure DelayFirst + , char '-' *> pure DelayAll + ] + <*> decimal + <*> parseTimeUnit