src/Util/GenerateHtmlTCombinators.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 module Util.GenerateHtmlTCombinators where
   4
   5 import Control.Applicative
   6 import Data.List
   7 import Language.Haskell.TH
   8 import System.Directory
   9 import System.FilePath
  10 import Text.Printf
  11 import Text.Regex
  12 import Text.Regex.TDFA
  13 import Util.GenerateHtmlCombinators hiding (getModuleName, main)
  14
  15 declare :: HtmlVariant -> [Dec]
  16 declare x = concatMap (\(w,ls) -> concatMap (g w) ls)
  17             [(("wrapMarkup2","Markup2"),"docTypeHtml" : parents x)
  18               ,(("wrapMarkup","Markup"),  "docType"     : leafs x)]
  19   where g (w',t') l' =
  20           [SigD l $ ConT t
  21           ,ValD (VarP l) (NormalB (AppE (VarE w)
  22           $ VarE $ mkName $ getModuleName "Blaze" x ++"."++l')) []]
  23           where [w,t,l] = fmap mkName [w',t',l']
  24
  25
  26
  27 writeSource :: HtmlVariant -> IO ()
  28 writeSource v = mapM_ g [True, False]
  29   where
  30     g attr = do
  31       let path = if attr then "Attributes" else ""
  32           name = (if attr then "." else "") ++ path
  33           [mT,m] = ((++ name) . flip getModuleName v) <$>
  34                    ["BlazeT","Blaze"]
  35           exports = if attr then [m] else [mT, "Text.BlazeT.Html"]
  36           f = (joinPath $ ["src","Text","BlazeT"] ++ version v
  37                ++ [path]) <.> "hs"
  38           body = if attr then "" else unlines $
  39             map (printf "import           Text.BlazeT%s") ["", ".Html", ".Internal"]
  40             ++ ["", show ( ppr_list $ declare v)]
  41           quali = if attr then "" else "qualified "
  42           docs True  = "This module simply reexports the corresponding @blaze-html@ module."
  43           docs False = printf "This module wraps all exports of \"%s\" using 'wrapMarkup' and 'wrapMarkup'." m
  44       createDirectoryIfMissing True $ takeDirectory $ f
  45       writeFile f $ unlines $
  46         ["-- !! DO NOT EDIT"
  47         ,"{-|"
  48         ,printf "(Automatically generated by @%s:%d@)\n"
  49          (subRegex (mkRegex "/")  __FILE__ "\\\\/") ( __LINE__ :: Int)
  50         ,docs attr
  51         ,"-}"
  52         ,"module "++ mT
  53         ,"   (" ++ intercalate "\n   ," (map ("module "++) exports)
  54         ,"   ) where"
  55         ,"import "++ quali ++ m
  56         , body]
  57
  58 main = mapM_ writeSource htmlVariants
  59
  60
  61 getModuleName :: String -> HtmlVariant -> String
  62 getModuleName base = (("Text."++base++".")++) . intercalate "." . version