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