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          KeySection{}:_ ->
 196                 case ts of
 197                  (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 198                  _ -> D.para $ d_Tokens path ts
 199          _ -> d_Tokens path ts
 200
 201 d_Tokens :: [Key] -> Tokens -> DTC
 202 d_Tokens _path tok = goTokens tok
 203         where
 204         -- indent = Text.replicate (columnPos pos - 1) " "
 205         go :: Token -> DTC
 206         go (TokenPlain t)  = B.toMarkup t
 207         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 208         go (TokenEscape c) = B.toMarkup c
 209         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 210         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 211         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 212         go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
 213         go (TokenPair PairHash (toList -> [TokenPlain ts])) =
 214                 D.ref mempty ! DA.to (attrValue ts)
 215         go (TokenPair (PairElem name attrs) ts) =
 216                 d_Attrs attrs $
 217                 case ts of
 218                  Tokens s | Seq.null s ->
 219                         B.CustomLeaf (B.Text name) True mempty
 220                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 221         go (TokenPair p ts) = do
 222                 let (o,c) = pairBorders p ts
 223                 B.toMarkup o
 224                 goTokens ts
 225                 B.toMarkup c
 226         goTokens :: Tokens -> DTC
 227         goTokens (Tokens ts) = foldMap go ts
 228
 229 d_Attrs :: Attrs -> DTC -> DTC
 230 d_Attrs = flip $ foldl' d_Attr
 231
 232 d_Attr :: DTC -> (Text,Attr) -> DTC
 233 d_Attr acc (_,Attr{..}) =
 234         B.AddCustomAttribute
 235          (B.Text attr_name)
 236          (B.Text attr_value)
 237          acc
 238
 239 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 240 -- attr_id title = ("id",title)
 241
 242 -- * Type 'Attributes'
 243 type Attributes = Map Name Text
 244
 245 d_attrs :: Attributes -> DTC -> DTC
 246 d_attrs = flip $ Map.foldrWithKey $ \n v ->
 247         B.AddCustomAttribute (B.Text n) (B.Text v)
 248
 249 partitionAttributesChildren ::
 250  Trees (Cell Key) (Cell Tokens) ->
 251  (Attributes, Trees (Cell Key) (Cell Tokens))
 252 partitionAttributesChildren ts = (attrs,children)
 253         where
 254         attrs :: Attributes
 255         attrs =
 256                 foldr (\t acc ->
 257                         case t of
 258                          Tree0{} -> acc
 259                          TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
 260                                 where
 261                                 v = TL.toStrict $
 262                                         Write.text Write.config_text{Write.config_text_escape = False} $
 263                                         Write.treeRackUpLeft <$> a
 264                          TreeN{} -> acc
 265                  ) mempty ts
 266         children = Seq.filter (\t ->
 267                 case t of
 268                  Tree0{} -> True
 269                  TreeN (unCell -> KeyEqual{}) _cs -> False
 270                  TreeN{} -> True
 271                  ) ts