---------------------------------------------------------
-- 
-- Copyright   : (c) alpha 2006
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- Quick and dirty hack for HTML to Haskell conversion
---------------------------------------------------------

module Main where

import Text.XML.HXT.Arrow
import Data.Tree.NTree.TypeDefs(NTree(..))
import Data.List(intersperse)
import Data.Char(toUpper,toLower,ord)
import System.FilePath.Version_0_11(dropExtension)
import System.IO

-- If your html file is named alpha.html then a module Alpha.hs will be created
-- Import it if you want to use this haskell code
--import Alpha

-- | Html file to process
name = "alpha.html"

-- | Ident the Haskell code
ident :: Int -> String
ident i = concat $ replicate i " "

-- | Class for converting html tags to haskell code
class Haskell a where
 toHaskell :: Int -> a -> String
 
-- Instances used to convert an XmlTree as defined in HXT
instance Haskell [XmlTree] where
 toHaskell i l =  concat . intersperse ("\n" ++ ident i ++ "+++\n") $ (map (toHaskell i) l)

instance Haskell XmlTree where
  toHaskell i (NTree r@(XText _) []) = toHaskell i r 
  toHaskell i (NTree r@(XTag _ []) []) = toHaskell i r ++ " noHtml"
  toHaskell i (NTree r@(XTag _ a) []) = ident i ++ "(" ++ toHaskell 0 r  ++ " noHtml" ++ ")" ++ attrs a
  toHaskell i (NTree r@(XText _) l) = toHaskell i r ++ " << (\n" ++ (toHaskell (i+1) l) ++ ")" 
  toHaskell i (NTree r@(XTag _ []) l) = toHaskell i r ++ " << (\n" ++ (toHaskell (i+1) l) ++ ")" 
  toHaskell i (NTree r@(XTag _ a) l) = toHaskell i r ++ attrs a ++ " << (\n" ++ (toHaskell (i+1) l) ++ ")" 
  toHaskell i _ = ident i ++ "noHtml"
  
-- | Generate HTML attributes
attrs :: [NTree XNode] -> String
attrs [] = ""
attrs l = "![" ++ (concat . intersperse "," . map attr $ l) ++ "]" where
  textNodes [] = ""
  textNodes ((NTree (XText s) _):l) = s ++ textNodes l
  textNodes (a:l) = textNodes l
  attr (NTree (XAttr qname) l) = "strAttr \"" ++ (localPart qname) ++ "\" \"" ++ textNodes l ++ "\""
  attr (NTree _ _) = ""

instance Haskell XNode where
  toHaskell i (XText s) = toHaskell i s -- ident i ++ "stringToHtml(\""++s++"\")"
  toHaskell i (XTag name _) = ident i ++ "tag \"" ++ qualifiedName name ++ "\"" 
  toHaskell i _ = ident i ++ "noHtml"
  
instance Haskell String where
  toHaskell i s = printLine s where
    escape [] = []
    escape ('"':l) = "\\\"" ++ (escape l)
    escape ('\\':l) = "\\\\" ++ (escape l)
    escape ('\n':l) = "\\n" ++ (escape l)
    escape ('\t':l) = "\\t" ++ (escape l)
    -- A hack : not good for Unicode
    escape (a:l) | (ord a) <= 255 = a:escape l
                 | otherwise = escape l
    printLine s = ident i ++ "stringToHtml(\"" ++ escape s ++ "\")"

-- | Replace the first letter of a word bu the uppercase version
capitalize :: String -> String
capitalize [] = []
capitalize (a:l) = toUpper a : l

-- | Parse the html document and create the haskell code
parseHtml h src = do
  r <- runX (readDocument [(a_validate,v_0),(a_parse_html,v_1),(a_remove_whitespace,v_1),(a_encoding,utf8)] src
        >>> getChildren >>> getChildren >>> escapeHtmlDoc
       )
  hPutStrLn h $ "module " ++ capitalize (dropExtension src) ++ " where\n"
  hPutStrLn h "import Text.XHtml.Strict\n"
  hPutStr h $ (map toLower (dropExtension src)) ++ " = showHtml $\n"
  hPutStr h $ toHaskell (length (dropExtension src) + 2) r
  
-- Uncomment if you want to generate the Html from the haskell code.
-- If the initial html file was alpha.html then the haskell code is containing
-- a text value alpha
--createHtml = putStr alpha
 
main = do
  -- Create a file for writing the Haskell code and parse the html
  h <- openBinaryFile  ((capitalize (dropExtension name)) ++ ".hs") WriteMode
  parseHtml h name
  hClose h
  -- Uncomment if you want to generate the Html document from the Haskell one
  --createHtml
  return ()