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.Arrow (first)
   9 import Control.Monad (Monad(..), (=<<), forM_, when)
  10 import Data.Bool
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (foldr, null, foldMap, foldl', any)
  13 import Data.Function (($), (.), flip, id)
  14 import Data.Functor (Functor(..), (<$>))
  15 import Data.Map.Strict (Map)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
  20 import Data.String (String)
  21 import Data.Text (Text)
  22 import GHC.Exts (toList)
  23 import Text.Blaze ((!))
  24 import Text.Show (Show(..))
  25 import qualified Data.Char as Char
  26 import qualified Data.Map.Strict as Map
  27 import qualified Data.Sequence as Seq
  28 import qualified Data.Text as Text
  29 import qualified Data.Text.Lazy as TL
  30 import qualified Text.Blaze as B
  31 import qualified Text.Blaze.Internal as B
  32
  33 import Language.TCT.Tree
  34 import Language.TCT.Token
  35 import Language.TCT.Elem hiding (trac,dbg)
  36 import qualified Language.TCT.Write.Text as Write
  37 import Text.Blaze.Utils
  38 import Text.Blaze.DTC (DTC)
  39 import qualified Text.Blaze.DTC as D
  40 import qualified Text.Blaze.DTC.Attributes as DA
  41
  42 import Debug.Trace (trace)
  43 trac :: String -> a -> a
  44 trac _m x = x
  45 -- trac m x = trace m x
  46 dbg :: Show a => String -> a -> a
  47 dbg m x = trac (m <> ": " <> show x) x
  48
  49 -- * Type 'Inh_DTC'
  50 data Inh_DTC
  51  =   Inh_DTC
  52  {   inh_dtc_para   :: DTC -> DTC
  53  ,   inh_dtc_figure :: Bool
  54  }
  55 inh_dtc :: Inh_DTC
  56 inh_dtc = Inh_DTC
  57  { inh_dtc_para   = id
  58  , inh_dtc_figure = False
  59  }
  60
  61 mimetype :: Text -> Maybe Text
  62 mimetype "sh"          = Just "text/x-shellscript"
  63 mimetype "shell"       = Just "text/x-shellscript"
  64 mimetype "shellscript" = Just "text/x-shellscript"
  65 mimetype _             = Nothing
  66
  67 dtc :: Trees Key Tokens -> DTC
  68 dtc ts = do
  69         let lang = "fr"
  70         D.xmlModel "./schema/dtc.rnc"
  71         D.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  72         D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  73         D.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  74         D.document $
  75                 case Seq.viewl ts of
  76                  TreeN KeySection{}
  77                        (Seq.viewl -> Tree0 (Write.t_Tokens -> TL.toStrict -> title) :< head)
  78                        :< body -> do
  79                         d_Trees inh_dtc (mangleHead title head)
  80                         d_Trees
  81                          inh_dtc { inh_dtc_figure = True }
  82                          body
  83                  _ ->
  84                         d_Trees
  85                          inh_dtc { inh_dtc_figure = True }
  86                          ts
  87         where
  88         mangleHead ::
  89          Text ->
  90          Trees Key Tokens ->
  91          Trees Key Tokens
  92         mangleHead title head =
  93                 let mi =
  94                         (`Seq.findIndexL` head) $ \case
  95                          TreeN (KeyColon "about" _) _ -> True
  96                          _ -> False in
  97                 case mi of
  98                  Nothing ->
  99                         TreeN (KeyColon "about" "")
 100                               (Seq.fromList names)
 101                         <| head
 102                  Just i -> Seq.adjust f i head
 103                         where
 104                         f (TreeN c about) = TreeN c $ Seq.fromList names <> about
 105                         f t = t
 106                 where
 107                 names = name <$> Text.splitOn "\n" title
 108                 name =
 109                         TreeN (KeyColon "name" "") .
 110                         Seq.singleton . Tree0 .
 111                         tokens1 . TokenPlain
 112
 113 d_Trees :: Inh_DTC -> Trees Key Tokens -> DTC
 114 d_Trees inh ts =
 115         case Seq.viewl ts of
 116          TreeN (KeyBar n _) _ :< _
 117           | (content,ts') <- gatherBar n ts -> do
 118                 D.artwork !?? (mimetype n, DA.type_ . attrValue) $
 119                         d_Trees inh{inh_dtc_para=id} content
 120                 d_Trees inh ts'
 121
 122          TreeN KeyBrackets{} _ :< _
 123           | (refs,ts') <- gatherBrackets ts, not (null refs) -> do
 124                 D.references $
 125                         forM_ refs $ d_Tree inh
 126                 d_Trees inh ts'
 127
 128          TreeN key@(KeyColon n _) cs :< ts'
 129           | (cs',ts'') <- gatherColon n ts'
 130           , not (null cs') ->
 131                 d_Trees inh $ TreeN key (cs<>cs') <| ts''
 132
 133          _ | (ul,ts') <- gatherLI (==KeyDash) ts, not (null ul) -> do
 134                 D.ul ! DA.style "format —" $
 135                         forM_ ul $ d_Tree inh
 136                 d_Trees inh ts'
 137
 138          _ | (ol,ts') <- gatherLI (\case KeyDot{} -> True; _ -> False) ts, not (null ol) -> do
 139                 D.ol $ forM_ ol $ d_Tree inh
 140                 d_Trees inh ts'
 141
 142          t:<ts' -> do
 143                 d_Tree inh t
 144                 d_Trees inh ts'
 145
 146          _ ->
 147                 return ()
 148
 149 gatherBar :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
 150 gatherBar name = first unKeyBar . spanBar
 151         where
 152         unKeyBar :: Trees Key Tokens -> Trees Key Tokens
 153         unKeyBar = (=<<) $ \case
 154                  TreeN KeyBar{} ts -> ts
 155                  _ -> mempty
 156         spanBar =
 157                 Seq.spanl $ \case
 158                  TreeN (KeyBar n _) _ | n == name -> True
 159                  _ -> False
 160
 161 gatherColon :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
 162 gatherColon name =
 163         Seq.spanl $ \case
 164          TreeN (KeyBar   n _) _ -> n == name
 165          TreeN (KeyGreat n _) _ -> n == name
 166          _ -> False
 167
 168 gatherBrackets :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
 169 gatherBrackets =
 170         Seq.spanl $ \case
 171          TreeN KeyBrackets{} _ -> True
 172          _ -> False
 173
 174 gatherLI ::
 175  (Key -> Bool) ->
 176  Trees Key Tokens ->
 177  (Trees Key Tokens, Trees Key Tokens)
 178 gatherLI liKey ts =
 179         let (lis, ts') = spanLIs ts in
 180         foldl' accumLIs (mempty,ts') lis
 181         where
 182         spanLIs = Seq.spanl $ \case
 183                  TreeN (liKey -> True) _ -> True
 184                  Tree0 (Tokens toks) ->
 185                         (`any` toks) $ \case
 186                          TokenPair (PairElem "li" _) _ -> True
 187                          _ -> False
 188                  _ -> False
 189         accumLIs acc@(oks,kos) t =
 190                 case t of
 191                  TreeN (liKey -> True) _ -> (oks|>t,kos)
 192                  Tree0 (Tokens toks) ->
 193                         let mk = Tree0 . Tokens in
 194                         let (ok,ko) =
 195                                 (`Seq.spanl` toks) $ \case
 196                                  TokenPair (PairElem "li" _) _ -> True
 197                                  TokenPlain txt -> Char.isSpace`Text.all`txt
 198                                  _ -> False in
 199                         ( if null ok then oks else oks|>mk (rmTokenPlain ok)
 200                         , if null ko then kos else mk ko<|kos )
 201                  _ -> acc
 202         rmTokenPlain =
 203                 Seq.filter $ \case
 204                  TokenPlain{} -> False
 205                  _ -> True
 206
 207 gatherName ::
 208  Trees Key Tokens ->
 209  (Name, Tokens, Attributes, Trees Key Tokens)
 210 gatherName ts = dbg "gatherName" $
 211         case Seq.viewl children of
 212          Tree0 (toList -> [TokenPlain name]) :< body ->
 213                 case Text.splitOn "\n" name of
 214                  n:[] -> (n,mempty,attrs,body)
 215                  n:ns -> (n,tokens [TokenPlain $ Text.intercalate "\n" ns],attrs,body)
 216                  []   -> (name,mempty,attrs,body)
 217          Tree0 name :< body -> ("",name,attrs,body)
 218          _ -> ("",mempty,attrs,children)
 219         where
 220         (attrs,children) = partitionAttributesChildren ts
 221
 222 d_Tree :: Inh_DTC -> Tree Key Tokens -> DTC
 223 d_Tree inh (TreeN KeySection{} ts) =
 224         let inh' = inh
 225                  { inh_dtc_para = D.para
 226                  } in
 227         case gatherName ts of
 228          ("",Tokens (null->True),attrs,body) ->
 229                 d_Attributes attrs $
 230                 D.section $ d_Trees inh' body
 231          ("",names,attrs,body) ->
 232                 d_Attributes (setAttrId (TL.toStrict $ Write.t_Tokens names) attrs) $
 233                 D.section $ do
 234                         D.name $ d_Tokens names
 235                         d_Trees inh' body
 236          (name,names,attrs,body) ->
 237                 d_Attributes (setAttrId name attrs) $
 238                 D.section ! DA.name (attrValue name) $ do
 239                         when (not $ null $ unTokens names) $
 240                                 D.name $ d_Tokens names
 241                         d_Trees inh' body
 242 d_Tree inh (TreeN key@(KeyColon typ _) ts) =
 243         if inh_dtc_figure inh
 244         then
 245                 case gatherName ts of
 246                  ("",names,attrs,body) ->
 247                         d_Attributes attrs $
 248                         D.figure ! DA.type_ (attrValue typ) $ do
 249                                 when (not $ null $ unTokens names) $
 250                                         D.name $ d_Tokens names
 251                                 d_Trees inh body
 252                  (name,names,attrs,body) ->
 253                         d_Attributes attrs $
 254                         D.figure ! DA.type_ (attrValue typ)
 255                                  ! DA.name (attrValue name) $ do
 256                                 when (not $ null $ unTokens names) $
 257                                         D.name $ d_Tokens names
 258                                 d_Trees inh body
 259         else
 260                 let (attrs,body) = partitionAttributesChildren ts in
 261                 d_Attributes attrs $
 262                 d_Key inh key body
 263 d_Tree path (TreeN key ts) = d_Key path key ts
 264 d_Tree inh (Tree0 ts) =
 265         case ts of
 266          (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens ts
 267          _ -> inh_dtc_para inh $ d_Tokens ts
 268
 269 setAttrId :: Text -> Attributes -> Attributes
 270 setAttrId = Map.insertWith (\_new old -> old) "id"
 271
 272 d_Key :: Inh_DTC -> Key -> Trees Key Tokens -> DTC
 273 d_Key inh key ts = do
 274         case key of
 275          KeyColon n _wh -> d_key n
 276          KeyGreat n _wh -> d_key n
 277          KeyEqual n _wh -> d_key n
 278          KeyBar   n _wh -> d_key n
 279          KeyDot _n -> D.li $ d_Trees inh ts
 280          KeyDash   -> D.li $ d_Trees inh ts
 281          KeyDashDash -> B.Comment (B.Text $ TL.toStrict com) ()
 282                 where
 283                 com =
 284                         Write.text Write.config_text $
 285                         mapTreeKey cell1 (\_path -> cell1) <$> ts
 286          KeyLower n as ->
 287                 D.artwork $ d_Trees inh{inh_dtc_para = id} ts
 288          KeyBrackets n ->
 289                 case gatherName ts of
 290                  ("",Tokens (null->True),attrs,body) ->
 291                         d_Attributes (setAttrId n attrs) $
 292                         D.reference $ d_Trees inh body
 293                  ("",names,attrs,body) ->
 294                         d_Attributes (setAttrId n attrs) $
 295                         D.reference $ do
 296                                 D.name $ d_Tokens names
 297                                 d_Trees inh body
 298                  (name,names,attrs,body) ->
 299                         d_Attributes (setAttrId n attrs) $
 300                         D.reference ! DA.name (attrValue name) $ do
 301                                 when (not $ null $ unTokens names) $
 302                                         D.name $ d_Tokens names
 303                                 d_Trees inh body
 304         where
 305         d_key :: Text -> DTC
 306         d_key name | null ts =
 307                 B.CustomLeaf (B.Text name) True mempty
 308         d_key name =
 309                 B.CustomParent (B.Text name) $
 310                         d_Trees inh ts
 311
 312 d_Tokens :: Tokens -> DTC
 313 d_Tokens tok = goTokens tok
 314         where
 315         -- indent = Text.replicate (columnPos pos - 1) " "
 316         go :: Token -> DTC
 317         go (TokenPlain t)  = B.toMarkup t
 318         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 319         go (TokenEscape c) = B.toMarkup c
 320         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 321         go (TokenPair PairBracket ts)
 322          | to <- Write.t_Tokens ts
 323          , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to =
 324                 D.rref ! DA.to (attrValue $ TL.toStrict to) $ mempty
 325         go (TokenPair PairStar ts)        = D.b $ goTokens ts
 326         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 327         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 328         go (TokenPair PairFrenchquote toks@(Tokens ts)) =
 329                 D.q $
 330                 case ts of
 331                  (Seq.viewl -> TokenPlain l :< ls) ->
 332                         case Seq.viewr ls of
 333                          m :> TokenPlain r ->
 334                                 goTokens $ Tokens $
 335                                         TokenPlain (Text.dropWhile Char.isSpace l)
 336                                          <|(m|>TokenPlain (Text.dropWhileEnd Char.isSpace r))
 337                          _ ->
 338                                 goTokens $ Tokens $
 339                                         TokenPlain (Text.dropAround Char.isSpace l) <| ls
 340                  (Seq.viewr -> rs :> TokenPlain r) ->
 341                         goTokens $ Tokens $
 342                                 rs |> TokenPlain (Text.dropAround Char.isSpace r)
 343                  _ -> goTokens toks
 344         go (TokenPair PairHash (toList -> [TokenPlain ts])) =
 345                 D.ref mempty ! DA.to (attrValue ts)
 346         go (TokenPair (PairElem name attrs) ts) =
 347                 d_Attrs attrs $
 348                 case ts of
 349                  Tokens s | Seq.null s ->
 350                         B.CustomLeaf (B.Text name) True mempty
 351                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 352         go (TokenPair p ts) = do
 353                 let (o,c) = pairBorders p ts
 354                 B.toMarkup o
 355                 goTokens ts
 356                 B.toMarkup c
 357         goTokens :: Tokens -> DTC
 358         goTokens (Tokens toks) =
 359                 case Seq.viewl toks of
 360                  TokenPair PairParen b :< (Seq.viewl -> TokenPair PairBracket p :< ts) -> do
 361                         case p of
 362                          Tokens (toList -> [TokenLink lnk]) ->
 363                                 D.eref ! DA.to (attrValue lnk) $ goTokens b
 364                          _ -> D.rref ! DA.to (attrValue $ TL.toStrict $ Write.t_Tokens p) $ goTokens b
 365                         goTokens (Tokens ts)
 366                  t :< ts -> go t <> goTokens (Tokens ts)
 367                  Seq.EmptyL -> mempty
 368
 369 d_Attrs :: Attrs -> DTC -> DTC
 370 d_Attrs = flip $ foldl' d_Attr
 371
 372 d_Attr :: DTC -> (Text,Attr) -> DTC
 373 d_Attr acc (_,Attr{..}) =
 374         B.AddCustomAttribute
 375          (B.Text attr_name)
 376          (B.Text attr_value)
 377          acc
 378
 379 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 380 -- attr_id title = ("id",title)
 381
 382 -- * Type 'Attributes'
 383 type Attributes = Map Name Text
 384
 385 d_Attributes :: Attributes -> DTC -> DTC
 386 d_Attributes = flip $ Map.foldrWithKey $ \n v ->
 387         B.AddCustomAttribute (B.Text n) (B.Text v)
 388
 389 partitionAttributesChildren ::
 390  Trees Key Tokens ->
 391  (Attributes, Trees Key Tokens)
 392 partitionAttributesChildren ts = (attrs,children)
 393         where
 394         attrs :: Attributes
 395         attrs =
 396                 foldr (\t acc ->
 397                         case t of
 398                          Tree0{} -> acc
 399                          TreeN (KeyEqual n _wh) a -> Map.insert n v acc
 400                                 where
 401                                 v = TL.toStrict $
 402                                         Write.text Write.config_text{Write.config_text_escape = False} $
 403                                         mapTreeKey cell1 (\_path -> cell1) <$> a
 404                                         -- Write.treeRackUpLeft <$> a
 405                          TreeN{} -> acc
 406                  ) mempty ts
 407         children = Seq.filter (\t ->
 408                 case t of
 409                  Tree0{} -> True
 410                  TreeN KeyEqual{} _cs -> False
 411                  TreeN{} -> True
 412                  ) ts