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