packages feed

xml2x-0.4: src/Html.hs

{- Xml2Html

   Read BLAST Output in XML format, and output as a set of
   HTML files.  In contrast to almost everything else out there, 
   we generate HTML tables, rather than a GIF or similar for the
   graphical output.

-}

module Html where

import Tabulate

import Bio.Alignment.BlastData

import Data.ByteString.Lazy.Char8 (unpack,ByteString)
import Text.XHtml
import System.Directory
import System.IO
import Text.Printf
import Debug.Trace (trace)

import Options (htmldir)

instance HTML ByteString where
    toHtml = toHtml . unpack

makeDirectory :: FilePath -> IO ()
makeDirectory f = do
   createDirectory f `catch` (\e -> fail ("Couldn't create directory: '" ++ f++ "'\n"++show e))

doctype, htmlfooter, default_bg :: String

-- manual open tags
doctype = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n"

htmlheader :: BlastResult -> [String] -> String
htmlheader b hs = doctype ++ "<html>" ++ renderHtmlFragment (header << thetitle << "Blast") 
                ++ "<body>" ++ renderHtmlFragment pagehdr ++ "\n<table border=\"1\">\n" 
                ++ renderHtmlFragment (tr << map (th <<) hs)
    where pagehdr = (h1 << "Blast results") 
                    +++ p ((toHtml ("Program: "++unpack (blastversion b)))
                    +++ br +++ toHtml ("Database: "++ unpack (database b)))

htmlfooter = "    </table>\n  </body>\n</html>"

-- xs = writeFile "index.html" $ renderHtmlFragment document
--          mklink x = anchor ! [href (mkdirname x)] << x +++ br 

mkdirname :: FilePath -> FilePath
mkdirname x = htmldir++"/"++x++".html"

type Link = String

-- | Generate two results: 
--   1. a new file displaying the aligned matches (via genBrfile)
--   2. a row in the index file, with a link to the former (using writeRow)
mkHtml :: Handle -> (BlastRecord -> [[String]]) -> BlastRecord -> IO ()
mkHtml h writer br1 = 
    do let ls@((q:_):_) = writer br1
           writeRow (x:xs) = hPutStr h $ renderHtmlFragment (tr << (td << mklink x : (map (td <<) xs)))
           mklink x = anchor ! [href (mkdirname x)] << x
       mapM writeRow ls 
       genBrfile q br1

genBrfile :: FilePath -> BlastRecord -> IO ()
genBrfile fn x = writeFile (mkdirname fn) $ renderHtml $ record $ tabulate x

record :: Table -> Html
record (t,w,rs) = table -- ! [ border 1 ]
           << (tr << (th << t +++ th << ruler w
                      +++ map hit rs))
                where ruler i = table ! [ border 1, cellspacing 0, width (show i) ] << tr << go i
                      go i | i > 100 = td ! [ width "100" , small_font ] 
                                       << "|" +++ go (i-100)
                           | otherwise = td ! [ width (show i), small_font ] << ""

small_font :: HtmlAttr
small_font = thestyle "font-size:50%"
default_bg = "#d0e0ff"

-- | Format a BlastHit as a <tr>
hit :: Row -> Html
hit (h_name,ms) = tr ! [bgcolor default_bg] << 
        (td << anchor ! [ href (unpack h_name++".html") {-, title (unwords "h_desc") -} ] << h_name
        +++ td << (line ms))

-- | Format a set of BlastMatches from one BlastHit
--   Total length in pixels(?
line :: [Cell] -> Html
line bs = table ! [ cellspacing 0 ] << tr << map mycell bs +++ mycomment
    where
      mycomment = comment $ show bs
--                  $ map (\b -> let (f,t) = (q_from b,q_to b) 
--                               in (f,t,bits b/fromIntegral (t-f),aux b)) $ bs

      mycell (Cell w c fr) = td ! [width (show w), bgcolor (makeColor c), small_font] 
                             << (maybe "" showFrame fr)

      showFrame (Frame Plus n)  = "+"++show n
      showFrame (Frame Minus n) = "-"++show n
      showFrame (Strands a b)   = if a==b then "->" else "<-"

-- blastn and tblastn report bits > 2/position
-- Currently we just report it and truncate to 2 (i.e. 100%).
makeColor :: Int -> String
makeColor c | c == 0    = default_bg 
            | c > 100   = trace (" - makeColor: value >100 ("++show c++") - truncating!")
                          $ makeColor 100
            | otherwise = printf "#%2x8080" ((0x80::Int)+0x79*c`div`100)

comment :: String -> Html
comment xs = primHtml $ "<!--"++xs++"-->"