view Main.hs @ 1:dc4f989435d0 tip

Fixed problem with URLs
author Benedikt Fluhr <http://bfluhr.com>
date Sat, 24 Oct 2015 16:58:30 +0200
parents 8976f4287b8a
children
line wrap: on
line source
import Data.Default
import Data.Maybe
import Data.List as L
import System.Directory (createDirectoryIfMissing)
import Network.HTTP.Conduit (simpleHttp)
import Development.Shake
import Development.Shake.FilePath

import qualified Control.Monad as M
import qualified Data.ByteString.Lazy as B
import qualified Data.Text.Lazy.IO as TIO

import qualified Text.Pandoc as P
import qualified Text.Pandoc.Options as O
import           Text.Blaze.Html
import qualified Text.Blaze.Html5 as H
import           Text.Blaze.Html.Renderer.Text (renderHtml)

import qualified Text.MultidocRules as MR

import Templates

build :: FilePath
build = "_website"

srcDir :: FilePath
srcDir = "content"

lift2IO :: Show e => Either e a -> IO a
lift2IO (Left  errMsg) = (error . show) errMsg
lift2IO (Right val   ) = return val

copyFileAction :: FilePath -> FilePath -> Action ()
copyFileAction src target = do
  need [src]
  copyFile' src target

readFileAction :: FilePath -> Action String
readFileAction src = do
  need [src]
  readFile' src

-- needDir :: FilePath -> Action ()
-- needDir dir = do
--   mds <- getDirectoryFiles dir ["*.md"]
--   need $ L.map ( (-<.> "html") . (build </>) . dropDirectory1 ) mds


main = shakeArgs shakeOptions { shakeFiles = build } $ do

  action $ do
    mds <- getDirectoryFiles srcDir ["*.md", "*/*.md"]
    need $ L.map ( (build </>) . (-<.> "html") ) mds

  want [ build </> "notes/index.html"
       , build </> "pure-min.css"
       , build </> "layout.css"
       ]

  [ build </> "*.html", build </> "*/*.html" ] |%> \out -> do
    let md = srcDir </> dropDirectory1 out -<.> "md"
        outDir = takeDirectory out
    putNormal md
    src <- readFileAction md
    liftIO $ do
      pandoc@(P.Pandoc meta _) <- lift2IO $
                                  P.readMarkdown def { O.readerSmart = True }
                                  src
      createDirectoryIfMissing True outDir
      TIO.writeFile out $ renderHtml $ template (
        dropDirectory1 $ outDir
        ) Nothing (
        H.title $ P.writeHtml def (
           P.Pandoc P.nullMeta [P.Plain (P.docTitle meta)]
           )
        ) (
        wrapContainer $ P.writeHtml def pandoc
        )
  
  -- build </> "notes/index.html" %> \out -> liftIO $ do
  --   let outDir = takeDirectory out
  --   createDirectoryIfMissing True outDir
  --   TIO.writeFile out $ renderHtml $ template (
  --     dropDirectory1 outDir
  --     ) Nothing (
  --     H.title $ toHtml "Notes"
  --     ) (
  --     notesTemplate $ L.zip ["Persistence Cohomology"] [
  --        L.zip perCohoFiles MR.formats ++ [("../hg/perCoho", "Source")]
  --        ]
  --     )
  
  build </> "pure-min.css" %> \out -> liftIO $ do
    createDirectoryIfMissing True $ takeDirectory out
    ( simpleHttp "http://yui.yahooapis.com/pure/0.6.0/pure-min.css"
      >>= B.writeFile out )

  build </> "layout.css" %> \out ->
    copyFileAction (MR.md_dataDir def </> takeFileName out) out

  perCohoRules

  where
    (perCohoRules, perCohoFiles) =
      MR.makeRules def { MR.tmpDir = Just "tmp"
                       , MR.mb_template = Just $
                                          template "notes/perCoho" Nothing
                       } "perCoho" ( build </> "notes" )