{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Render a TCT file in DTC. module Language.TCT.Write.DTC where import Control.Monad (Monad(..), forM_, when) import Data.Bool import Data.Foldable (foldr, null, foldMap, foldl', any) import Data.Function (($), (.), flip) import Data.Functor ((<$>)) import Data.Map.Strict (Map) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..), (<|), (|>)) import Data.String (String) import Data.Text (Text) import GHC.Exts (toList) import Text.Blaze ((!)) import Text.Show (Show(..)) import qualified Data.Char as Char import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Text.Blaze as B import qualified Text.Blaze.Internal as B import Language.TCT.Tree import Language.TCT.Token import Language.TCT.Elem hiding (trac,dbg) import qualified Language.TCT.Write.Text as Write import Text.Blaze.Utils import Text.Blaze.DTC (DTC) import qualified Text.Blaze.DTC as D import qualified Text.Blaze.DTC.Attributes as DA import Debug.Trace (trace) trac :: String -> a -> a -- trac _m x = x trac m x = trace m x dbg :: Show a => String -> a -> a dbg m x = trac (m <> ": " <> show x) x dtc :: Trees Key Tokens -> DTC dtc ts = do let lang = "fr" D.xmlModel "./schema/dtc.rnc" D.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl" D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl" D.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl" D.document $ case Seq.viewl ts of TreeN KeySection{} (Seq.viewl -> Tree0 (Write.t_Tokens -> TL.toStrict -> title) :< head) :< body -> do d_Trees [] (mangleHead title head) d_Trees [] body _ -> d_Trees [] ts where mangleHead :: Text -> Trees Key Tokens -> Trees Key Tokens mangleHead title head = let mi = (`Seq.findIndexL` head) $ \case TreeN (KeyColon "about" _) _ -> True _ -> False in case mi of Nothing -> TreeN (KeyColon "about" "") (Seq.fromList names) <| head Just i -> Seq.adjust f i head where f (TreeN c about) = TreeN c $ Seq.fromList names <> about f t = t where names = name <$> Text.splitOn "\n" title name = TreeN (KeyColon "name" "") . Seq.singleton . Tree0 . Tokens . Seq.singleton . TokenPlain d_Trees :: [Key] -> Trees Key Tokens -> DTC d_Trees path ts = case () of _ | (ul,ts') <- gatherUL ts, not (null ul) -> do D.ul $ forM_ ul $ d_Tree path d_Trees path ts' _ | (ol,ts') <- gatherOL ts, not (null ol) -> do D.ol $ forM_ ol $ d_Tree path d_Trees path ts' _ | t: do d_Tree path t d_Trees path ts' _ -> return () gatherUL :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens) gatherUL ts = let (lis, ts') = spanLIs ts in foldl' accumLIs (mempty,ts') lis where spanLIs = Seq.spanl $ \case TreeN KeyDash _ -> True Tree0 (Tokens toks) -> (`any` toks) $ \case TokenPair (PairElem "li" _) _ -> True _ -> False _ -> False accumLIs acc@(oks,kos) t = case t of TreeN KeyDash _ -> (oks|>t,kos) Tree0 (Tokens toks) -> let mk = Tree0 . Tokens in let (ok,ko) = (`Seq.spanl` toks) $ \case TokenPair (PairElem "li" _) _ -> True TokenPlain txt -> Char.isSpace`Text.all`txt _ -> False in ( if null ok then oks else oks|>mk (rmTokenPlain ok) , if null ko then kos else mk ko<|kos ) _ -> acc rmTokenPlain = Seq.filter $ \case TokenPlain{} -> False _ -> True gatherOL :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens) gatherOL ts = let (lis, ts') = spanLIs ts in foldl' accumLIs (mempty,ts') lis where spanLIs = Seq.spanl $ \case TreeN KeyDot{} _ -> True Tree0 (Tokens toks) -> (`any` toks) $ \case TokenPair (PairElem "li" _) _ -> True _ -> False _ -> False accumLIs acc@(oks,kos) t = case t of TreeN KeyDot{} _ -> (oks|>t,kos) Tree0 (Tokens toks) -> let mk = Tree0 . Tokens in let (ok,ko) = (`Seq.spanl` toks) $ \case TokenPair (PairElem "li" _) _ -> True TokenPlain txt -> Char.isSpace`Text.all`txt _ -> False in ( if null ok then oks else oks|>mk (rmTokenPlain ok) , if null ko then kos else mk ko<|kos ) _ -> acc rmTokenPlain = Seq.filter $ \case TokenPlain{} -> False _ -> True d_Tree :: [Key] -> Tree Key Tokens -> DTC d_Tree path (TreeN key@KeySection{} ts) = case Seq.viewl children of Tree0 (toList -> [TokenPlain title]) :< body -> d_attrs (mangleAttrs title attrs) $ case Text.splitOn "\n" title of t0:t1 -> D.section ! DA.name (attrValue t0) $ do let st = Text.intercalate "\n" t1 when (not (Text.null st)) $ D.name $ B.toMarkup st d_content body [] -> D.section ! DA.name (attrValue title) $ d_content body Tree0 title :< body -> d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $ D.section $ do D.name $ d_Tokens (key:path) title d_content body _ -> d_attrs attrs $ D.section $ d_content children where (attrs,children) = partitionAttributesChildren ts d_content cs = d_Trees (key:path) cs mangleAttrs :: Text -> Attributes -> Attributes mangleAttrs title = Map.insertWith (\_new old -> old) "id" title d_Tree path (Tree0 ts) = case path of [] -> case ts of (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts _ -> D.para $ d_Tokens path ts KeySection{}:_ -> case ts of (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts _ -> D.para $ d_Tokens path ts _ -> d_Tokens path ts d_Tree path (TreeN cell@KeyColon{} ts) = let (attrs,children) = partitionAttributesChildren ts in d_attrs attrs $ d_Key path cell children d_Tree path (TreeN cell ts) = d_Key path cell ts d_Key :: [Key] -> Key -> Trees Key Tokens -> DTC d_Key path key cells = do case key of KeyColon n _wh -> d_key n KeyGreat n _wh -> d_key n KeyEqual n _wh -> d_key n KeyBar n _wh -> d_key n KeyDot _n -> D.li $ d_Trees (key:path) cells KeyDash -> D.li $ d_Trees (key:path) cells {- KeyLower name attrs -> do B.Content $ "<"<>B.toMarkup name d_Attrs attrs forM_ cells $ d_Tree path -} where d_key :: Text -> DTC d_key name | null cells = B.CustomLeaf (B.Text name) True mempty d_key name = B.CustomParent (B.Text name) $ d_Trees (key:path) cells d_Tokens :: [Key] -> Tokens -> DTC d_Tokens _path tok = goTokens tok where -- indent = Text.replicate (columnPos pos - 1) " " go :: Token -> DTC go (TokenPlain t) = B.toMarkup t go (TokenTag t) = D.ref mempty ! DA.to (attrValue t) go (TokenEscape c) = B.toMarkup c go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk) go (TokenPair PairSlash ts) = D.i $ goTokens ts go (TokenPair PairBackquote ts) = D.code $ goTokens ts go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts go (TokenPair PairHash (toList -> [TokenPlain ts])) = D.ref mempty ! DA.to (attrValue ts) go (TokenPair (PairElem name attrs) ts) = d_Attrs attrs $ case ts of Tokens s | Seq.null s -> B.CustomLeaf (B.Text name) True mempty _ -> B.CustomParent (B.Text name) $ goTokens ts go (TokenPair p ts) = do let (o,c) = pairBorders p ts B.toMarkup o goTokens ts B.toMarkup c goTokens :: Tokens -> DTC goTokens (Tokens ts) = foldMap go ts d_Attrs :: Attrs -> DTC -> DTC d_Attrs = flip $ foldl' d_Attr d_Attr :: DTC -> (Text,Attr) -> DTC d_Attr acc (_,Attr{..}) = B.AddCustomAttribute (B.Text attr_name) (B.Text attr_value) acc -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)] -- attr_id title = ("id",title) -- * Type 'Attributes' type Attributes = Map Name Text d_attrs :: Attributes -> DTC -> DTC d_attrs = flip $ Map.foldrWithKey $ \n v -> B.AddCustomAttribute (B.Text n) (B.Text v) partitionAttributesChildren :: Trees Key Tokens -> (Attributes, Trees Key Tokens) partitionAttributesChildren ts = (attrs,children) where attrs :: Attributes attrs = foldr (\t acc -> case t of Tree0{} -> acc TreeN (KeyEqual n _wh) a -> Map.insert n v acc where v = TL.toStrict $ Write.text Write.config_text{Write.config_text_escape = False} $ mapTreeKey cell1 (\_path -> cell1) <$> a -- Write.treeRackUpLeft <$> a TreeN{} -> acc ) mempty ts children = Seq.filter (\t -> case t of Tree0{} -> True TreeN KeyEqual{} _cs -> False TreeN{} -> True ) ts