Html.hs

{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}
module Document.Semantics.Html where

import Control.Monad

import Data.HList.Label4
import Data.HList.TypeEqGeneric1
import Data.HList.TypeCastGeneric1

import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.Derive

import Document.Decl

$(attLabels ["html"])

-- Document production
document_html = syn html $
    do blocks <- at ch_blocks
       return $ blocks # html



-- Blocks productions
blockLnil_html = syn html $ return ""

blockLcons_html = syn html $
    do block  <- at ch_hd_BlockL_Cons
       blocks <- at ch_tl_BlockL_Cons
       return $ block # html ++ blocks # html


--blockLcons_html = use html (nt_BlockL .*. HNil) (++) ""

-- Block productions
header_html = syn html $
    do level  <- at ch_level_header
       inls   <- at ch_inlines_header
       return $ "<h" ++ show level ++ ">" 
                 ++ inls # html
                 ++ "</h" ++ show level ++ ">"
                 ++ "\n"

paragraph_html = syn html $
    do inls <- at ch_inlines_par
       return $ "<p>" 
              ++ inls # html
              ++ "</p>"
              ++ "\n"



-- Inline productions

inlineLnil_html = syn html $ return ""
inlineLcons_html = syn html $
    do inl  <- at ch_hd_InlineL_Cons
       inls <- at ch_tl_InlineL_Cons
       return $ inl # html ++ inls # html


plain_html = syn html $ at ch_str_plainInl


bold_html  = syn html $ 
                    do inls <- at ch_inlines_boldInl
                       return $ "<b>" 
                              ++ inls # html 
                              ++ "</b>"

italics_html  = syn html $ 
                    do inls <- at ch_inlines_italInl
                       return $ "<i>" 
                              ++ inls # html
                              ++ "</i>"




-----------------------
-- building the record

{- 
aspDocument     = document_html
aspBlockL_Nil   = blockLnil_html
aspBlockL_Cons  = blockLcons_html
aspHeader       = header_html
aspParagraph    = paragraph_html
aspInlineL_Nil  = inlineLnil_html
aspInlineL_Cons = inlineLcons_html
aspPlain        = plain_html
aspBold         = bold_html
aspItalics      = italics_html
-}
semHtml = mkDoc' blockLcons_html blockLnil_html bold_html
                 document_html header_html inlineLcons_html inlineLnil_html
                 italics_html paragraph_html plain_html


-- slightly edited mkDoc (from TH splice)
mkDoc'
      _BlockL_Cons
      _BlockL_Nil
      _Bold
      _Document
      _Header
      _InlineL_Cons
      _InlineL_Nil
      _Italics
      _Paragraph
      _Plain
      = DocSF
          {pBlockL_Cons = semP_BlockL_Cons _BlockL_Cons,
           pBlockL_Nil = semP_BlockL_Nil _BlockL_Nil, pBold = semP_Bold _Bold,
           pDocument = semP_Document _Document, pHeader = semP_Header _Header . sem_Lit,
           pInlineL_Cons = semP_InlineL_Cons _InlineL_Cons,
           pInlineL_Nil = semP_InlineL_Nil _InlineL_Nil,
           pItalics = semP_Italics _Italics,
           pParagraph = semP_Paragraph _Paragraph, pPlain = semP_Plain _Plain . sem_Lit}



{- -- OLD, not extensible
semHtmlNotExtensible :: Document -> String
semHtmlNotExtensible doc = sem_Document asp_html doc () # html




------------------------------------------
-- Initial aspect html (synthesized html)
------------------------------------------

-- The aspect is a heterogenous list of pairs of production and rule
asp_html =  (p_Document     .=. document_html) 
         .*. (p_BlockL_Nil   .=. blockLnil_html)
         .*. (p_BlockL_Cons  .=. blockLcons_html)
         .*. (p_Header       .=. header_html) 
         .*. (p_Paragraph    .=. paragraph_html)
         .*. (p_InlineL_Nil  .=. inlineLnil_html)
         .*. (p_InlineL_Cons .=. inlineLcons_html)
         .*. (p_Plain        .=. plain_html)
         .*. (p_Bold         .=. bold_html) 
         .*. (p_Italics      .=. italics_html)
         .*. emptyRecord
-}