heckle-0.1.0.0: src/Heckle.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module Heckle where

--Blaze HTML
import Text.Blaze.Html5 as H hiding (main, map)
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty

--Pandoc
import Text.Pandoc.Options
import Text.Pandoc.Readers.Markdown
import Text.Pandoc.Definition
import Text.Pandoc.Writers.HTML

--TagSoup
import Text.HTML.TagSoup

--Other
import Data.List.Split
import Control.Applicative
import Data.Map.Lazy as Map (lookup)
import Control.Monad

data Post = Post {
  filename :: String
  , pd :: Pandoc
  , postTitle :: String
  , postDate :: String
  }
          deriving (Eq, Show)

getMD :: FilePath -> Either String String
getMD s = case splitOn "." s of
            [fn, "md"] -> Right fn
            _ -> Left "Not a PDF file"

getMeta :: (Meta -> [Inline]) -> Pandoc -> Either String String
getMeta f (Pandoc m _) = case f m of
  [] -> Left "Couldn't find it"
  ((Str s):xs) -> Right s
  (_:xs) -> Left "Not a string??"

createPost :: Show a => String -> Either a Pandoc -> Either String Post
createPost _ (Left e) = Left (show e)
createPost fn (Right pd) = 
	Post <$> pure fn <*> pure pd <*> getMeta docTitle pd <*> getMeta docDate pd

filenameToPost :: String -> IO (Either String Post)
filenameToPost fn = do
	native <- fmap (readMarkdown def) (readFile ("posts/" ++ fn ++ ".md"))
	return (createPost fn native)
        
writeHTML :: Post -> IO ()
writeHTML p = do
	let html = writeHtmlString def (pd p)
	writeFile ("posts/" ++ (filename p) ++ ".html") html 

postsToHtml :: [Post] -> Html
postsToHtml xs = do
  ul ! A.id "blog-posts" $
    forM_ xs h
  where
    h s = li ! class_ "blog-post" $ do
            a ! class_ "post-link" ! href (stringValue ("posts/"++filename s++".html")) $ toHtml (postTitle s)
            H.div ! class_ "post-date" $ toHtml (postDate s)

injectPosts :: String -> Html -> Either String String 
injectPosts layout ul = case splitFile of
                        [beginning, end] -> Right (renderTags (beginning ++ parseTags (show ul) ++ end))
                        _ ->  Left "Broken layout file"
  where
    splitFile = splitOn [(TagOpen "ul" [("id","blog-posts")]), (TagClose "ul")] (parseTags layout)

instance Show Html where
  show = renderHtml