Add Text/TDoc/TH.hs

Text/TDoc/TH.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Text.TDoc.TH
+  (node
+  ,nodeChildren
+  ,nodeAttributes
+  ,attribute
+  ,attributes
+  ,tagInstances
+  ,tagInstance
+  ,NodeOpt(..))
+where
+
+import Data.Char (toLower)
+import Text.TDoc.Core (IsNode, IsChildOf, IsAttributeOf, IsAttribute
+                      ,IsInline, IsBlock, IsBlockOrInline)
+import Language.Haskell.TH
+
+data NodeOpt = NoTag | Inline | Block | BlockOrInline
+  deriving (Eq)
+type NodeOpts = [NodeOpt]
+
+mkIs :: Name -> Name -> Dec
+mkIs cl ty = InstanceD [] (ConT cl `AppT` ConT ty) []
+
+node :: String -> NodeOpts -> [Name] -> [Name] -> Q [Dec]
+node nod opts attrs children
+  = return . concat
+    $ [ [ DataD [] nodeNm [] [] []
+        , mkIs ''IsNode nodeNm
+        ]
+      , [ mkIs ''IsInline nodeNm | Inline `elem` opts ]
+      , [ mkIs ''IsBlock  nodeNm | Block `elem` opts  ]
+      , [ mkIs ''IsBlockOrInline nodeNm | BlockOrInline `elem` opts
+                                          || Block `elem` opts
+                                          || Inline `elem` opts ]
+      , [ mkTagClass nodeNm | NoTag `notElem` opts ]
+      , map (`mkIsAttributeOf` nodeNm) attrs
+      , map (`mkIsChildOf` nodeNm) children
+      ]
+  where nodeNm = mkName nod
+
+lowerFirst :: String -> String
+lowerFirst []     = error "Text.TDoc.TH.lowerFirst: []"
+lowerFirst (x:xs) = toLower x : xs
+
+mkTagName :: String -> Name
+mkTagName x = mkName $ x ++ "Tag"
+
+mkTagClass :: Name -> Dec
+mkTagClass nm = ClassD [] nmTagTy [PlainTV t] []
+                       [SigD nmTagFun (VarT t `AppT` ConT nm)]
+  where nmBase   = nameBase  nm
+        nmTagTy  = mkTagName nmBase
+        nmTagFun = mkTagName $ lowerFirst nmBase
+        t        = mkName "t"
+
+attribute :: Name -> Q [Dec]
+attribute attr = return
+                   [ InstanceD [] (ConT ''IsAttribute `AppT` ConT attr) []
+                   , mkTagClass attr
+                   ]
+
+attributes :: [Name] -> Q [Dec]
+attributes = fmap concat . mapM attribute
+
+tagInstances :: Name -> [Name] -> Q [Dec]
+tagInstances tagTy = return . map (tagInstance tagTy)
+
+tagInstance :: Name -> Name -> Dec
+tagInstance tagTy nm =
+  InstanceD [] (ConT nmTagCon `AppT` ConT tagTy)
+            [ValD (VarP nmTagFun) (NormalB (ConE nmTagCon)) []]
+  where
+    nmBase   = nameBase nm
+    nmTagFun = mkTagName . lowerFirst $ nmBase
+    nmTagCon = mkTagName nmBase
+
+mkIsChildOf :: Name -> Name -> Dec
+mkIsChildOf child nod = InstanceD [] (ConT ''IsChildOf `AppT` ConT child `AppT` ConT nod) []
+
+mkIsAttributeOf :: Name -> Name -> Dec
+mkIsAttributeOf attr nod = InstanceD [] (ConT ''IsAttributeOf `AppT` ConT attr `AppT` ConT nod) []
+
+nodeChildren :: Name -> [Name] -> Q [Dec]
+nodeChildren nod = return . map (`mkIsChildOf` nod)
+
+nodeAttributes :: Name -> [Name] -> Q [Dec]
+nodeAttributes nod = return . map (`mkIsAttributeOf` nod)