{-# LANGUAGE Safe #-}
module Text.Show.Html
  ( HtmlOpts(..), defaultHtmlOpts
  , valToHtml, valToHtmlPage, htmlPage
  , Html(..)
  ) where

import Text.Show.Value
import Prelude hiding (span)

-- | Make an Html page representing the given value.
valToHtmlPage :: HtmlOpts -> Value -> String
valToHtmlPage opts = htmlPage opts . valToHtml opts

-- | Options on how to generate Html (more to come).
data HtmlOpts = HtmlOpts
  { dataDir :: FilePath   -- ^ Path for extra files.  If empty, we look in
                          -- directory `style`, relative to document.
  , wideListWidth :: Int  -- ^ Max. number of columns in wide lists.
  } deriving Show

-- | Default options.
defaultHtmlOpts :: HtmlOpts
defaultHtmlOpts = HtmlOpts
  { dataDir       = ""
  , wideListWidth = 80
  }

-- | Convert a value into an Html fragment.
valToHtml :: HtmlOpts -> Value -> Html
valToHtml opts = loop
  where
  loop val =
    case val of
      Con con []  -> span "con" (text con)
      Con con vs  -> tallRecord con (map conLab vs) (map loop         vs)
      Rec con fs  -> tallRecord con (map fst fs)    (map (loop . snd) fs)
      Tuple vs    -> wideTuple                      (map loop vs)

      InfixCons v ms ->
        table "infix tallRecord"
          [ tr $ (th "label" 1 (text " ") :)
               $ map td $ loop v : [ h | (op,u) <- ms
                                   , h <- [ text op, loop u ]
                                   ]
          ]

      List []     -> span "list" (text "[]")
      List vs@(v : vs1) ->
        case v of

          Con c fs
            | all (isCon c) vs1  -> recordList c (map conLab fs)
                                     [ map loop xs | Con _ xs <- vs ]
            | otherwise          -> tallList $ map (loop) vs

          Rec c fs
            | all (isRec c) vs1   -> recordList c (map fst fs)
                                   [ map (loop . snd) xs | Rec _ xs <- vs ]
            | otherwise           -> tallList $ map (loop) vs

          Tuple fs -> tupleList (length fs)
                            [ map (loop) xs | Tuple xs <- vs ]

          List {}    -> tallList    $ map loop vs

          Neg {}     -> wideList (wideListWidth opts) $ map loop vs
          Ratio {}   -> wideList (wideListWidth opts) $ map loop vs
          Integer {} -> wideList (wideListWidth opts) $ map loop vs
          Float {}   -> wideList (wideListWidth opts) $ map loop vs
          Char {}    -> wideList (wideListWidth opts) $ map loop vs
          String {}  -> tallList                      $ map loop vs
          InfixCons {} -> tallList                    $ map loop vs

      Neg v       ->
        case v of
          Integer txt -> span "integer" $ text ('-' : txt)
          Float txt   -> span "float"   $ text ('-' : txt)
          _           -> neg (loop v)

      Ratio v1 v2 -> ratio (loop v1) (loop v2)
      Integer txt -> span "integer" (text txt)
      Float txt   -> span "float"   (text txt)
      Char txt    -> span "char"    (text txt)
      String txt  -> span "string"  (text txt)

  conLab _          = " "

  isCon c (Con d _) = c == d
  isCon _ _         = False

  isRec c (Rec d _) = c == d
  isRec _ _         = False


neg :: Html -> Html
neg e = table "negate" [ tr [td (text "-"), td e] ]

ratio :: Html -> Html -> Html
ratio e1 e2 = table "ratio" [ tr [ td' "numerator" e1 ], tr [td e2] ]

wideTuple :: [Html] -> Html
wideTuple els = table "wideTuple" [ tr $ map td els ]

tallTuple :: [Html] -> Html
tallTuple els = table "tallTuple" $ map (tr . return . td) els

tallRecord :: Name -> [Name] -> [Html] -> Html
tallRecord con labs els = table "tallRecord" $ topHs : zipWith row labs els
  where
  topHs   = tr [ th "con" 2 (text con) ]
  row l e = tr [ th "label" 1 (text l),   td e ]

recordList :: Name -> [Name] -> [[Html]] -> Html
recordList con labs els = table "recordList" $ topHs : zipWith row [0..] els
  where
  topHs    = tr $ th "con" 1 (text con) : map (th "label" 1 . text) labs
  row n es = tr $ th "ix" 1 (int n) : map td es

tupleList :: Int -> [[Html]] -> Html
tupleList n els = recordList " " (replicate n " ") els

tallList :: [Html] -> Html
tallList els = table "tallList" $ top : zipWith row [0..] els
  where
  top     = tr [ th "con" 2 (text " ")]
  row n e = tr [ th "ix" 1 (int n), td e ]

wideList :: Int -> [Html] -> Html
wideList w els = table "wideList" $ topHs : zipWith row [0..] (chop els)
  where
  elNum = length els
  pad   = elNum > w

  chop [] = []
  chop xs = let (as,bs) = splitAt w xs
            in take w (as ++ if pad then repeat empty else []) : chop bs

  topHs     = tr $ th "con" 1 (text " ") : map (th "label" 1 . int)
                                                [ 0 .. min elNum w - 1 ]
  row n es  = tr $ (th "ix" 1 (int (n*w))) : map td es

--------------------------------------------------------------------------------
newtype Html = Html { exportHtml :: String }

table :: String -> [Html] -> Html
table cl body = Html $ "<table class=" ++ show cl ++ ">" ++
                       concatMap exportHtml body ++
                       "</table>"

tr :: [Html] -> Html
tr body = Html $ "<tr>" ++ concatMap exportHtml body ++ "</tr>"

th :: String -> Int -> Html -> Html
th cl n body = Html $ "<th class=" ++ show cl ++
                         " colspan=" ++ show (show n) ++ ">" ++
                      exportHtml body ++
                      "</th>"

td :: Html -> Html
td body = Html $ "<td>" ++ exportHtml body ++ "</td>"

td' :: String -> Html -> Html
td' cl body = Html $ "<td class=" ++ show cl ++ ">" ++
                     exportHtml body ++
                     "</td>"

span :: String -> Html -> Html
span cl body = Html $ "<span class=" ++ show cl ++ ">" ++
                      exportHtml body ++
                      "</span>"

empty :: Html
empty = Html  ""

int :: Int -> Html
int = Html . show

text :: String -> Html
text = Html . concatMap esc
  where
  esc '<' = "&lt;"
  esc '>' = "&gt;"
  esc '&' = "&amp;"
  esc ' ' = "&nbsp;"
  esc c   = [c]

-- | Wrap an Html fragment to make an Html page.
htmlPage :: HtmlOpts -> Html -> String
htmlPage opts body =
  unlines
  [ "<html>"
  , "<head>"
  , "<link href="  ++ show pstyle ++ " rel=" ++ show "stylesheet" ++ ">"
  , "<script src=" ++ show jquery ++ "></script>"
  , "<script src=" ++ show pjs    ++ "></script>"
  , "<body>"
  , exportHtml  body
  , "</body>"
  , "</html>"
  ]
  where
  -- XXX: slashes on Windows?
  dir    = case dataDir opts of
             "" -> ""
             d  -> d ++ "/"
  jquery = dir ++ "style/jquery.js"
  pjs    = dir ++ "style/pretty-show.js"
  pstyle = dir ++ "style/pretty-show.css"