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.Monad (Monad(..), forM_, mapM)
  10 import Data.Bool
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.), flip)
  14 import Data.Functor ((<$>))
  15 import Data.Int (Int)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence (ViewL(..))
  21 import Data.String (String, IsString(..))
  22 import Data.Text (Text)
  23 import Prelude (Num(..), undefined)
  24 import Text.Blaze ((!))
  25 import Text.Blaze.Html (Html)
  26 import Text.Show (Show(..))
  27 import qualified Control.Monad.Trans.State as S
  28 import qualified Data.List as L
  29 import qualified Data.Sequence as Seq
  30 import qualified Data.Text as Text
  31 import qualified Text.Blaze as B
  32 import qualified Text.Blaze.Internal as B
  33 import qualified Data.Text.Lazy as TL
  34
  35 import Language.TCT.Tree
  36 import Language.TCT.Token
  37 import Language.TCT.Elem hiding (trac,dbg)
  38 import qualified Language.TCT.Write.Text as Write
  39 import Text.Blaze.Utils
  40 import Text.Blaze.DTC (DTC)
  41 import qualified Text.Blaze.DTC as D
  42 import qualified Text.Blaze.DTC.Attributes as DA
  43
  44 import Debug.Trace (trace)
  45 trac :: String -> a -> a
  46 -- trac _m x = x
  47 trac m x = trace m x
  48 dbg :: Show a => String -> a -> a
  49 dbg m x = trac (m <> ": " <> show x) x
  50
  51 dtc :: Trees (Cell Key) (Cell Token) -> DTC
  52 dtc tct = do
  53         D.xmlModel        "./schema/dtc.rnc"
  54         D.xmlStylesheet   "./xsl/document.html5.xsl"
  55         D.html5Stylesheet "./xsl/document.html5.xsl"
  56         D.atomStylesheet  "./xsl/document.atom.xsl"
  57         D.document $
  58                 forM_ tct $ d_TreeCell []
  59
  60 d_TreeCell :: [Key] -> Tree (Cell Key) (Cell Token) -> DTC
  61 d_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
  62         case Seq.viewl ts of
  63          Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
  64                 D.section ! DA.name (attrValue title) $
  65                         d_content
  66          Tree0 (Cell _posTitle _ title) :< _ ->
  67                 D.section $ do
  68                         D.name $ d_Token (key:path) title
  69                         d_content
  70          _ -> D.section d_content
  71         where
  72         d_content = forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ d_TreeCell (key:path)
  73 d_TreeCell path (Tree0 cell) = d_CellToken path cell
  74 d_TreeCell path (TreeN cell@(unCell -> KeyColon{}) ts) =
  75         foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v))
  76          (d_CellKey path cell children)
  77          attrs
  78         where
  79         attrs :: [(Name,Text)]
  80         attrs =
  81                 foldr (\t acc ->
  82                         case t of
  83                          Tree0{} -> acc
  84                          TreeN (unCell -> KeyEqual n _wh) a -> (n,v):acc
  85                                 where
  86                                 v = TL.toStrict $
  87                                         Write.text Write.config_text{Write.config_text_escape = False} $
  88                                         Write.treeRackUpLeft <$> a
  89                          TreeN{} -> acc
  90                  ) [] ts
  91         children = Seq.filter (\t ->
  92                 case t of
  93                  Tree0{} -> True
  94                  TreeN (unCell -> KeyEqual{}) _cs -> False
  95                  TreeN{} -> True
  96                  ) ts
  97 d_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
  98
  99 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> DTC
 100 d_CellKey path (Cell _pos _posEnd key) cells = do
 101         case key of
 102          KeyColon n _wh -> d_Key n
 103          KeyGreat n _wh -> d_Key n
 104          KeyEqual n _wh -> d_Key n
 105          KeyBar   n _wh -> d_Key n
 106          KeyDash -> do
 107                 B.toMarkup ("- "::Text)
 108                 forM_ cells $ d_TreeCell (key:path)
 109          {-
 110          KeyLower name attrs -> do
 111                 B.Content $ "<"<>B.toMarkup name
 112                 d_Attrs attrs
 113                 forM_ cells $ d_TreeCell path
 114          -}
 115         where
 116         d_Key :: Text -> DTC
 117         d_Key name | null cells =
 118                 B.CustomLeaf (B.Text name) True mempty
 119         d_Key name =
 120                 B.CustomParent (B.Text name) $
 121                         forM_ cells $ d_TreeCell (key:path)
 122
 123 d_CellToken :: [Key] -> Cell Token -> DTC
 124 d_CellToken path (Cell _pos _posEnd tok) =
 125         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
 126         case dbg "d_CellToken: path" path of
 127          KeySection{}:_ ->
 128                 case tok of
 129                  TokenPair PairElem{} _t -> d_Token path tok
 130                  _ -> D.para $ d_Token path tok
 131          _ -> d_Token path tok
 132
 133 d_Token :: [Key] -> Token -> DTC
 134 d_Token path tok = go tok
 135         where
 136         -- indent = Text.replicate (columnPos pos - 1) " "
 137         go :: Token -> DTC
 138         go (TokenPlain txt) = B.toMarkup txt
 139         go (TokenTag v) = D.ref mempty ! DA.to (attrValue v)
 140         go (TokenEscape c) = B.toMarkup c
 141         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 142         go (TokenPair PairSlash t) = D.i $ go t
 143         go (TokenPair PairBackquote t) = D.code $ go t
 144         go (TokenPair PairFrenchquote t) = D.q $ go t
 145         go (TokenPair PairHash (TokenPlain t)) =
 146                 D.ref mempty ! DA.to (attrValue t)
 147         go (TokenPair (PairElem name attrs) t) =
 148                 d_Attrs attrs $
 149                 case t of
 150                  Tokens ts | Seq.null ts ->
 151                         B.CustomLeaf (B.Text name) True mempty
 152                  _ -> B.CustomParent (B.Text name) $ go t
 153         go (TokenPair p t) = do
 154                 let (o,c) = pairBorders p t
 155                 B.toMarkup o
 156                 go t
 157                 B.toMarkup c
 158         go (Tokens ts) = foldMap go ts
 159
 160 d_Attrs :: Attrs -> DTC -> DTC
 161 d_Attrs = flip $ foldl' d_Attr
 162
 163 d_Attr :: DTC -> (Text,Attr) -> DTC
 164 d_Attr acc (_,Attr{..}) =
 165         B.AddCustomAttribute
 166          (B.Text attr_name)
 167          (B.Text attr_value)
 168          acc