Language/TCT/Write/DTC.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 -- | Render a TCT file in DTC.
   6 module Language.TCT.Write.DTC where
   7
   8 import Control.Monad (forM_, when)
   9 import Data.Bool
  10 import Data.Foldable (Foldable(..))
  11 import Data.Function (($), (.), flip)
  12 import Data.Functor ((<$>))
  13 import Data.Monoid (Monoid(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.Sequence (Seq, ViewL(..))
  16 import Data.String (String)
  17 import Data.Text (Text)
  18 import Text.Blaze ((!))
  19 import Text.Show (Show(..))
  20 import qualified Data.Sequence as Seq
  21 import qualified Data.Text as Text
  22 import qualified Text.Blaze as B
  23 import qualified Text.Blaze.Internal as B
  24 import qualified Data.Text.Lazy as TL
  25
  26 import Language.TCT.Tree
  27 import Language.TCT.Token
  28 import Language.TCT.Elem hiding (trac,dbg)
  29 import qualified Language.TCT.Write.Text as Write
  30 import Text.Blaze.Utils
  31 import Text.Blaze.DTC (DTC)
  32 import qualified Text.Blaze.DTC as D
  33 import qualified Text.Blaze.DTC.Attributes as DA
  34
  35 import Debug.Trace (trace)
  36 trac :: String -> a -> a
  37 -- trac _m x = x
  38 trac m x = trace m x
  39 dbg :: Show a => String -> a -> a
  40 dbg m x = trac (m <> ": " <> show x) x
  41
  42 dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
  43 dtc tct = do
  44         let lang = "fr"
  45         D.xmlModel        "./schema/dtc.rnc"
  46         D.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  47         D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  48         D.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  49         D.document $
  50                 forM_ tct $ d_TreeCell []
  51
  52 d_TreeCell :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
  53 d_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
  54         let (attrs,children) = partitionAttributesChildren ts in
  55         let d_content =
  56                 forM_ (case Seq.viewl children of {Tree0{} :< ts' -> ts'; _ -> children}) $
  57                         d_TreeCell (key:path) in
  58         (\acc -> foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v)) acc attrs) $
  59         case Seq.viewl children of
  60          Tree0 (Cell _posTitle _ (toList . unTokens -> [TokenPlain title])) :< _ ->
  61                 case Text.splitOn "\n" title of
  62                  t0:t1 ->
  63                         D.section ! DA.name (attrValue t0) $ do
  64                                 let st = Text.intercalate "\n" t1
  65                                 when (not (Text.null st)) $
  66                                         D.name $ B.toMarkup st
  67                                 d_content
  68                  [] ->
  69                         D.section ! DA.name (attrValue title) $
  70                                 d_content
  71          Tree0 (Cell _posTitle _ title) :< _ ->
  72                 D.section $ do
  73                         D.name $ d_Tokens (key:path) title
  74                         d_content
  75          _ -> D.section d_content
  76 d_TreeCell path (Tree0 cell) = d_CellTokens path cell
  77 d_TreeCell path (TreeN cell@(unCell -> KeyColon{}) ts) =
  78         let (attrs,children) = partitionAttributesChildren ts in
  79         foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v))
  80          (d_CellKey path cell children)
  81          attrs
  82 d_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
  83
  84 partitionAttributesChildren :: Seq (Tree (Cell Key) (Cell Tokens)) -> ([(Name,Text)],Seq (Tree (Cell Key) (Cell Tokens)))
  85 partitionAttributesChildren ts = (attrs,children)
  86         where
  87         attrs :: [(Name,Text)]
  88         attrs =
  89                 foldr (\t acc ->
  90                         case t of
  91                          Tree0{} -> acc
  92                          TreeN (unCell -> KeyEqual n _wh) a -> (n,v):acc
  93                                 where
  94                                 v = TL.toStrict $
  95                                         Write.text Write.config_text{Write.config_text_escape = False} $
  96                                         Write.treeRackUpLeft <$> a
  97                          TreeN{} -> acc
  98                  ) [] ts
  99         children = Seq.filter (\t ->
 100                 case t of
 101                  Tree0{} -> True
 102                  TreeN (unCell -> KeyEqual{}) _cs -> False
 103                  TreeN{} -> True
 104                  ) ts
 105
 106 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
 107 d_CellKey path (Cell _pos _posEnd key) cells = do
 108         case key of
 109          KeyColon n _wh -> d_Key n
 110          KeyGreat n _wh -> d_Key n
 111          KeyEqual n _wh -> d_Key n
 112          KeyBar   n _wh -> d_Key n
 113          KeyDash -> do
 114                 B.toMarkup ("- "::Text)
 115                 forM_ cells $ d_TreeCell (key:path)
 116          {-
 117          KeyLower name attrs -> do
 118                 B.Content $ "<"<>B.toMarkup name
 119                 d_Attrs attrs
 120                 forM_ cells $ d_TreeCell path
 121          -}
 122         where
 123         d_Key :: Text -> DTC
 124         d_Key name | null cells =
 125                 B.CustomLeaf (B.Text name) True mempty
 126         d_Key name =
 127                 B.CustomParent (B.Text name) $
 128                         forM_ cells $ d_TreeCell (key:path)
 129
 130 d_CellTokens :: [Key] -> Cell Tokens -> DTC
 131 d_CellTokens path (Cell _pos _posEnd ts) =
 132         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
 133         case dbg "d_CellTokens: path" path of
 134          KeySection{}:_ ->
 135                 case ts of
 136                  _ | [TokenPair PairElem{} _ts] <- toList (unTokens ts) -> d_Tokens path ts
 137                  _ -> D.para $ d_Tokens path ts
 138          _ -> d_Tokens path ts
 139
 140 d_Tokens :: [Key] -> Tokens -> DTC
 141 d_Tokens _path tok = goTokens tok
 142         where
 143         -- indent = Text.replicate (columnPos pos - 1) " "
 144         go :: Token -> DTC
 145         go (TokenPlain txt) = B.toMarkup txt
 146         go (TokenTag v) = D.ref mempty ! DA.to (attrValue v)
 147         go (TokenEscape c) = B.toMarkup c
 148         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 149         go (TokenPair PairSlash ts) = D.i $ goTokens ts
 150         go (TokenPair PairBackquote ts) = D.code $ goTokens ts
 151         go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
 152         go (TokenPair PairHash (toList . unTokens -> [TokenPlain ts])) =
 153                 D.ref mempty ! DA.to (attrValue ts)
 154         go (TokenPair (PairElem name attrs) ts) =
 155                 d_Attrs attrs $
 156                 case ts of
 157                  Tokens s | Seq.null s ->
 158                         B.CustomLeaf (B.Text name) True mempty
 159                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 160         go (TokenPair p ts) = do
 161                 let (o,c) = pairBorders p ts
 162                 B.toMarkup o
 163                 goTokens ts
 164                 B.toMarkup c
 165         goTokens :: Tokens -> DTC
 166         goTokens (Tokens ts) = foldMap go ts
 167
 168 d_Attrs :: Attrs -> DTC -> DTC
 169 d_Attrs = flip $ foldl' d_Attr
 170
 171 d_Attr :: DTC -> (Text,Attr) -> DTC
 172 d_Attr acc (_,Attr{..}) =
 173         B.AddCustomAttribute
 174          (B.Text attr_name)
 175          (B.Text attr_value)
 176          acc