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