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 {-
 175 gatherColon :: Trees Key Tokens -> Maybe (Name, Tokens, Trees Key Tokens, Trees Key Tokens)
 176 gatherColon ts =
 177         case Seq.viewl ts of
 178          TreeN (KeyColon name _) (toList -> [Tree0 head]) :< (spanBar name -> (body,ts')) ->
 179                 Just (name,head,body,ts')
 180          _ -> Nothing
 181         where
 182         spanBar name =
 183                 Seq.spanl $ \case
 184                  TreeN (KeyBar n _) _ | n == name -> True
 185                  _ -> False
 186 -}
 187
 188 gatherLI ::
 189  (Key -> Bool) ->
 190  Trees Key Tokens ->
 191  (Trees Key Tokens, Trees Key Tokens)
 192 gatherLI liKey ts =
 193         let (lis, ts') = spanLIs ts in
 194         foldl' accumLIs (mempty,ts') lis
 195         where
 196         spanLIs = Seq.spanl $ \case
 197                  TreeN (liKey -> True) _ -> True
 198                  Tree0 (Tokens toks) ->
 199                         (`any` toks) $ \case
 200                          TokenPair (PairElem "li" _) _ -> True
 201                          _ -> False
 202                  _ -> False
 203         accumLIs acc@(oks,kos) t =
 204                 case t of
 205                  TreeN (liKey -> True) _ -> (oks|>t,kos)
 206                  Tree0 (Tokens toks) ->
 207                         let mk = Tree0 . Tokens in
 208                         let (ok,ko) =
 209                                 (`Seq.spanl` toks) $ \case
 210                                  TokenPair (PairElem "li" _) _ -> True
 211                                  TokenPlain txt -> Char.isSpace`Text.all`txt
 212                                  _ -> False in
 213                         ( if null ok then oks else oks|>mk (rmTokenPlain ok)
 214                         , if null ko then kos else mk ko<|kos )
 215                  _ -> acc
 216         rmTokenPlain =
 217                 Seq.filter $ \case
 218                  TokenPlain{} -> False
 219                  _ -> True
 220
 221 gatherName ::
 222  Trees Key Tokens ->
 223  (Name, Tokens, Attributes, Trees Key Tokens)
 224 gatherName ts = dbg "gatherName" $
 225         case Seq.viewl children of
 226          Tree0 (toList -> [TokenPlain name]) :< body ->
 227                 case Text.splitOn "\n" name of
 228                  n:[] -> (n,mempty,attrs,body)
 229                  n:ns -> (n,tokens [TokenPlain $ Text.intercalate "\n" ns],attrs,body)
 230                  []   -> (name,mempty,attrs,body)
 231          Tree0 name :< body -> ("",name,attrs,body)
 232          _ -> ("",mempty,attrs,children)
 233         where
 234         (attrs,children) = partitionAttributesChildren ts
 235
 236 d_Tree :: Inh_DTC -> Tree Key Tokens -> DTC
 237 d_Tree inh (TreeN KeySection{} ts) =
 238         let inh' = inh
 239                  { inh_dtc_para = D.para
 240                  } in
 241         case gatherName ts of
 242          ("",Tokens (null->True),attrs,body) ->
 243                 d_Attributes attrs $
 244                 D.section $ d_Trees inh' body
 245          ("",names,attrs,body) ->
 246                 d_Attributes (setAttrId (TL.toStrict $ Write.t_Tokens names) attrs) $
 247                 D.section $ do
 248                         D.name $ d_Tokens names
 249                         d_Trees inh' body
 250          (name,names,attrs,body) ->
 251                 d_Attributes (setAttrId name attrs) $
 252                 D.section ! DA.name (attrValue name) $ do
 253                         when (not $ null $ unTokens names) $
 254                                 D.name $ d_Tokens names
 255                         d_Trees inh' body
 256 d_Tree inh (TreeN key@(KeyColon typ _) ts) =
 257         if inh_dtc_figure inh
 258         then
 259                 case gatherName ts of
 260                  ("",names,attrs,body) ->
 261                         d_Attributes attrs $
 262                         D.figure ! DA.type_ (attrValue typ) $ do
 263                                 when (not $ null $ unTokens names) $
 264                                         D.name $ d_Tokens names
 265                                 d_Trees inh body
 266                  (name,names,attrs,body) ->
 267                         d_Attributes attrs $
 268                         D.figure ! DA.type_ (attrValue typ)
 269                                  ! DA.name (attrValue name) $ do
 270                                 when (not $ null $ unTokens names) $
 271                                         D.name $ d_Tokens names
 272                                 d_Trees inh body
 273         else
 274                 let (attrs,body) = partitionAttributesChildren ts in
 275                 d_Attributes attrs $
 276                 d_Key inh key body
 277 d_Tree path (TreeN key ts) = d_Key path key ts
 278 d_Tree inh (Tree0 ts) =
 279         case ts of
 280          (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens ts
 281          _ -> inh_dtc_para inh $ d_Tokens ts
 282
 283 setAttrId :: Text -> Attributes -> Attributes
 284 setAttrId = Map.insertWith (\_new old -> old) "id"
 285
 286 d_Key :: Inh_DTC -> Key -> Trees Key Tokens -> DTC
 287 d_Key inh key ts = do
 288         case key of
 289          KeyColon n _wh -> d_key n
 290          KeyGreat n _wh -> d_key n
 291          KeyEqual n _wh -> d_key n
 292          KeyBar   n _wh -> d_key n
 293          KeyDot _n -> D.li $ d_Trees inh ts
 294          KeyDash   -> D.li $ d_Trees inh ts
 295          KeyDashDash -> B.Comment (B.Text $ TL.toStrict com) ()
 296                 where
 297                 com =
 298                         Write.text Write.config_text $
 299                         mapTreeKey cell1 (\_path -> cell1) <$> ts
 300          KeyLower n as ->
 301                 D.artwork $ d_Trees inh{inh_dtc_para = id} ts
 302          KeyBrackets n ->
 303                 case gatherName ts of
 304                  ("",Tokens (null->True),attrs,body) ->
 305                         d_Attributes (setAttrId n attrs) $
 306                         D.reference $ d_Trees inh body
 307                  ("",names,attrs,body) ->
 308                         d_Attributes (setAttrId n attrs) $
 309                         D.reference $ do
 310                                 D.name $ d_Tokens names
 311                                 d_Trees inh body
 312                  (name,names,attrs,body) ->
 313                         d_Attributes (setAttrId n attrs) $
 314                         D.reference ! DA.name (attrValue name) $ do
 315                                 when (not $ null $ unTokens names) $
 316                                         D.name $ d_Tokens names
 317                                 d_Trees inh body
 318         where
 319         d_key :: Text -> DTC
 320         d_key name | null ts =
 321                 B.CustomLeaf (B.Text name) True mempty
 322         d_key name =
 323                 B.CustomParent (B.Text name) $
 324                         d_Trees inh ts
 325
 326 d_Tokens :: Tokens -> DTC
 327 d_Tokens tok = goTokens tok
 328         where
 329         -- indent = Text.replicate (columnPos pos - 1) " "
 330         go :: Token -> DTC
 331         go (TokenPlain t)  = B.toMarkup t
 332         go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
 333         go (TokenEscape c) = B.toMarkup c
 334         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 335         go (TokenPair PairBracket ts)
 336          | to <- Write.t_Tokens ts
 337          , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to =
 338                 D.rref ! DA.to (attrValue $ TL.toStrict to) $ mempty
 339         go (TokenPair PairStar ts)        = D.b $ goTokens ts
 340         go (TokenPair PairSlash ts)       = D.i $ goTokens ts
 341         go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
 342         go (TokenPair PairFrenchquote toks@(Tokens ts)) =
 343                 D.q $
 344                 case ts of
 345                  (Seq.viewl -> TokenPlain l :< ls) ->
 346                         case Seq.viewr ls of
 347                          m :> TokenPlain r ->
 348                                 goTokens $ Tokens $
 349                                         TokenPlain (Text.dropWhile Char.isSpace l)
 350                                          <|(m|>TokenPlain (Text.dropWhileEnd Char.isSpace r))
 351                          _ ->
 352                                 goTokens $ Tokens $
 353                                         TokenPlain (Text.dropAround Char.isSpace l) <| ls
 354                  (Seq.viewr -> rs :> TokenPlain r) ->
 355                         goTokens $ Tokens $
 356                                 rs |> TokenPlain (Text.dropAround Char.isSpace r)
 357                  _ -> goTokens toks
 358         go (TokenPair PairHash (toList -> [TokenPlain ts])) =
 359                 D.ref mempty ! DA.to (attrValue ts)
 360         go (TokenPair (PairElem name attrs) ts) =
 361                 d_Attrs attrs $
 362                 case ts of
 363                  Tokens s | Seq.null s ->
 364                         B.CustomLeaf (B.Text name) True mempty
 365                  _ -> B.CustomParent (B.Text name) $ goTokens ts
 366         go (TokenPair p ts) = do
 367                 let (o,c) = pairBorders p ts
 368                 B.toMarkup o
 369                 goTokens ts
 370                 B.toMarkup c
 371         goTokens :: Tokens -> DTC
 372         goTokens (Tokens toks) =
 373                 case Seq.viewl toks of
 374                  TokenPair PairParen b :< (Seq.viewl -> TokenPair PairBracket p :< ts) -> do
 375                         case p of
 376                          Tokens (toList -> [TokenLink lnk]) ->
 377                                 D.eref ! DA.to (attrValue lnk) $ goTokens b
 378                          _ -> D.rref ! DA.to (attrValue $ TL.toStrict $ Write.t_Tokens p) $ goTokens b
 379                         goTokens (Tokens ts)
 380                  t :< ts -> go t <> goTokens (Tokens ts)
 381                  Seq.EmptyL -> mempty
 382
 383 d_Attrs :: Attrs -> DTC -> DTC
 384 d_Attrs = flip $ foldl' d_Attr
 385
 386 d_Attr :: DTC -> (Text,Attr) -> DTC
 387 d_Attr acc (_,Attr{..}) =
 388         B.AddCustomAttribute
 389          (B.Text attr_name)
 390          (B.Text attr_value)
 391          acc
 392
 393 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
 394 -- attr_id title = ("id",title)
 395
 396 -- * Type 'Attributes'
 397 type Attributes = Map Name Text
 398
 399 d_Attributes :: Attributes -> DTC -> DTC
 400 d_Attributes = flip $ Map.foldrWithKey $ \n v ->
 401         B.AddCustomAttribute (B.Text n) (B.Text v)
 402
 403 partitionAttributesChildren ::
 404  Trees Key Tokens ->
 405  (Attributes, Trees Key Tokens)
 406 partitionAttributesChildren ts = (attrs,children)
 407         where
 408         attrs :: Attributes
 409         attrs =
 410                 foldr (\t acc ->
 411                         case t of
 412                          Tree0{} -> acc
 413                          TreeN (KeyEqual n _wh) a -> Map.insert n v acc
 414                                 where
 415                                 v = TL.toStrict $
 416                                         Write.text Write.config_text{Write.config_text_escape = False} $
 417                                         mapTreeKey cell1 (\_path -> cell1) <$> a
 418                                         -- Write.treeRackUpLeft <$> a
 419                          TreeN{} -> acc
 420                  ) mempty ts
 421         children = Seq.filter (\t ->
 422                 case t of
 423                  Tree0{} -> True
 424                  TreeN KeyEqual{} _cs -> False
 425                  TreeN{} -> True
 426                  ) ts