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