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