105 lines
3.3 KiB
Haskell
105 lines
3.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Article (
|
|
Article(..)
|
|
, at
|
|
, getKey
|
|
, preview
|
|
, titleP
|
|
) 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.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
|
|
import Foreign.C.Types (CTime)
|
|
import System.FilePath (dropExtension, takeFileName)
|
|
import System.Posix.Files (getFileStatus, modificationTime)
|
|
import Text.ParserCombinators.Parsec (
|
|
ParseError
|
|
, Parser
|
|
-- , (<|>)
|
|
, anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
|
|
, oneOf, option, parse, skipMany, sourceLine, spaces, string, try
|
|
)
|
|
|
|
type Metadata = Map String String
|
|
|
|
data Article = Article {
|
|
key :: String
|
|
, title :: String
|
|
, metadata :: Metadata
|
|
, bodyOffset :: Int
|
|
, body :: [String]
|
|
}
|
|
|
|
articleP :: Parser (String, Metadata, Int, [String])
|
|
articleP =
|
|
skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP
|
|
where
|
|
headerP =
|
|
try ((,,,) <$> titleP <* many eol <*> metadataP)
|
|
<|> flip (,,,) <$> metadataP <* many eol<*> titleP
|
|
lineOffset = sourceLine <$> getPosition
|
|
bodyP = lines <$> many anyChar <* eof
|
|
|
|
metadataP :: Parser Metadata
|
|
metadataP = Map.fromList <$> option [] (
|
|
metaSectionSeparator *> many eol *>
|
|
(try keyVal) `endBy` (many1 eol)
|
|
<* metaSectionSeparator
|
|
)
|
|
where
|
|
metaSectionSeparator = count 3 (oneOf "~-") *> eol
|
|
keyVal = (,) <$> (no ": " <* 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
|
|
|
|
eol :: Parser String
|
|
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
|
|
|
|
no :: String -> Parser String
|
|
no = many1 . noneOf
|
|
|
|
setDate :: String -> CTime -> Metadata -> Metadata
|
|
setDate tzOffset defaultDate = Map.alter timeStamp "date"
|
|
where
|
|
formats = ("%Y-%m-%d" ++) . (++ " %z") <$> ["", " %H:%M"]
|
|
epoch = show . (truncate :: POSIXTime -> Integer) . utcTimeToPOSIXSeconds
|
|
timeStamp Nothing = Just $ show defaultDate
|
|
timeStamp (Just date) =
|
|
let dates = [date, date ++ " " ++ tzOffset] in
|
|
let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in
|
|
foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes)
|
|
|
|
at :: FilePath -> IO (Either ParseError (String, Article))
|
|
at filePath = do
|
|
tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
|
|
fileDate <- modificationTime <$> getFileStatus filePath
|
|
let build = makeArticle (setDate tzOffset fileDate)
|
|
fmap build . parse articleP filePath <$> readFile filePath
|
|
where
|
|
makeArticle metaFilter (title, metadata, bodyOffset, body) = (
|
|
getKey filePath
|
|
, Article {
|
|
key = getKey filePath
|
|
, title
|
|
, metadata = metaFilter metadata
|
|
, bodyOffset
|
|
, body
|
|
}
|
|
)
|
|
|
|
getKey :: FilePath -> String
|
|
getKey = dropExtension . takeFileName
|
|
|
|
preview :: Int -> Article -> Article
|
|
preview linesCount article = article {body = take linesCount $ body article}
|