{-# 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 {
      Markdown -> String
key :: String
    , Markdown -> String
path :: String
    , Markdown -> String
title :: String
    , Markdown -> Metadata
metadata :: Metadata
    , Markdown -> Int
bodyOffset :: Int
    , Markdown -> [String]
body :: [String]
  }

class MarkdownContent a where
  getMarkdown :: a -> Markdown

parser :: Parser Markdown
parser :: Parser Markdown
parser = do
  (String
title, Metadata
metadata) <- ParsecT String () Identity String -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity String
eol ParsecT String () Identity ()
-> ParsecT String () Identity (String, Metadata)
-> ParsecT String () Identity (String, Metadata)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT String () Identity (String, Metadata)
headerP ParsecT String () Identity (String, Metadata)
-> ParsecT String () Identity (String, Metadata)
-> ParsecT String () Identity (String, Metadata)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String () Identity (String, Metadata)
reverseHeaderP)
  Int
bodyOffset <- ParsecT String () Identity String -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity String
eol ParsecT String () Identity ()
-> ParsecT String () Identity Int -> ParsecT String () Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> (SourcePos -> Int) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Int
sourceLine (SourcePos -> Int)
-> ParsecT String () Identity SourcePos
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition)
  [String]
body <- String -> [String]
lines (String -> [String])
-> ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String () Identity [String]
-> ParsecT String () Identity ()
-> ParsecT String () Identity [String]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  String
inputFile <- SourcePos -> String
sourceName (SourcePos -> String)
-> ParsecT String () Identity SourcePos
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  let (String
key, String
path) = (String -> String
getKey String
inputFile, String -> String
dropExtension String
inputFile)
  Markdown -> Parser Markdown
forall (m :: * -> *) a. Monad m => a -> m a
return (Markdown -> Parser Markdown) -> Markdown -> Parser Markdown
forall a b. (a -> b) -> a -> b
$ Markdown :: String
-> String -> String -> Metadata -> Int -> [String] -> Markdown
Markdown {String
key :: String
key :: String
key, String
path :: String
path :: String
path, String
title :: String
title :: String
title, Metadata
metadata :: Metadata
metadata :: Metadata
metadata, Int
bodyOffset :: Int
bodyOffset :: Int
bodyOffset, [String]
body :: [String]
body :: [String]
body}
  where
    headerP :: ParsecT String () Identity (String, Metadata)
headerP = (,) (String -> Metadata -> (String, Metadata))
-> ParsecT String () Identity String
-> ParsecT String () Identity (Metadata -> (String, Metadata))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
titleP ParsecT String () Identity (Metadata -> (String, Metadata))
-> ParsecT String () Identity [String]
-> ParsecT String () Identity (Metadata -> (String, Metadata))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity String
eol ParsecT String () Identity (Metadata -> (String, Metadata))
-> ParsecT String () Identity Metadata
-> ParsecT String () Identity (String, Metadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity Metadata
metadataP
    reverseHeaderP :: ParsecT String () Identity (String, Metadata)
reverseHeaderP = (String -> Metadata -> (String, Metadata))
-> Metadata -> String -> (String, Metadata)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (Metadata -> String -> (String, Metadata))
-> ParsecT String () Identity Metadata
-> ParsecT String () Identity (String -> (String, Metadata))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Metadata
metadataP  ParsecT String () Identity (String -> (String, Metadata))
-> ParsecT String () Identity [String]
-> ParsecT String () Identity (String -> (String, Metadata))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity String
eolParsecT String () Identity (String -> (String, Metadata))
-> ParsecT String () Identity String
-> ParsecT String () Identity (String, Metadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity String
titleP

metadataP :: Parser Metadata
metadataP :: ParsecT String () Identity Metadata
metadataP = [(String, String)] -> Metadata
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, String)] -> Metadata)
-> ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity Metadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, String)]
-> ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity [(String, String)]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (
    ParsecT String () Identity String
metaSectionSeparator ParsecT String () Identity String
-> ParsecT String () Identity [String]
-> ParsecT String () Identity [String]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity String
eol ParsecT String () Identity [String]
-> ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity [(String, String)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    (GenParser Char () (String, String)
-> GenParser Char () (String, String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char () (String, String)
keyVal) GenParser Char () (String, String)
-> ParsecT String () Identity [String]
-> ParsecT String () Identity [(String, String)]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`endBy` (ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity String
eol)
    ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity String
-> ParsecT String () Identity [(String, String)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity String
metaSectionSeparator
  ) ParsecT String () Identity Metadata
-> String -> ParsecT String () Identity Metadata
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"metadata section"
  where
    metaSectionSeparator :: ParsecT String () Identity String
metaSectionSeparator = Int
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
3 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"~-") ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
eol
    spaces :: ParsecT String u Identity ()
spaces = ParsecT String u Identity Char -> ParsecT String u Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (ParsecT String u Identity Char -> ParsecT String u Identity ())
-> ParsecT String u Identity Char -> ParsecT String u Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '
    keyVal :: GenParser Char () (String, String)
keyVal = (,) (String -> String -> (String, String))
-> ParsecT String () Identity String
-> ParsecT String () Identity (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ParsecT String () Identity String
no String
": \r\n" ParsecT String () Identity String
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall u. ParsecT String u Identity ()
spaces ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':' ParsecT String () Identity String
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall u. ParsecT String u Identity ()
spaces) ParsecT String () Identity (String -> (String, String))
-> ParsecT String () Identity String
-> GenParser Char () (String, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ParsecT String () Identity String
no String
"\r\n"

titleP :: Parser String
titleP :: ParsecT String () Identity String
titleP = ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity String
singleLine ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String () Identity String
underlined)
  where
    singleLine :: ParsecT String () Identity String
singleLine = Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#' ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT String () Identity String
no String
"\r\n" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity String
eol
    underlined :: ParsecT String () Identity String
underlined =
      String -> ParsecT String () Identity String
no String
"\r\n" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity String
eol
      ParsecT String () Identity String
-> (String -> ParsecT String () Identity String)
-> ParsecT String () Identity String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
titleLine -> Int
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
titleLine) (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"#=") ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
eol ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
titleLine
      ParsecT String () Identity String
-> String -> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"'#' or '=' to underline the title"

eol :: Parser String
eol :: ParsecT String () Identity String
eol = ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\r\n") ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\r" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n" ParsecT String () Identity String
-> String -> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"newline"

no :: String -> Parser String
no :: String -> ParsecT String () Identity String
no = ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String () Identity Char
 -> ParsecT String () Identity String)
-> (String -> ParsecT String () Identity Char)
-> String
-> ParsecT String () Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf

getKey :: FilePath -> String
getKey :: String -> String
getKey = String -> String
dropExtension (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName

at :: FilePath -> IO (Either ParseError Markdown)
at :: String -> IO (Either ParseError Markdown)
at String
filePath = Parser Markdown -> String -> String -> Either ParseError Markdown
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser Markdown
parser String
filePath (String -> Either ParseError Markdown)
-> IO String -> IO (Either ParseError Markdown)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
filePath