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 (Seq, 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         let (attrs,children) = partitionAttributesChildren ts in
  64         let d_content =
  65                 forM_ (case Seq.viewl children of {Tree0{} :< ts' -> ts'; _ -> children}) $
  66                         d_TreeCell (key:path) in
  67         (\acc -> foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v)) acc attrs) $
  68         case Seq.viewl children of
  69          Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
  70                 case Text.splitOn "\n" title of
  71                  t0:t1 ->
  72                         D.section ! DA.name (attrValue t0) $ do
  73                                 let st = Text.intercalate "\n" t1
  74                                 when (not (Text.null st)) $
  75                                         D.name $ B.toMarkup st
  76                                 d_content
  77                  [] ->
  78                         D.section ! DA.name (attrValue title) $
  79                                 d_content
  80          Tree0 (Cell _posTitle _ title) :< _ ->
  81                 D.section $ do
  82                         D.name $ d_Token (key:path) title
  83                         d_content
  84          _ -> D.section d_content
  85 d_TreeCell path (Tree0 cell) = d_CellToken path cell
  86 d_TreeCell path (TreeN cell@(unCell -> KeyColon{}) ts) =
  87         let (attrs,children) = partitionAttributesChildren ts in
  88         foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v))
  89          (d_CellKey path cell children)
  90          attrs
  91 d_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
  92
  93 partitionAttributesChildren :: Seq (Tree (Cell Key) (Cell Token)) -> ([(Name,Text)],Seq (Tree (Cell Key) (Cell Token)))
  94 partitionAttributesChildren ts = (attrs,children)
  95         where
  96         attrs :: [(Name,Text)]
  97         attrs =
  98                 foldr (\t acc ->
  99                         case t of
 100                          Tree0{} -> acc
 101                          TreeN (unCell -> KeyEqual n _wh) a -> (n,v):acc
 102                                 where
 103                                 v = TL.toStrict $
 104                                         Write.text Write.config_text{Write.config_text_escape = False} $
 105                                         Write.treeRackUpLeft <$> a
 106                          TreeN{} -> acc
 107                  ) [] ts
 108         children = Seq.filter (\t ->
 109                 case t of
 110                  Tree0{} -> True
 111                  TreeN (unCell -> KeyEqual{}) _cs -> False
 112                  TreeN{} -> True
 113                  ) ts
 114
 115
 116 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> DTC
 117 d_CellKey path (Cell _pos _posEnd key) cells = do
 118         case key of
 119          KeyColon n _wh -> d_Key n
 120          KeyGreat n _wh -> d_Key n
 121          KeyEqual n _wh -> d_Key n
 122          KeyBar   n _wh -> d_Key n
 123          KeyDash -> do
 124                 B.toMarkup ("- "::Text)
 125                 forM_ cells $ d_TreeCell (key:path)
 126          {-
 127          KeyLower name attrs -> do
 128                 B.Content $ "<"<>B.toMarkup name
 129                 d_Attrs attrs
 130                 forM_ cells $ d_TreeCell path
 131          -}
 132         where
 133         d_Key :: Text -> DTC
 134         d_Key name | null cells =
 135                 B.CustomLeaf (B.Text name) True mempty
 136         d_Key name =
 137                 B.CustomParent (B.Text name) $
 138                         forM_ cells $ d_TreeCell (key:path)
 139
 140 d_CellToken :: [Key] -> Cell Token -> DTC
 141 d_CellToken path (Cell _pos _posEnd tok) =
 142         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
 143         case dbg "d_CellToken: path" path of
 144          KeySection{}:_ ->
 145                 case tok of
 146                  TokenPair PairElem{} _t -> d_Token path tok
 147                  _ -> D.para $ d_Token path tok
 148          _ -> d_Token path tok
 149
 150 d_Token :: [Key] -> Token -> DTC
 151 d_Token path tok = go tok
 152         where
 153         -- indent = Text.replicate (columnPos pos - 1) " "
 154         go :: Token -> DTC
 155         go (TokenPlain txt) = B.toMarkup txt
 156         go (TokenTag v) = D.ref mempty ! DA.to (attrValue v)
 157         go (TokenEscape c) = B.toMarkup c
 158         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 159         go (TokenPair PairSlash t) = D.i $ go t
 160         go (TokenPair PairBackquote t) = D.code $ go t
 161         go (TokenPair PairFrenchquote t) = D.q $ go t
 162         go (TokenPair PairHash (TokenPlain t)) =
 163                 D.ref mempty ! DA.to (attrValue t)
 164         go (TokenPair (PairElem name attrs) t) =
 165                 d_Attrs attrs $
 166                 case t of
 167                  Tokens ts | Seq.null ts ->
 168                         B.CustomLeaf (B.Text name) True mempty
 169                  _ -> B.CustomParent (B.Text name) $ go t
 170         go (TokenPair p t) = do
 171                 let (o,c) = pairBorders p t
 172                 B.toMarkup o
 173                 go t
 174                 B.toMarkup c
 175         go (Tokens ts) = foldMap go ts
 176
 177 d_Attrs :: Attrs -> DTC -> DTC
 178 d_Attrs = flip $ foldl' d_Attr
 179
 180 d_Attr :: DTC -> (Text,Attr) -> DTC
 181 d_Attr acc (_,Attr{..}) =
 182         B.AddCustomAttribute
 183          (B.Text attr_name)
 184          (B.Text attr_value)
 185          acc