Parser.hs

-- | Org-mode format parsing.

module OrgStat.Parser
       ( ParsingException (..)
       , parseOrg
       , runParser
       ) where

import Universum

import qualified Data.Attoparsec.Text as A
import Data.Char (isSpace)
import qualified Data.OrgMode.Parse as O
import qualified Data.OrgMode.Types as O
import qualified Data.Text as T
import Data.Time (LocalTime(..), TimeOfDay(..), fromGregorian, getZonedTime, zonedTimeToLocalTime)
import Data.Time.Calendar ()

import OrgStat.Ast (Clock(..), Org(..), orgTags, traverseTree)

----------------------------------------------------------------------------
-- Exceptions
----------------------------------------------------------------------------

data ParsingException = ParsingException Text
    deriving (Show, Typeable)

instance Exception ParsingException

----------------------------------------------------------------------------
-- Parsing
----------------------------------------------------------------------------

parseOrg :: LocalTime -> [Text] -> A.Parser Org
parseOrg curTime todoKeywords = convertDocument <$> O.parseDocument todoKeywords
  where
    convertDocument :: O.Document -> Org
    convertDocument (O.Document textBefore headings) =
        let fileLvlTags = extractFileTags textBefore
            addTags t = ordNub $ fileLvlTags <> t
            o = Org { _orgTitle    = ""
                    , _orgTags     = []
                    , _orgClocks   = []
                    , _orgSubtrees = map convertHeading headings
                    }
        in o & traverseTree . orgTags %~ addTags

    convertHeading :: O.Headline -> Org
    convertHeading headline = Org
        { _orgTitle    = O.title headline
        , _orgTags     = O.tags headline
        , _orgClocks   = getClocks $ O.section headline
        , _orgSubtrees = map convertHeading $ O.subHeadlines headline
        }

    mapEither :: (a -> Either e b) -> ([a] -> [b])
    mapEither f xs = rights $ map f xs

    getClocks :: O.Section -> [Clock]
    getClocks section =
        mapMaybe convertClock $ concat
          [ O.sectionClocks section
          , O.unLogbook (O.sectionLogbook section)
          , mapEither (A.parseOnly O.parseClock) $ concat
            [ concatMap lines $ map O.contents $ O.sectionDrawers section
            , lines $ O.sectionParagraph section
            ]
          ]

    -- convert clocks from orgmode-parse format, returns Nothing for clocks
    -- without end time or time-of-day
    convertClock :: O.Clock -> Maybe Clock
    convertClock (O.Clock (Just (O.Timestamp start _active (Just end)), _duration)) =
        Clock <$> convertDateTime start <*> convertDateTime end
    convertClock (O.Clock (Just (O.Timestamp start _active Nothing), _duration)) =
        Clock <$> convertDateTime start <*> pure curTime
    convertClock _                                                 = Nothing

    -- Nothing for DateTime without time-of-day
    convertDateTime :: O.DateTime -> Maybe LocalTime
    convertDateTime
        O.DateTime
          { yearMonthDay = O.YearMonthDay year month day
          , hourMinute = Just (hour, minute)
          }
      = Just $ LocalTime
          (fromGregorian (toInteger year) month day)
          (TimeOfDay hour minute 0)
    convertDateTime _ = Nothing

    extractFileTags (T.lines -> inputLines) =
        let prfx = "#+FILETAGS: "
            matching =
                map (T.drop (length prfx)) $
                (filter (prfx `T.isPrefixOf`) inputLines)
            toTags (T.strip -> line) =
                let parts = filter (not . T.null) $ T.splitOn ":" line
                    -- Correct tag shouldn't contain spaces inside
                    correctPart p = not $ T.any isSpace p
                in if all correctPart parts then parts else []
        in ordNub $ concatMap toTags matching

-- Throw parsing exception if it can't be parsed (use Control.Monad.Catch#throwM)
runParser :: (MonadIO m, MonadThrow m) => [Text] -> Text -> m Org
runParser todoKeywords t = do
    localTime <- liftIO $ zonedTimeToLocalTime <$> getZonedTime
    case A.parseOnly (parseOrg localTime todoKeywords) t of
      Left err  -> throwM $ ParsingException $ T.pack err
      Right res -> pure res