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