pretty-show-1.6.16/Text/Show/Html.hs

   1 {-# LANGUAGE Safe #-}
   2 module Text.Show.Html
   3   ( HtmlOpts(..), defaultHtmlOpts
   4   , valToHtml, valToHtmlPage, htmlPage
   5   , Html(..)
   6   ) where
   7
   8 import Text.Show.Value
   9 import Prelude hiding (span)
  10
  11 -- | Make an Html page representing the given value.
  12 valToHtmlPage :: HtmlOpts -> Value -> String
  13 valToHtmlPage opts = htmlPage opts . valToHtml opts
  14
  15 -- | Options on how to generate Html (more to come).
  16 data HtmlOpts = HtmlOpts
  17   { dataDir :: FilePath   -- ^ Path for extra files.  If empty, we look in
  18                           -- directory `style`, relative to document.
  19   , wideListWidth :: Int  -- ^ Max. number of columns in wide lists.
  20   } deriving Show
  21
  22 -- | Default options.
  23 defaultHtmlOpts :: HtmlOpts
  24 defaultHtmlOpts = HtmlOpts
  25   { dataDir       = ""
  26   , wideListWidth = 80
  27   }
  28
  29 -- | Convert a value into an Html fragment.
  30 valToHtml :: HtmlOpts -> Value -> Html
  31 valToHtml opts = loop
  32   where
  33   loop val =
  34     case val of
  35       Con con []  -> span "con" (text con)
  36       Con con vs  -> tallRecord con (map conLab vs) (map loop         vs)
  37       Rec con fs  -> tallRecord con (map fst fs)    (map (loop . snd) fs)
  38       Tuple vs    -> wideTuple                      (map loop vs)
  39
  40       InfixCons v ms ->
  41         table "infix tallRecord"
  42           [ tr $ (th "label" 1 (text " ") :)
  43                $ map td $ loop v : [ h | (op,u) <- ms
  44                                    , h <- [ text op, loop u ]
  45                                    ]
  46           ]
  47
  48       List []     -> span "list" (text "[]")
  49       List vs@(v : vs1) ->
  50         case v of
  51
  52           Con c fs
  53             | all (isCon c) vs1  -> recordList c (map conLab fs)
  54                                      [ map loop xs | Con _ xs <- vs ]
  55             | otherwise          -> tallList $ map (loop) vs
  56
  57           Rec c fs
  58             | all (isRec c) vs1   -> recordList c (map fst fs)
  59                                    [ map (loop . snd) xs | Rec _ xs <- vs ]
  60             | otherwise           -> tallList $ map (loop) vs
  61
  62           Tuple fs -> tupleList (length fs)
  63                             [ map (loop) xs | Tuple xs <- vs ]
  64
  65           List {}    -> tallList    $ map loop vs
  66
  67           Neg {}     -> wideList (wideListWidth opts) $ map loop vs
  68           Ratio {}   -> wideList (wideListWidth opts) $ map loop vs
  69           Integer {} -> wideList (wideListWidth opts) $ map loop vs
  70           Float {}   -> wideList (wideListWidth opts) $ map loop vs
  71           Char {}    -> wideList (wideListWidth opts) $ map loop vs
  72           String {}  -> tallList                      $ map loop vs
  73           InfixCons {} -> tallList                    $ map loop vs
  74
  75       Neg v       ->
  76         case v of
  77           Integer txt -> span "integer" $ text ('-' : txt)
  78           Float txt   -> span "float"   $ text ('-' : txt)
  79           _           -> neg (loop v)
  80
  81       Ratio v1 v2 -> ratio (loop v1) (loop v2)
  82       Integer txt -> span "integer" (text txt)
  83       Float txt   -> span "float"   (text txt)
  84       Char txt    -> span "char"    (text txt)
  85       String txt  -> span "string"  (text txt)
  86
  87   conLab _          = " "
  88
  89   isCon c (Con d _) = c == d
  90   isCon _ _         = False
  91
  92   isRec c (Rec d _) = c == d
  93   isRec _ _         = False
  94
  95
  96 neg :: Html -> Html
  97 neg e = table "negate" [ tr [td (text "-"), td e] ]
  98
  99 ratio :: Html -> Html -> Html
 100 ratio e1 e2 = table "ratio" [ tr [ td' "numerator" e1 ], tr [td e2] ]
 101
 102 wideTuple :: [Html] -> Html
 103 wideTuple els = table "wideTuple" [ tr $ map td els ]
 104
 105 tallTuple :: [Html] -> Html
 106 tallTuple els = table "tallTuple" $ map (tr . return . td) els
 107
 108 tallRecord :: Name -> [Name] -> [Html] -> Html
 109 tallRecord con labs els = table "tallRecord" $ topHs : zipWith row labs els
 110   where
 111   topHs   = tr [ th "con" 2 (text con) ]
 112   row l e = tr [ th "label" 1 (text l),   td e ]
 113
 114 recordList :: Name -> [Name] -> [[Html]] -> Html
 115 recordList con labs els = table "recordList" $ topHs : zipWith row [0..] els
 116   where
 117   topHs    = tr $ th "con" 1 (text con) : map (th "label" 1 . text) labs
 118   row n es = tr $ th "ix" 1 (int n) : map td es
 119
 120 tupleList :: Int -> [[Html]] -> Html
 121 tupleList n els = recordList " " (replicate n " ") els
 122
 123 tallList :: [Html] -> Html
 124 tallList els = table "tallList" $ top : zipWith row [0..] els
 125   where
 126   top     = tr [ th "con" 2 (text " ")]
 127   row n e = tr [ th "ix" 1 (int n), td e ]
 128
 129 wideList :: Int -> [Html] -> Html
 130 wideList w els = table "wideList" $ topHs : zipWith row [0..] (chop els)
 131   where
 132   elNum = length els
 133   pad   = elNum > w
 134
 135   chop [] = []
 136   chop xs = let (as,bs) = splitAt w xs
 137             in take w (as ++ if pad then repeat empty else []) : chop bs
 138
 139   topHs     = tr $ th "con" 1 (text " ") : map (th "label" 1 . int)
 140                                                 [ 0 .. min elNum w - 1 ]
 141   row n es  = tr $ (th "ix" 1 (int (n*w))) : map td es
 142
 143 --------------------------------------------------------------------------------
 144 newtype Html = Html { exportHtml :: String }
 145
 146 table :: String -> [Html] -> Html
 147 table cl body = Html $ "<table class=" ++ show cl ++ ">" ++
 148                        concatMap exportHtml body ++
 149                        "</table>"
 150
 151 tr :: [Html] -> Html
 152 tr body = Html $ "<tr>" ++ concatMap exportHtml body ++ "</tr>"
 153
 154 th :: String -> Int -> Html -> Html
 155 th cl n body = Html $ "<th class=" ++ show cl ++
 156                          " colspan=" ++ show (show n) ++ ">" ++
 157                       exportHtml body ++
 158                       "</th>"
 159
 160 td :: Html -> Html
 161 td body = Html $ "<td>" ++ exportHtml body ++ "</td>"
 162
 163 td' :: String -> Html -> Html
 164 td' cl body = Html $ "<td class=" ++ show cl ++ ">" ++
 165                      exportHtml body ++
 166                      "</td>"
 167
 168 span :: String -> Html -> Html
 169 span cl body = Html $ "<span class=" ++ show cl ++ ">" ++
 170                       exportHtml body ++
 171                       "</span>"
 172
 173 empty :: Html
 174 empty = Html  ""
 175
 176 int :: Int -> Html
 177 int = Html . show
 178
 179 text :: String -> Html
 180 text = Html . concatMap esc
 181   where
 182   esc '<' = "&lt;"
 183   esc '>' = "&gt;"
 184   esc '&' = "&amp;"
 185   esc ' ' = "&nbsp;"
 186   esc c   = [c]
 187
 188 -- | Wrap an Html fragment to make an Html page.
 189 htmlPage :: HtmlOpts -> Html -> String
 190 htmlPage opts body =
 191   unlines
 192   [ "<html>"
 193   , "<head>"
 194   , "<link href="  ++ show pstyle ++ " rel=" ++ show "stylesheet" ++ ">"
 195   , "<script src=" ++ show jquery ++ "></script>"
 196   , "<script src=" ++ show pjs    ++ "></script>"
 197   , "<body>"
 198   , exportHtml  body
 199   , "</body>"
 200   , "</html>"
 201   ]
 202   where
 203   -- XXX: slashes on Windows?
 204   dir    = case dataDir opts of
 205              "" -> ""
 206              d  -> d ++ "/"
 207   jquery = dir ++ "style/jquery.js"
 208   pjs    = dir ++ "style/pretty-show.js"
 209   pstyle = dir ++ "style/pretty-show.css"
 210
 211