cryptol-2.9.0: utils/CryHtml.hs

#!/usr/bin/env runhaskell

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Main
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

import Cryptol.Parser.Lexer
import Cryptol.Utils.PP
import qualified Data.Text.IO as Text
import Text.Blaze.Html (Html, AttributeValue, toValue, toHtml, (!))
import qualified Text.Blaze.Html as H
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty (renderHtml)


main :: IO ()
main =
  do txt <- Text.getContents
     putStrLn $ renderHtml
              $ page
              $ toHtml
              $ map toBlaze
              $ fst
              $ primLexer defaultConfig txt

page :: Html -> Html
page inner = do
    H.docTypeHtml ! A.xmlns "http://www.w3.org/1999/xhtml" $ do
        H.head $ do
            H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8"
            H.title "Cryptol Source"
            H.style $ H.preEscapedString sty
        H.body inner


toBlaze :: Located Token -> Html
toBlaze tok = H.span ! (A.class_ $ cl $ tokenType $ thing tok)
                     ! (A.title $ toValue $ show $ pp $ srcRange tok)
  $ H.toHtml
  $ tokenText
  $ thing tok


cl :: TokenT -> AttributeValue
cl tok =
  case tok of
        Num {}      -> "number"
        Frac {}     -> "number"
        Ident {}    -> "identifier"
        KW {}       -> "keyword"
        Op {}       -> "operator"
        Sym {}      -> "symbol"
        Virt {}     -> "virtual"
        White Space -> "white"
        White _     -> "comment"
        Err {}      -> "error"
        EOF         -> "eof"
        StrLit {}   -> "text"
        ChrLit {}   -> "text"



sty :: String
sty = unlines
  [ "body { font-family: monospace }"
  , ".number        { color: #cc00cc }"
  , ".identifier    { }"
  , ".keyword       { color: blue; }"
  , ".operator      { color: #cc00cc }"
  , ".symbol        { color: blue }"
  , ".white         { }"
  , ".virtual       { background-color: red }"
  , ".comment       { color: green }"
  , ".error         { color: red }"
  , ".text          { color: #cc00cc }"
  ]