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