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') <- gatherLIs ts, not (null ul) -> do
  94                 D.ul $ forM_ ul $ d_Tree path
  95                 d_Trees path ts'
  96          _ | t:<ts' <- Seq.viewl ts -> do
  97                 d_Tree path t
  98                 d_Trees path ts'
  99          _ ->
 100                 return ()
 101
 102 gatherLIs ::
 103  Trees (Cell Key) (Cell Tokens) ->
 104  ( Trees (Cell Key) (Cell Tokens)
 105  , Trees (Cell Key) (Cell Tokens) )
 106 gatherLIs ts =
 107         let (lis, ts') = spanLIs ts in
 108         foldl' accumLIs (mempty,ts') lis
 109         where
 110         spanLIs = Seq.spanl $ \case
 111                  TreeN (unCell -> KeyDash) _ -> True
 112                  Tree0 (unCell -> Tokens toks) ->
 113                         (`any` toks) $ \case
 114                          TokenPair (PairElem "li" _) _ -> True
 115                          _ -> False
 116                  _ -> False
 117         accumLIs acc@(oks,kos) t =
 118                 case t of
 119                  TreeN (unCell -> KeyDash) _ -> (oks|>t,kos)
 120                  Tree0 (Cell pos posEnd (Tokens toks)) ->
 121                         let mk = Tree0 . Cell pos posEnd . Tokens in
 122                         let (ok,ko) =
 123                                 (`Seq.spanl` toks) $ \case
 124                                  TokenPair (PairElem "li" _) _ -> True
 125                                  TokenPlain txt -> Char.isSpace`Text.all`txt
 126                                  _ -> False in
 127                         ( if null ok then oks else oks|>mk (rmTokenPlain ok)
 128                         , if null ko then kos else mk ko<|kos )
 129                  _ -> acc
 130         rmTokenPlain =
 131                 Seq.filter $ \case
 132                  TokenPlain{} -> False
 133                  _ -> True
 134
 135 d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
 136 d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
 137         case Seq.viewl children of
 138          Tree0 (Cell _posTitle _ (toList -> [TokenPlain title])) :< body ->
 139                 d_attrs (mangleAttrs title attrs) $
 140                 case Text.splitOn "\n" title of
 141                  t0:t1 ->
 142                         D.section ! DA.name (attrValue t0) $ do
 143                                 let st = Text.intercalate "\n" t1
 144                                 when (not (Text.null st)) $
 145                                         D.name $ B.toMarkup st
 146                                 d_content body
 147                  [] ->
 148                         D.section ! DA.name (attrValue title) $
 149                                 d_content body
 150          Tree0 (Cell _posTitle _ title) :< body ->
 151                 d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $
 152                 D.section $ do
 153                         D.name $ d_Tokens (key:path) title
 154                         d_content body
 155          _ ->
 156                 d_attrs attrs $
 157                 D.section $ d_content children
 158         where
 159         (attrs,children) = partitionAttributesChildren ts
 160         d_content cs     = d_Trees (key:path) cs
 161         mangleAttrs :: Text -> Attributes -> Attributes
 162         mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
 163 d_Tree path (Tree0 cell) = d_CellTokens path cell
 164 d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
 165         let (attrs,children) = partitionAttributesChildren ts in
 166         d_attrs attrs $ d_CellKey path cell children
 167 d_Tree path (TreeN cell ts) = d_CellKey path cell ts
 168
 169 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
 170 d_CellKey path (Cell _pos _posEnd key) cells = do
 171         case key of
 172          KeyColon n _wh -> d_Key n
 173          KeyGreat n _wh -> d_Key n
 174          KeyEqual n _wh -> d_Key n
 175          KeyBar   n _wh -> d_Key n
 176          KeyDash -> D.li $ d_Trees (key:path) cells
 177          {-
 178          KeyLower name attrs -> do
 179                 B.Content $ "<"<>B.toMarkup name
 180                 d_Attrs attrs
 181                 forM_ cells $ d_Tree path
 182          -}
 183         where
 184         d_Key :: Text -> DTC
 185         d_Key name | null cells =
 186                 B.CustomLeaf (B.Text name) True mempty
 187         d_Key name =
 188                 B.CustomParent (B.Text name) $
 189                         d_Trees (key:path) cells
 190
 191 d_CellTokens :: [Key] -> Cell Tokens -> DTC
 192 d_CellTokens path (Cell _pos _posEnd ts) =
 193         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
 194         case dbg "d_CellTokens: path" path of
 195          [] ->
 196                 case ts of
 197                  (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 198                  _ -> D.para $ d_Tokens path ts
 199          KeySection{}:_ ->
 200                 case ts of
 201                  (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 202                  _ -> D.para $ d_Tokens path ts
 203          _ -> d_Tokens path ts
 204
 205 d_Tokens :: [Key] -> Tokens -> DTC
 206 d_Tokens _path tok = goTokens tok
 207         where
 208         -- indent = Text.replicate (columnPos pos - 1) " "
 209         go :: Token -> DTC
 210         go (TokenPlain t)  = B.toMarkup t
 211         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 212         go (TokenEscape c) = B.toMarkup c
 213         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 214         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 215         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 216         go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
 217         go (TokenPair PairHash (toList -> [TokenPlain ts])) =
 218                 D.ref mempty ! DA.to (attrValue ts)
 219         go (TokenPair (PairElem name attrs) ts) =
 220                 d_Attrs attrs $
 221                 case ts of
 222                  Tokens s | Seq.null s ->
 223                         B.CustomLeaf (B.Text name) True mempty
 224                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 225         go (TokenPair p ts) = do
 226                 let (o,c) = pairBorders p ts
 227                 B.toMarkup o
 228                 goTokens ts
 229                 B.toMarkup c
 230         goTokens :: Tokens -> DTC
 231         goTokens (Tokens ts) = foldMap go ts
 232
 233 d_Attrs :: Attrs -> DTC -> DTC
 234 d_Attrs = flip $ foldl' d_Attr
 235
 236 d_Attr :: DTC -> (Text,Attr) -> DTC
 237 d_Attr acc (_,Attr{..}) =
 238         B.AddCustomAttribute
 239          (B.Text attr_name)
 240          (B.Text attr_value)
 241          acc
 242
 243 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 244 -- attr_id title = ("id",title)
 245
 246 -- * Type 'Attributes'
 247 type Attributes = Map Name Text
 248
 249 d_attrs :: Attributes -> DTC -> DTC
 250 d_attrs = flip $ Map.foldrWithKey $ \n v ->
 251         B.AddCustomAttribute (B.Text n) (B.Text v)
 252
 253 partitionAttributesChildren ::
 254  Trees (Cell Key) (Cell Tokens) ->
 255  (Attributes, Trees (Cell Key) (Cell Tokens))
 256 partitionAttributesChildren ts = (attrs,children)
 257         where
 258         attrs :: Attributes
 259         attrs =
 260                 foldr (\t acc ->
 261                         case t of
 262                          Tree0{} -> acc
 263                          TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
 264                                 where
 265                                 v = TL.toStrict $
 266                                         Write.text Write.config_text{Write.config_text_escape = False} $
 267                                         Write.treeRackUpLeft <$> a
 268                          TreeN{} -> acc
 269                  ) mempty ts
 270         children = Seq.filter (\t ->
 271                 case t of
 272                  Tree0{} -> True
 273                  TreeN (unCell -> KeyEqual{}) _cs -> False
 274                  TreeN{} -> True
 275                  ) ts