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 (foldr, null, foldMap, foldl', any)
  11 import Data.Function (($), (.), flip)
  12 import Data.Functor ((<$>))
  13 import Data.Map.Strict (Map)
  14 import Data.Maybe (Maybe(..))
  15 import Data.Monoid (Monoid(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.Sequence (ViewL(..), (<|), (|>))
  18 import Data.String (String)
  19 import Data.Text (Text)
  20 import GHC.Exts (toList)
  21 import Text.Blaze ((!))
  22 import Text.Show (Show(..))
  23 import qualified Data.Char as Char
  24 import qualified Data.Map.Strict as Map
  25 import qualified Data.Sequence as Seq
  26 import qualified Data.Text.Lazy as TL
  27 import qualified Text.Blaze as B
  28 import qualified Text.Blaze.Internal as B
  29
  30 import Language.TCT.Tree
  31 import Language.TCT.Token
  32 import Language.TCT.Elem hiding (trac,dbg)
  33 import qualified Language.TCT.Write.Text as Write
  34 import Text.Blaze.Utils
  35 import Text.Blaze.DTC (DTC)
  36 import qualified Text.Blaze.DTC as D
  37 import qualified Text.Blaze.DTC.Attributes as DA
  38
  39 import Debug.Trace (trace)
  40 trac :: String -> a -> a
  41 -- trac _m x = x
  42 trac m x = trace m x
  43 dbg :: Show a => String -> a -> a
  44 dbg m x = trac (m <> ": " <> show x) x
  45
  46 dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
  47 dtc ts = do
  48         let lang = "fr"
  49         D.xmlModel "./schema/dtc.rnc"
  50         D.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  51         D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  52         D.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  53         D.document $
  54                 case Seq.viewl ts of
  55                  TreeN (unCell -> KeySection{})
  56                        (Seq.viewl -> Tree0 (unCell -> Write.t_Tokens -> title) :< head)
  57                        :< body -> do
  58                         d_Trees [] (mangleHead title head)
  59                         d_Trees [] body
  60                  _ ->
  61                         d_Trees [] ts
  62         where
  63         mangleHead ::
  64          TL.Text ->
  65          Trees (Cell Key) (Cell Tokens) ->
  66          Trees (Cell Key) (Cell Tokens)
  67         mangleHead title head =
  68                 let mi =
  69                         (`Seq.findIndexL` head) $ \case
  70                          TreeN (unCell -> KeyColon "about" _) _ -> True
  71                          _ -> False in
  72                 case mi of
  73                  Nothing ->
  74                         TreeN (cell0 (KeyColon "about" ""))
  75                               (Seq.fromList names)
  76                         <| head
  77                  Just i -> Seq.adjust f i head
  78                         where
  79                         f (TreeN c about) = TreeN c $ Seq.fromList names <> about
  80                         f t = t
  81                 where
  82                 names = name <$> TL.splitOn "\n" title
  83                 name =
  84                         TreeN (cell0 (KeyColon "name" "")) .
  85                         Seq.singleton .
  86                         Tree0 . cell0 .
  87                         Tokens . Seq.singleton . TokenPlain
  88
  89 d_Trees :: [Key] -> Trees (Cell Key) (Cell Tokens) -> DTC
  90 d_Trees path ts =
  91         case () of
  92          _ | (ul,ts') <- gatherUL ts, not (null ul) -> do
  93                 D.ul $ forM_ ul $ d_Tree path
  94                 d_Trees path ts'
  95          _ | (ol,ts') <- gatherOL ts, not (null ol) -> do
  96                 D.ol $ forM_ ol $ d_Tree path
  97                 d_Trees path ts'
  98          _ | t:<ts' <- Seq.viewl ts -> do
  99                 d_Tree path t
 100                 d_Trees path ts'
 101          _ ->
 102                 return ()
 103
 104 gatherUL ::
 105  Trees (Cell Key) (Cell Tokens) ->
 106  ( Trees (Cell Key) (Cell Tokens)
 107  , Trees (Cell Key) (Cell Tokens) )
 108 gatherUL ts =
 109         let (lis, ts') = spanLIs ts in
 110         foldl' accumLIs (mempty,ts') lis
 111         where
 112         spanLIs = Seq.spanl $ \case
 113                  TreeN (unCell -> KeyDash) _ -> True
 114                  Tree0 (unCell -> Tokens toks) ->
 115                         (`any` toks) $ \case
 116                          TokenPair (PairElem "li" _) _ -> True
 117                          _ -> False
 118                  _ -> False
 119         accumLIs acc@(oks,kos) t =
 120                 case t of
 121                  TreeN (unCell -> KeyDash) _ -> (oks|>t,kos)
 122                  Tree0 (Cell pos posEnd (Tokens toks)) ->
 123                         let mk = Tree0 . Cell pos posEnd . Tokens in
 124                         let (ok,ko) =
 125                                 (`Seq.spanl` toks) $ \case
 126                                  TokenPair (PairElem "li" _) _ -> True
 127                                  TokenPlain txt -> Char.isSpace`TL.all`txt
 128                                  _ -> False in
 129                         ( if null ok then oks else oks|>mk (rmTokenPlain ok)
 130                         , if null ko then kos else mk ko<|kos )
 131                  _ -> acc
 132         rmTokenPlain =
 133                 Seq.filter $ \case
 134                  TokenPlain{} -> False
 135                  _ -> True
 136
 137 gatherOL ::
 138  Trees (Cell Key) (Cell Tokens) ->
 139  ( Trees (Cell Key) (Cell Tokens)
 140  , Trees (Cell Key) (Cell Tokens) )
 141 gatherOL ts =
 142         let (lis, ts') = spanLIs ts in
 143         foldl' accumLIs (mempty,ts') lis
 144         where
 145         spanLIs = Seq.spanl $ \case
 146                  TreeN (unCell -> KeyDot{}) _ -> True
 147                  Tree0 (unCell -> Tokens toks) ->
 148                         (`any` toks) $ \case
 149                          TokenPair (PairElem "li" _) _ -> True
 150                          _ -> False
 151                  _ -> False
 152         accumLIs acc@(oks,kos) t =
 153                 case t of
 154                  TreeN (unCell -> KeyDot{}) _ -> (oks|>t,kos)
 155                  Tree0 (Cell pos posEnd (Tokens toks)) ->
 156                         let mk = Tree0 . Cell pos posEnd . Tokens in
 157                         let (ok,ko) =
 158                                 (`Seq.spanl` toks) $ \case
 159                                  TokenPair (PairElem "li" _) _ -> True
 160                                  TokenPlain txt -> Char.isSpace`TL.all`txt
 161                                  _ -> False in
 162                         ( if null ok then oks else oks|>mk (rmTokenPlain ok)
 163                         , if null ko then kos else mk ko<|kos )
 164                  _ -> acc
 165         rmTokenPlain =
 166                 Seq.filter $ \case
 167                  TokenPlain{} -> False
 168                  _ -> True
 169
 170 d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
 171 d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
 172         case Seq.viewl children of
 173          Tree0 (Cell _posTitle _ (toList -> [TokenPlain title])) :< body ->
 174                 d_attrs (mangleAttrs title attrs) $
 175                 case TL.splitOn "\n" title of
 176                  t0:t1 ->
 177                         D.section ! DA.name (attrValue t0) $ do
 178                                 let st = TL.intercalate "\n" t1
 179                                 when (not (TL.null st)) $
 180                                         D.name $ B.toMarkup st
 181                                 d_content body
 182                  [] ->
 183                         D.section ! DA.name (attrValue title) $
 184                                 d_content body
 185          Tree0 (Cell _posTitle _ title) :< body ->
 186                 d_attrs (mangleAttrs (Write.t_Tokens title) attrs) $
 187                 D.section $ do
 188                         D.name $ d_Tokens (key:path) title
 189                         d_content body
 190          _ ->
 191                 d_attrs attrs $
 192                 D.section $ d_content children
 193         where
 194         (attrs,children) = partitionAttributesChildren ts
 195         d_content cs     = d_Trees (key:path) cs
 196         mangleAttrs :: TL.Text -> Attributes -> Attributes
 197         mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
 198 d_Tree path (Tree0 cell) = d_CellTokens path cell
 199 d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
 200         let (attrs,children) = partitionAttributesChildren ts in
 201         d_attrs attrs $ d_CellKey path cell children
 202 d_Tree path (TreeN cell ts) = d_CellKey path cell ts
 203
 204 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
 205 d_CellKey path (Cell _pos _posEnd key) cells = do
 206         case key of
 207          KeyColon n _wh -> d_Key n
 208          KeyGreat n _wh -> d_Key n
 209          KeyEqual n _wh -> d_Key n
 210          KeyBar   n _wh -> d_Key n
 211          KeyDot _n -> D.li $ d_Trees (key:path) cells
 212          KeyDash   -> D.li $ d_Trees (key:path) cells
 213          {-
 214          KeyLower name attrs -> do
 215                 B.Content $ "<"<>B.toMarkup name
 216                 d_Attrs attrs
 217                 forM_ cells $ d_Tree path
 218          -}
 219         where
 220         d_Key :: Text -> DTC
 221         d_Key name | null cells =
 222                 B.CustomLeaf (B.Text name) True mempty
 223         d_Key name =
 224                 B.CustomParent (B.Text name) $
 225                         d_Trees (key:path) cells
 226
 227 d_CellTokens :: [Key] -> Cell Tokens -> DTC
 228 d_CellTokens path (Cell _pos _posEnd ts) =
 229         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
 230         case dbg "d_CellTokens: path" path of
 231          [] ->
 232                 case ts of
 233                  (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 234                  _ -> D.para $ d_Tokens path ts
 235          KeySection{}:_ ->
 236                 case ts of
 237                  (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 238                  _ -> D.para $ d_Tokens path ts
 239          _ -> d_Tokens path ts
 240
 241 d_Tokens :: [Key] -> Tokens -> DTC
 242 d_Tokens _path tok = goTokens tok
 243         where
 244         -- indent = Text.replicate (columnPos pos - 1) " "
 245         go :: Token -> DTC
 246         go (TokenPlain t)  = B.toMarkup t
 247         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 248         go (TokenEscape c) = B.toMarkup c
 249         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 250         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 251         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 252         go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
 253         go (TokenPair PairHash (toList -> [TokenPlain ts])) =
 254                 D.ref mempty ! DA.to (attrValue ts)
 255         go (TokenPair (PairElem name attrs) ts) =
 256                 d_Attrs attrs $
 257                 case ts of
 258                  Tokens s | Seq.null s ->
 259                         B.CustomLeaf (B.Text name) True mempty
 260                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 261         go (TokenPair p ts) = do
 262                 let (o,c) = pairBorders p ts
 263                 B.toMarkup o
 264                 goTokens ts
 265                 B.toMarkup c
 266         goTokens :: Tokens -> DTC
 267         goTokens (Tokens ts) = foldMap go ts
 268
 269 d_Attrs :: Attrs -> DTC -> DTC
 270 d_Attrs = flip $ foldl' d_Attr
 271
 272 d_Attr :: DTC -> (Text,Attr) -> DTC
 273 d_Attr acc (_,Attr{..}) =
 274         B.AddCustomAttribute
 275          (B.Text attr_name)
 276          (B.Text attr_value)
 277          acc
 278
 279 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 280 -- attr_id title = ("id",title)
 281
 282 -- * Type 'Attributes'
 283 type Attributes = Map Name TL.Text
 284
 285 d_attrs :: Attributes -> DTC -> DTC
 286 d_attrs = flip $ Map.foldrWithKey $ \n v ->
 287         B.AddCustomAttribute (B.Text n) (B.Text $ TL.toStrict v)
 288
 289 partitionAttributesChildren ::
 290  Trees (Cell Key) (Cell Tokens) ->
 291  (Attributes, Trees (Cell Key) (Cell Tokens))
 292 partitionAttributesChildren ts = (attrs,children)
 293         where
 294         attrs :: Attributes
 295         attrs =
 296                 foldr (\t acc ->
 297                         case t of
 298                          Tree0{} -> acc
 299                          TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
 300                                 where
 301                                 v =
 302                                         Write.text Write.config_text{Write.config_text_escape = False} $
 303                                         Write.treeRackUpLeft <$> a
 304                          TreeN{} -> acc
 305                  ) mempty ts
 306         children = Seq.filter (\t ->
 307                 case t of
 308                  Tree0{} -> True
 309                  TreeN (unCell -> KeyEqual{}) _cs -> False
 310                  TreeN{} -> True
 311                  ) ts