Language/TCT/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.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.Int (Int)
  15 import Data.Maybe (Maybe(..))
  16 import Data.Monoid (Monoid(..))
  17 import Data.Ord (Ord(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Sequence (ViewL(..))
  20 import Data.String (String, IsString(..))
  21 import Data.Text (Text)
  22 import Prelude (Num(..), undefined)
  23 import Text.Blaze ((!))
  24 import Text.Blaze.Html (Html)
  25 import Text.Show (Show(..))
  26 import qualified Control.Monad.Trans.State as S
  27 import qualified Data.List as L
  28 import qualified Data.Sequence as Seq
  29 import qualified Data.Text as Text
  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 Text.Blaze.Utils
  37 import Text.Blaze.DTC (DTC)
  38 import qualified Text.Blaze.DTC as D
  39 import qualified Text.Blaze.DTC.Attributes as DA
  40
  41 import Debug.Trace (trace)
  42 trac :: String -> a -> a
  43 -- trac _m x = x
  44 trac m x = trace m x
  45 dbg :: Show a => String -> a -> a
  46 dbg m x = trac (m <> ": " <> show x) x
  47
  48 dtc :: Trees (Cell Key) (Cell Token) -> DTC
  49 dtc tct = do
  50         D.xmlModel        "./schema/dtc.rnc"
  51         D.xmlStylesheet   "./xsl/document.html5.xsl"
  52         D.html5Stylesheet "./xsl/document.html5.xsl"
  53         D.atomStylesheet  "./xsl/document.atom.xsl"
  54         D.document $
  55                 forM_ tct $ d_TreeCell []
  56
  57 d_TreeCell :: [Key] -> Tree (Cell Key) (Cell Token) -> DTC
  58 d_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
  59         case Seq.viewl ts of
  60          Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
  61                 D.section ! DA.name (attrValue title) $
  62                         d_content
  63          Tree0 (Cell _posTitle _ title) :< _ ->
  64                 D.section $ do
  65                         D.name $ d_Token (key:path) title
  66                         d_content
  67          _ -> D.section d_content
  68         where
  69         d_content = forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ d_TreeCell (key:path)
  70 d_TreeCell path (Tree0 cell) = d_CellToken path cell
  71 d_TreeCell path (TreeN cell cs) = d_CellKey path cell cs
  72
  73 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> DTC
  74 d_CellKey path (Cell _pos _posEnd key) cells = do
  75         case key of
  76          KeyColon n _wh -> d_Key n
  77          KeyGreat n _wh -> d_Key n
  78          KeyEqual n _wh -> d_Key n
  79          KeyBar   n _wh -> d_Key n
  80          KeyDash -> do
  81                 B.toMarkup ("- "::Text)
  82                 forM_ cells $ d_TreeCell (key:path)
  83          {-
  84          KeyLower name attrs -> do
  85                 B.Content $ "<"<>B.toMarkup name
  86                 d_Attrs attrs
  87                 forM_ cells $ d_TreeCell path
  88          -}
  89         where
  90         d_Key :: Text -> DTC
  91         d_Key name = do
  92                 B.CustomParent (B.Text name) $
  93                         forM_ cells $ d_TreeCell (key:path)
  94
  95 d_CellToken :: [Key] -> Cell Token -> DTC
  96 d_CellToken path (Cell _pos _posEnd tok) =
  97         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
  98         case dbg "d_CellToken: path" path of
  99          KeySection{}:_ ->
 100                 case tok of
 101                  TokenGroup GroupElem{} _t -> d_Token path tok
 102                  _ -> D.para $ d_Token path tok
 103          _ -> d_Token path tok
 104
 105 d_Token :: [Key] -> Token -> DTC
 106 d_Token path tok = go tok
 107         where
 108         -- indent = Text.replicate (columnPos pos - 1) " "
 109         go :: Token -> DTC
 110         go (TokenPlain txt) = B.toMarkup txt
 111         go (TokenTag v) = D.ref mempty ! DA.to (attrValue v)
 112         go (TokenEscape c) = B.toMarkup c
 113         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 114         go (TokenGroup GroupSlash t) = D.i $ go t
 115         go (TokenGroup GroupBackquote t) = D.code $ go t
 116         go (TokenGroup GroupFrenchquote t) = D.q $ go t
 117         go (TokenGroup GroupHash (TokenPlain t)) =
 118                 D.ref mempty ! DA.to (attrValue t)
 119         go (TokenGroup (GroupElem name attrs) t) =
 120                 d_Attrs attrs $
 121                 case t of
 122                  Tokens ts | Seq.null ts ->
 123                         B.CustomLeaf (B.Text name) True mempty
 124                  _ -> B.CustomParent (B.Text name) $ go t
 125         go (TokenGroup grp t) = do
 126                 let (o,c) = groupBorders grp t
 127                 B.toMarkup o
 128                 go t
 129                 B.toMarkup c
 130         go (Tokens ts) = foldMap go ts
 131
 132 d_Attrs :: Attrs -> DTC -> DTC
 133 d_Attrs = flip $ foldl' d_Attr
 134
 135 d_Attr :: DTC -> (Text,Attr) -> DTC
 136 d_Attr acc (_,Attr{..}) =
 137         B.AddCustomAttribute
 138          (B.Text attr_name)
 139          (B.Text attr_value)
 140          acc