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                         forM_ (mangleHead title head) $ d_TreeCell []
  57                         forM_ body $ d_TreeCell []
  58                  _ ->
  59                         forM_ ts $ d_TreeCell []
  60         where
  61         mangleHead ::
  62          Text ->
  63          Trees (Cell Key) (Cell Tokens) ->
  64          Trees (Cell Key) (Cell Tokens)
  65         mangleHead title head =
  66                 (<$> head) $ \case
  67                  TreeN cell@(unCell -> KeyColon "about" _) about ->
  68                         TreeN cell $ Seq.fromList (name <$> Text.splitOn "\n" title) <> about
  69                         where
  70                         name =
  71                                 TreeN (cell0 (KeyColon "name" "")) .
  72                                 Seq.fromList . return .
  73                                 Tree0 . cell0 .
  74                                 tokens . return . TokenPlain
  75                  t -> t
  76
  77 d_TreeCell :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
  78 d_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
  79         case Seq.viewl children of
  80          Tree0 (Cell _posTitle _ (unTokens -> toList -> [TokenPlain title])) :< body ->
  81                 d_attrs (mangleAttrs title attrs) $
  82                 case Text.splitOn "\n" title of
  83                  t0:t1 ->
  84                         D.section ! DA.name (attrValue t0) $ do
  85                                 let st = Text.intercalate "\n" t1
  86                                 when (not (Text.null st)) $
  87                                         D.name $ B.toMarkup st
  88                                 d_content body
  89                  [] ->
  90                         D.section ! DA.name (attrValue title) $
  91                                 d_content body
  92          Tree0 (Cell _posTitle _ title) :< body ->
  93                 d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $
  94                 D.section $ do
  95                         D.name $ d_Tokens (key:path) title
  96                         d_content body
  97          _ ->
  98                 d_attrs attrs $
  99                 D.section $ d_content children
 100         where
 101         (attrs,children) = partitionAttributesChildren ts
 102         d_content cs     = forM_ cs $ d_TreeCell (key:path)
 103         mangleAttrs :: Text -> Attributes -> Attributes
 104         mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
 105 d_TreeCell path (Tree0 cell) = d_CellTokens path cell
 106 d_TreeCell path (TreeN cell@(unCell -> KeyColon{}) ts) =
 107         let (attrs,children) = partitionAttributesChildren ts in
 108         d_attrs attrs $ d_CellKey path cell children
 109 d_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
 110
 111 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
 112 d_CellKey path (Cell _pos _posEnd key) cells = do
 113         case key of
 114          KeyColon n _wh -> d_Key n
 115          KeyGreat n _wh -> d_Key n
 116          KeyEqual n _wh -> d_Key n
 117          KeyBar   n _wh -> d_Key n
 118          KeyDash -> do
 119                 B.toMarkup ("- "::Text)
 120                 forM_ cells $ d_TreeCell (key:path)
 121          {-
 122          KeyLower name attrs -> do
 123                 B.Content $ "<"<>B.toMarkup name
 124                 d_Attrs attrs
 125                 forM_ cells $ d_TreeCell path
 126          -}
 127         where
 128         d_Key :: Text -> DTC
 129         d_Key name | null cells =
 130                 B.CustomLeaf (B.Text name) True mempty
 131         d_Key name =
 132                 B.CustomParent (B.Text name) $
 133                         forM_ cells $ d_TreeCell (key:path)
 134
 135 d_CellTokens :: [Key] -> Cell Tokens -> DTC
 136 d_CellTokens path (Cell _pos _posEnd ts) =
 137         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
 138         case dbg "d_CellTokens: path" path of
 139          KeySection{}:_ ->
 140                 case ts of
 141                  (unTokens -> toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
 142                  _ -> D.para $ d_Tokens path ts
 143          _ -> d_Tokens path ts
 144
 145 d_Tokens :: [Key] -> Tokens -> DTC
 146 d_Tokens _path tok = goTokens tok
 147         where
 148         -- indent = Text.replicate (columnPos pos - 1) " "
 149         go :: Token -> DTC
 150         go (TokenPlain t)  = B.toMarkup t
 151         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 152         go (TokenEscape c) = B.toMarkup c
 153         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 154         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 155         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 156         go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
 157         go (TokenPair PairHash (unTokens -> toList -> [TokenPlain ts])) =
 158                 D.ref mempty ! DA.to (attrValue ts)
 159         go (TokenPair (PairElem name attrs) ts) =
 160                 d_Attrs attrs $
 161                 case ts of
 162                  Tokens s | Seq.null s ->
 163                         B.CustomLeaf (B.Text name) True mempty
 164                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 165         go (TokenPair p ts) = do
 166                 let (o,c) = pairBorders p ts
 167                 B.toMarkup o
 168                 goTokens ts
 169                 B.toMarkup c
 170         goTokens :: Tokens -> DTC
 171         goTokens (Tokens ts) = foldMap go ts
 172
 173 d_Attrs :: Attrs -> DTC -> DTC
 174 d_Attrs = flip $ foldl' d_Attr
 175
 176 d_Attr :: DTC -> (Text,Attr) -> DTC
 177 d_Attr acc (_,Attr{..}) =
 178         B.AddCustomAttribute
 179          (B.Text attr_name)
 180          (B.Text attr_value)
 181          acc
 182
 183 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 184 -- attr_id title = ("id",title)
 185
 186 -- * Type 'Attributes'
 187 type Attributes = Map Name Text
 188
 189 d_attrs :: Attributes -> DTC -> DTC
 190 d_attrs = flip $ Map.foldrWithKey $ \n v ->
 191         B.AddCustomAttribute (B.Text n) (B.Text v)
 192
 193 partitionAttributesChildren ::
 194  Trees (Cell Key) (Cell Tokens) ->
 195  (Attributes, Trees (Cell Key) (Cell Tokens))
 196 partitionAttributesChildren ts = (attrs,children)
 197         where
 198         attrs :: Attributes
 199         attrs =
 200                 foldr (\t acc ->
 201                         case t of
 202                          Tree0{} -> acc
 203                          TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
 204                                 where
 205                                 v = TL.toStrict $
 206                                         Write.text Write.config_text{Write.config_text_escape = False} $
 207                                         Write.treeRackUpLeft <$> a
 208                          TreeN{} -> acc
 209                  ) mempty ts
 210         children = Seq.filter (\t ->
 211                 case t of
 212                  Tree0{} -> True
 213                  TreeN (unCell -> KeyEqual{}) _cs -> False
 214                  TreeN{} -> True
 215                  ) ts