{-# LANGUAGE NamedFieldPuns #-}
module Markdown (
      Markdown(..)
    , MarkdownContent(..)
    , Metadata
    , at
    , getKey
  ) where

import Control.Applicative ((<|>))
import Data.Map (Map)
import qualified Data.Map as Map (fromList)
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, sourceName, string, try
  )

type Metadata = Map String String
data Markdown = Markdown {
      key :: String
    , path :: String
    , title :: String
    , metadata :: Metadata
    , bodyOffset :: Int
    , body :: [String]
  }

class MarkdownContent a where
  getMarkdown :: a -> Markdown

parser :: Parser Markdown
parser = do
  (title, metadata) <- skipMany eol *> (headerP <|> reverseHeaderP)
  bodyOffset <- skipMany eol *> (pred . sourceLine <$> getPosition)
  body <- lines <$> many anyChar <* eof
  inputFile <- sourceName <$> getPosition
  let (key, path) = (getKey inputFile, dropExtension inputFile)
  return $ Markdown {key, path, title, metadata, bodyOffset, body}
  where
    headerP = (,) <$> titleP <* many eol <*> metadataP
    reverseHeaderP = flip (,) <$> metadataP  <* many eol<*> titleP

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

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

at :: FilePath -> IO (Either ParseError Markdown)
at filePath = parse parser filePath <$> readFile filePath