{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Article (
      Article(..)
    , at
    , getKey
    , preview
  ) where

import Control.Applicative ((<|>))
import Data.Map (Map)
import qualified Data.Map as Map (fromList, alter)
import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import System.Directory (getModificationTime)
import System.FilePath (dropExtension, takeFileName)
import Text.ParserCombinators.Parsec (
      ParseError
    , Parser
    , (<?>)
    , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
    , oneOf, option, parse, skipMany, sourceLine, string, try
  )

type Metadata = Map String String

data Article = Article {
      key :: String
    , title :: String
    , metadata :: Metadata
    , bodyOffset :: Int
    , body :: [String]
  }

type ProtoArticle = (String, Metadata, Int, [String])

articleP :: Parser ProtoArticle
articleP =
  skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP
  where
    headerP =
        try ((,,,) <$> titleP <* many eol <*> metadataP)
      <|> flip (,,,) <$> metadataP  <* many eol<*> titleP
    lineOffset = pred . sourceLine <$> getPosition
    bodyP = lines <$> many anyChar <* eof

metadataP :: Parser Metadata
metadataP = Map.fromList <$> option [] (
    metaSectionSeparator *> many eol *>
    (try keyVal) `endBy` (many1 eol)
    <* metaSectionSeparator
  ) <?> "metadata section"
  where
    metaSectionSeparator = count 3 (oneOf "~-") *> eol
    spaces = skipMany $ char ' '
    keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n"

titleP :: Parser String
titleP = try (singleLine <|> underlined)
  where
    singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
    underlined =
      no "\r\n" <* eol
      >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
      <?> "'#' or '=' to underline the title"

eol :: Parser String
eol = try (string "\r\n") <|> string "\r" <|> string "\n" <?> "newline"

no :: String -> Parser String
no = many1 . noneOf

getTimestamp :: UTCTime -> String
getTimestamp = show . (truncate :: POSIXTime -> Integer) . utcTimeToPOSIXSeconds

setDate :: String -> String -> Metadata -> Metadata
setDate tzOffset defaultDate = Map.alter timeStamp "date"
  where
    formats = ("%Y-%m-%d" ++) . (++ " %z") <$> ["", " %H:%M"]
    timeStamp = maybe (Just defaultDate) $ \date ->
      let dates = [date, date ++ " " ++ tzOffset] in
      let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in
      foldr (<|>) (timeStamp Nothing) (fmap getTimestamp <$> parsedTimes)

makeArticle :: FilePath -> (Metadata -> Metadata) -> ProtoArticle -> (String, Article)
makeArticle filePath metaFilter (title, metadata, bodyOffset, body) = (
      getKey filePath
    , Article {
          key = getKey filePath
        , title
        , metadata = metaFilter metadata
        , bodyOffset
        , body
      }
  )

at :: FilePath -> IO (Either ParseError (String, Article))
at filePath = do
  tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
  fileDate <- getTimestamp <$> getModificationTime filePath
  let build = makeArticle filePath (setDate tzOffset fileDate)
  fmap build . parse articleP filePath <$> readFile filePath

getKey :: FilePath -> String
getKey = dropExtension . takeFileName

preview :: Int -> Article -> Article
preview linesCount article = article {body = take linesCount $ body article}