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.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.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) v ->
  85                                 (n,TL.toStrict $ Write.text $ Write.treeRackUpLeft <$> v):acc
  86                          TreeN{} -> acc
  87                  ) [] ts
  88         children = Seq.filter (\t ->
  89                 case t of
  90                  Tree0{} -> True
  91                  TreeN (unCell -> KeyEqual{}) _cs -> False
  92                  TreeN{} -> True
  93                  ) ts
  94 d_TreeCell path (TreeN cell ts) = d_CellKey path cell ts
  95
  96 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> DTC
  97 d_CellKey path (Cell _pos _posEnd key) cells = do
  98         case key of
  99          KeyColon n _wh -> d_Key n
 100          KeyGreat n _wh -> d_Key n
 101          KeyEqual n _wh -> d_Key n
 102          KeyBar   n _wh -> d_Key n
 103          KeyDash -> do
 104                 B.toMarkup ("- "::Text)
 105                 forM_ cells $ d_TreeCell (key:path)
 106          {-
 107          KeyLower name attrs -> do
 108                 B.Content $ "<"<>B.toMarkup name
 109                 d_Attrs attrs
 110                 forM_ cells $ d_TreeCell path
 111          -}
 112         where
 113         d_Key :: Text -> DTC
 114         d_Key name = do
 115                 B.CustomParent (B.Text name) $
 116                         forM_ cells $ d_TreeCell (key:path)
 117
 118 d_CellToken :: [Key] -> Cell Token -> DTC
 119 d_CellToken path (Cell _pos _posEnd tok) =
 120         -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
 121         case dbg "d_CellToken: path" path of
 122          KeySection{}:_ ->
 123                 case tok of
 124                  TokenPair PairElem{} _t -> d_Token path tok
 125                  _ -> D.para $ d_Token path tok
 126          _ -> d_Token path tok
 127
 128 d_Token :: [Key] -> Token -> DTC
 129 d_Token path tok = go tok
 130         where
 131         -- indent = Text.replicate (columnPos pos - 1) " "
 132         go :: Token -> DTC
 133         go (TokenPlain txt) = B.toMarkup txt
 134         go (TokenTag v) = D.ref mempty ! DA.to (attrValue v)
 135         go (TokenEscape c) = B.toMarkup c
 136         go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
 137         go (TokenPair PairSlash t) = D.i $ go t
 138         go (TokenPair PairBackquote t) = D.code $ go t
 139         go (TokenPair PairFrenchquote t) = D.q $ go t
 140         go (TokenPair PairHash (TokenPlain t)) =
 141                 D.ref mempty ! DA.to (attrValue t)
 142         go (TokenPair (PairElem name attrs) t) =
 143                 d_Attrs attrs $
 144                 case t of
 145                  Tokens ts | Seq.null ts ->
 146                         B.CustomLeaf (B.Text name) True mempty
 147                  _ -> B.CustomParent (B.Text name) $ go t
 148         go (TokenPair p t) = do
 149                 let (o,c) = pairBorders p t
 150                 B.toMarkup o
 151                 go t
 152                 B.toMarkup c
 153         go (Tokens ts) = foldMap go ts
 154
 155 d_Attrs :: Attrs -> DTC -> DTC
 156 d_Attrs = flip $ foldl' d_Attr
 157
 158 d_Attr :: DTC -> (Text,Attr) -> DTC
 159 d_Attr acc (_,Attr{..}) =
 160         B.AddCustomAttribute
 161          (B.Text attr_name)
 162          (B.Text attr_value)
 163          acc