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