hask-home-2006.3.23: hask-home.hs

#!/usr/bin/env runghc

import Control.Exception
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.Utils
import Prelude hiding (catch)
import System.Directory
import System.Environment
import System.Cmd
import Text.Regex

import Text.XHtml

docDir = "doc"
haddockDirRel = "api"
downloadDir = "download"
haddockDir = docDir ++ "/" ++ haddockDirRel
indexFile = docDir ++ "/" ++ "index.html"

standardPackages = ["base","stm","mtl","fgl","QuickCheck",
                    "Cabal","network","readline","unix","parsec",
                    "haskell98","posix"]

knownPackages = [("fps",("FastPackedString","http://www.cse.unsw.edu.au/~dons/fps.html")),
                 ("Crypto",("The Haskell Cryptographic Library","http://haskell.org/crypto/")),
                 ("HTTP",("The Haskell HTTP package","http://haskell.org/http/")),
                 ("XmlRpc",("HaXR - the Haskell XML-RPC library","http://haskell.org/haxr/")),
                 ("xhtml",("Text.XHtml","http://www.cs.chalmers.se/~bringert/darcs/haskell-xhtml/doc/")),
                 ("cgi",("NewCGI","http://www.cs.chalmers.se/~bringert/darcs/haskell-cgi/doc/"))
                ]

stylesheet = unlines $
 [
  "body { background-color: white; color: black; margin: 0; padding: 0; }",
  "h1, .footer { background-color:silver; color: black; margin: 0; border: 0 solid black; }",
  "h1 { border-bottom-width: thin; padding: 1em; }",
  ".footer { font-size: smaller; text-align:center; border-top-width: thin; padding: 0.25em 1em; }",
  ".footer span { padding: 0 0.25em; } ",
  "hr { display: none; }",
  ".section { padding: 0; margin: 0 5em; }"
 ]

buildHaddock :: PackageDescription -> IO ()
buildHaddock desc = 
    do
    let desc' = desc { description = synopsis desc }
    showExceptions $ withArgs ["haddock","-v"] $ defaultMainNoRead desc'
    let haddockOutputDir = "dist/doc/html"
    rawSystem "rm" ["-rf", haddockDir]
    rawSystem "cp" ["-r", haddockOutputDir, haddockDir]
    return ()
  where
--  formatDesc p = p { description = format (description p) }
--      where format = unlines . map formatLine . lines
--            formatLine l | match "^\\s*\\*" l = "\n" ++ l
--                         | otherwise = l

match :: String -> String -> Bool
match p s = isJust $ matchRegex (mkRegex p) s

distDir :: PackageDescription -> String
distDir desc = showPackageId (package desc)

distFile :: PackageDescription -> String
distFile desc = distDir desc ++ ".tar.gz"

mkTarball :: PackageDescription -> IO ()
mkTarball desc = 
    do
    system ("darcs dist --dist-name=" ++ distDir desc)
    createDirectoryIfMissing True downloadDir
    let f = downloadDir ++ "/" ++ distFile desc
    renameFile (distFile desc) f

makeIndex :: PackageDescription -> String -> Html
makeIndex desc setupProg = (header << hdr) +++ (body << bdy)
  where
  hdr = [thetitle << t, 
         meta ! [name "generator", content "hask-home, http://www.cs.chalmers.se/~bringert/darcs/hask-home/doc/"],
         style ! [thetype "text/css"] << stylesheet
        ]
  t = pkgName (package desc) ++ " - " ++ synopsis desc
  bdy = [h1 << t, des, api, dow, req, ins, mai, lic, foo]
  des = section "Description" [primHtml (description desc)]
  api | not (needsHaddock desc) = noHtml
      | otherwise = section "API Documentation" 
                      [p << hlink (haddockDirRel ++ "/" ++ "index.html")
                                     << "Haddock-generated API documentation"]
  repo = reverse $ drop (length docDir) $ dropWhile (=='/') $ reverse $ homepage desc
  tarball = "../" ++ downloadDir ++ "/" ++ distFile desc
  dow = section "Download" 
         ((if null repo then [] else 
                    [h3 << "Darcs", pre << ("$ darcs get --partial " ++ repo)])
            ++ [h3 << "Tarball",
                   p << hlink tarball (distFile desc)])
  req | null reqs = noHtml
      | otherwise = section "Requirements" [ulist << reqs]
  reqs = catMaybes $ map formatReq (buildDepends desc)
  formatReq d@(Dependency p v)
      | p `elem` standardPackages = Nothing
      | otherwise = Just $ case lookup p knownPackages of
                               Just (n,u) -> li << hlink u n
                               Nothing -> li << p
  ins = section "Installation" 
                  [olist << [li << ("Unpack the sources and enter the source directory:"
                                    +++ pre << [unlines ["$ tar -zxf " ++ distFile desc,
                                                         "$ cd " ++ distDir desc]]),
                             li << ("Configure:"
                                    +++ pre << [unlines ["$ runghc " ++ setupProg ++ " configure"]]),
                             li << ("Build:"
                                    +++ pre << [unlines ["$ runghc " ++ setupProg ++ " build"]]),
                             li << ("Install (as root):"
                                    +++ pre << [unlines ["# runghc " ++ setupProg ++ " install"]])
                            ]
        ]
  mai = section "Maintainer" [p << maintainer desc]
  lic | null (licenseFile desc) = section "License" [p << show (license desc)]
      | otherwise = section "License" 
                       [p << ("See " 
                              +++ (hlink ("../" ++ licenseFile desc) 
                                   << licenseFile desc)
                              +++ ".")]
  validXHtml = thespan << hlink "http://validator.w3.org/check?uri=referer" "Validate XHTML" 
  validCSS = thespan << hlink "http://jigsaw.w3.org/css-validator/check/referer" "Validate CSS" 
  generator = thespan << ("Page generated by " 
              +++ hlink "http://www.cs.chalmers.se/~bringert/darcs/hask-home/doc/" "hask-home")
  foo = thediv ! [theclass "footer"] 
        << [hr, p << [generator +++ " " +++ validXHtml +++ " " +++ validCSS]]
  section h xs = thediv ! [theclass "section"] << ((h2 << [h]):xs)


needsHaddock :: PackageDescription -> Bool
needsHaddock = isJust . library

txt2html :: String -> IO String
txt2html s = 
    do
    let tmpInFile = "txt2html.txt.tmp"
        tmpOutFile = "txt2html.html.tmp"
    writeFile tmpInFile ("\n\n\n"++s)
    rawSystem "txt2tags" ["-H","--target=xhtml","--outfile="++tmpOutFile,tmpInFile]
    s' <- readFile tmpOutFile
    removeFile tmpInFile
    removeFile tmpOutFile
    return s'

desc2html :: PackageDescription -> IO PackageDescription
desc2html desc = 
    do
    d' <- txt2html $ description desc
    return $ desc { description = d' }

findSetup :: IO String
findSetup = do
            b <- doesFileExist "Setup.hs"
            if b then return "Setup.hs"
                 else do
                      b <- doesFileExist "Setup.lhs"
                      if b then return "Setup.lhs"
                           else fail "No setup program found"

hlink :: HTML a => String -> a -> Html
hlink u b = anchor ! [href u] << b

showExceptions a = catch a (\e -> print e >> throw e)

main = do
       packageDesc <- defaultPackageDesc
       desc <- readPackageDescription packageDesc
       createDirectoryIfMissing True docDir
       setupProg <- findSetup
       when (needsHaddock desc) $ buildHaddock desc
       mkTarball desc
       desc' <- desc2html desc
       writeFile indexFile $ renderHtml $ makeIndex desc' setupProg