112 lines
3.4 KiB
Haskell
112 lines
3.4 KiB
Haskell
{-# 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 (
|
|
UTCTime, defaultTimeLocale, getCurrentTimeZone, parseTimeM
|
|
, timeZoneOffsetString
|
|
)
|
|
import Data.Time.Clock.System (systemSeconds, utcToSystemTime)
|
|
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 . systemSeconds . utcToSystemTime
|
|
|
|
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}
|