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 (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 (ViewL(..))
  16 import Data.String (String)
  17 import Data.Text (Text)
  18 import Text.Blaze ((!))
  19 import Text.Show (Show(..))
  20 import Data.Map.Strict (Map)
  21 import qualified Data.Sequence as Seq
  22 import qualified Data.Text as Text
  23 import qualified Text.Blaze as B
  24 import qualified Text.Blaze.Internal as B
  25 import qualified Data.Text.Lazy as TL
  26 import qualified Data.Map.Strict as Map
  27
  28 import Language.TCT.Tree
  29 import Language.TCT.Token
  30 import Language.TCT.Elem hiding (trac,dbg)
  31 import qualified Language.TCT.Write.Text as Write
  32 import Text.Blaze.Utils
  33 import Text.Blaze.DTC (DTC)
  34 import qualified Text.Blaze.DTC as D
  35 import qualified Text.Blaze.DTC.Attributes as DA
  36
  37 import Debug.Trace (trace)
  38 trac :: String -> a -> a
  39 -- trac _m x = x
  40 trac m x = trace m x
  41 dbg :: Show a => String -> a -> a
  42 dbg m x = trac (m <> ": " <> show x) x
  43
  44 dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
  45 dtc ts = do
  46         let lang = "fr"
  47         D.xmlModel "./schema/dtc.rnc"
  48         D.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  49         D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  50         D.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  51         D.document $
  52                 case Seq.viewl ts of
  53                  TreeN (unCell -> KeySection{})
  54                        (Seq.viewl -> Tree0 (unCell -> Write.t_Tokens -> TL.toStrict -> title) :< head)
  55                        :< body -> do
  56                         d_Trees [] (mangleHead title head)
  57                         d_Trees [] body
  58                  _ ->
  59                         d_Trees [] ts
  60         where
  61         mangleHead ::
  62          Text ->
  63          Trees (Cell Key) (Cell Tokens) ->
  64          Trees (Cell Key) (Cell Tokens)
  65         mangleHead title head =
  66                 (<$> head) $ \case
  67                  TreeN cell@(unCell -> KeyColon "about" _) about ->
  68                         TreeN cell $ Seq.fromList (name <$> Text.splitOn "\n" title) <> about
  69                         where
  70                         name =
  71                                 TreeN (cell0 (KeyColon "name" "")) .
  72                                 Seq.fromList . return .
  73                                 Tree0 . cell0 .
  74                                 tokens . return . TokenPlain
  75                  t -> t
  76
  77 d_Trees :: [Key] -> Trees (Cell Key) (Cell Tokens) -> DTC
  78 d_Trees path ts =
  79         case () of
  80          _ | (ul,ts') <- Seq.spanl (\case TreeN (unCell -> KeyDash) _ -> True
  81                                           Tree0 (unCell -> unTokens -> toList -> [TokenPair (PairElem "li" _) _]) -> True
  82                                           _ -> False) ts
  83            , not (null ul) -> do
  84                 D.ul $ forM_ ul $ d_Tree path
  85                 d_Trees path ts'
  86          _ | t:<ts' <- Seq.viewl ts -> do
  87                 d_Tree path t
  88                 d_Trees path ts'
  89          _ ->
  90                 return ()
  91
  92 d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
  93 d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
  94         case Seq.viewl children of
  95          Tree0 (Cell _posTitle _ (unTokens -> toList -> [TokenPlain title])) :< body ->
  96                 d_attrs (mangleAttrs title attrs) $
  97                 case Text.splitOn "\n" title of
  98                  t0:t1 ->
  99                         D.section ! DA.name (attrValue t0) $ do
 100                                 let st = Text.intercalate "\n" t1
 101                                 when (not (Text.null st)) $
 102                                         D.name $ B.toMarkup st
 103                                 d_content body
 104                  [] ->
 105                         D.section ! DA.name (attrValue title) $
 106                                 d_content body
 107          Tree0 (Cell _posTitle _ title) :< body ->
 108                 d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $
 109                 D.section $ do
 110                         D.name $ d_Tokens (key:path) title
 111                         d_content body
 112          _ ->
 113                 d_attrs attrs $
 114                 D.section $ d_content children
 115         where
 116         (attrs,children) = partitionAttributesChildren ts
 117         d_content cs     = d_Trees (key:path) cs
 118         mangleAttrs :: Text -> Attributes -> Attributes
 119         mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
 120 d_Tree path (Tree0 cell) = d_CellTokens path cell
 121 d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
 122         let (attrs,children) = partitionAttributesChildren ts in
 123         d_attrs attrs $ d_CellKey path cell children
 124 d_Tree path (TreeN cell ts) = d_CellKey path cell ts
 125
 126 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
 127 d_CellKey path (Cell _pos _posEnd key) cells = do
 128         case key of
 129          KeyColon n _wh -> d_Key n
 130          KeyGreat n _wh -> d_Key n
 131          KeyEqual n _wh -> d_Key n
 132          KeyBar   n _wh -> d_Key n
 133          KeyDash -> D.li $ d_Trees (key:path) cells
 134          {-
 135          KeyLower name attrs -> do
 136                 B.Content $ "<"<>B.toMarkup name
 137                 d_Attrs attrs
 138                 forM_ cells $ d_Tree path
 139          -}
 140         where
 141         d_Key :: Text -> DTC
 142         d_Key name | null cells =
 143                 B.CustomLeaf (B.Text name) True mempty
 144         d_Key name =
 145                 B.CustomParent (B.Text name) $
 146                         d_Trees (key:path) cells
 147
 148 d_CellTokens :: [Key] -> Cell Tokens -> DTC
 149 d_CellTokens path (Cell _pos _posEnd ts) =
 150         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
 151         case dbg "d_CellTokens: path" path of
 152          KeySection{}:_ ->
 153                 case ts of
 154                  (unTokens -> toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 155                  _ -> D.para $ d_Tokens path ts
 156          _ -> d_Tokens path ts
 157
 158 d_Tokens :: [Key] -> Tokens -> DTC
 159 d_Tokens _path tok = goTokens tok
 160         where
 161         -- indent = Text.replicate (columnPos pos - 1) " "
 162         go :: Token -> DTC
 163         go (TokenPlain t)  = B.toMarkup t
 164         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 165         go (TokenEscape c) = B.toMarkup c
 166         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 167         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 168         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 169         go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
 170         go (TokenPair PairHash (unTokens -> toList -> [TokenPlain ts])) =
 171                 D.ref mempty ! DA.to (attrValue ts)
 172         go (TokenPair (PairElem name attrs) ts) =
 173                 d_Attrs attrs $
 174                 case ts of
 175                  Tokens s | Seq.null s ->
 176                         B.CustomLeaf (B.Text name) True mempty
 177                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 178         go (TokenPair p ts) = do
 179                 let (o,c) = pairBorders p ts
 180                 B.toMarkup o
 181                 goTokens ts
 182                 B.toMarkup c
 183         goTokens :: Tokens -> DTC
 184         goTokens (Tokens ts) = foldMap go ts
 185
 186 d_Attrs :: Attrs -> DTC -> DTC
 187 d_Attrs = flip $ foldl' d_Attr
 188
 189 d_Attr :: DTC -> (Text,Attr) -> DTC
 190 d_Attr acc (_,Attr{..}) =
 191         B.AddCustomAttribute
 192          (B.Text attr_name)
 193          (B.Text attr_value)
 194          acc
 195
 196 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 197 -- attr_id title = ("id",title)
 198
 199 -- * Type 'Attributes'
 200 type Attributes = Map Name Text
 201
 202 d_attrs :: Attributes -> DTC -> DTC
 203 d_attrs = flip $ Map.foldrWithKey $ \n v ->
 204         B.AddCustomAttribute (B.Text n) (B.Text v)
 205
 206 partitionAttributesChildren ::
 207  Trees (Cell Key) (Cell Tokens) ->
 208  (Attributes, Trees (Cell Key) (Cell Tokens))
 209 partitionAttributesChildren ts = (attrs,children)
 210         where
 211         attrs :: Attributes
 212         attrs =
 213                 foldr (\t acc ->
 214                         case t of
 215                          Tree0{} -> acc
 216                          TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
 217                                 where
 218                                 v = TL.toStrict $
 219                                         Write.text Write.config_text{Write.config_text_escape = False} $
 220                                         Write.treeRackUpLeft <$> a
 221                          TreeN{} -> acc
 222                  ) mempty ts
 223         children = Seq.filter (\t ->
 224                 case t of
 225                  Tree0{} -> True
 226                  TreeN (unCell -> KeyEqual{}) _cs -> False
 227                  TreeN{} -> True
 228                  ) ts