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
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
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
parseStateKeyword :: [Text] -> TP.Parser Text StateKeyword
parseStateKeyword (map string -> sk) = StateKeyword <$> choice sk
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 ']'
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
parseStats :: TP.Parser Text Stats
parseStats = sPct <|> sOf
where sPct = StatsPct
<$> (char '[' *> decimal <* string "%]")
sOf = StatsOf
<$> (char '[' *> decimal)
<*> (char '/' *> decimal <* char ']')
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'