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