-- | Render a TCT file in DTC.
module Language.TCT.Write.DTC where
-import Control.Monad (Monad(..), forM_, when)
+import Control.Arrow (first)
+import Control.Monad (Monad(..), (=<<), forM_, when)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (foldr, null, foldMap, foldl', any)
-import Data.Function (($), (.), flip)
-import Data.Functor ((<$>))
+import Data.Function (($), (.), flip, id)
+import Data.Functor (Functor(..), (<$>))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Debug.Trace (trace)
trac :: String -> a -> a
--- trac _m x = x
-trac m x = trace m x
+trac _m x = x
+-- trac m x = trace m x
dbg :: Show a => String -> a -> a
dbg m x = trac (m <> ": " <> show x) x
+-- * Type 'Inh_DTC'
+data Inh_DTC
+ = Inh_DTC
+ { inh_dtc_para :: DTC -> DTC
+ , inh_dtc_figure :: Bool
+ }
+inh_dtc :: Inh_DTC
+inh_dtc = Inh_DTC
+ { inh_dtc_para = id
+ , inh_dtc_figure = False
+ }
+
+mimetype :: Text -> Maybe Text
+mimetype "sh" = Just "text/x-shellscript"
+mimetype "shell" = Just "text/x-shellscript"
+mimetype "shellscript" = Just "text/x-shellscript"
+mimetype _ = Nothing
+
dtc :: Trees Key Tokens -> DTC
dtc ts = do
let lang = "fr"
TreeN KeySection{}
(Seq.viewl -> Tree0 (Write.t_Tokens -> TL.toStrict -> title) :< head)
:< body -> do
- d_Trees [] (mangleHead title head)
- d_Trees [] body
+ d_Trees inh_dtc (mangleHead title head)
+ d_Trees
+ inh_dtc { inh_dtc_figure = True }
+ body
_ ->
- d_Trees [] ts
+ d_Trees
+ inh_dtc { inh_dtc_figure = True }
+ ts
where
mangleHead ::
Text ->
names = name <$> Text.splitOn "\n" title
name =
TreeN (KeyColon "name" "") .
- Seq.singleton . Tree0 . Tokens .
- Seq.singleton . TokenPlain
+ Seq.singleton . Tree0 .
+ tokens1 . TokenPlain
-d_Trees :: [Key] -> Trees Key Tokens -> DTC
-d_Trees path ts =
- case () of
+d_Trees :: Inh_DTC -> Trees Key Tokens -> DTC
+d_Trees inh ts =
+ case Seq.viewl ts of
+ TreeN (KeyBar n _) _ :< _
+ | (content,ts') <- gatherBar n ts -> do
+ D.artwork !?? (mimetype n, DA.type_ . attrValue) $
+ d_Trees inh{inh_dtc_para=id} content
+ d_Trees inh ts'
+
+ TreeN key@(KeyColon n _) cs :< ts'
+ | (cs',ts'') <- gatherColon n ts'
+ , not (null cs') ->
+ d_Trees inh $ TreeN key (cs<>cs') <| ts''
+
_ | (ul,ts') <- gatherLI (==KeyDash) ts, not (null ul) -> do
- D.ul $ forM_ ul $ d_Tree path
- d_Trees path ts'
+ D.ul ! DA.style "format —" $ forM_ ul $ d_Tree inh
+ d_Trees inh ts'
+
_ | (ol,ts') <- gatherLI (\case KeyDot{} -> True; _ -> False) ts, not (null ol) -> do
- D.ol $ forM_ ol $ d_Tree path
- d_Trees path ts'
- _ | t:<ts' <- Seq.viewl ts -> do
- d_Tree path t
- d_Trees path ts'
+ D.ol $ forM_ ol $ d_Tree inh
+ d_Trees inh ts'
+
+ {-
+ _ | inh_dtc_figure inh
+ , Just (name,head,content,ts') <- gatherColon ts -> do
+ D.figure ! DA.type_ (attrValue name) $ do
+ D.name $ d_Tokens head
+ d_Trees inh content
+ d_Trees inh ts'
+ -}
+
+ t:<ts' -> do
+ d_Tree inh t
+ d_Trees inh ts'
+
_ ->
return ()
+gatherBar :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
+gatherBar name = first unKeyBar . spanBar
+ where
+ unKeyBar :: Trees Key Tokens -> Trees Key Tokens
+ unKeyBar = (=<<) $ \case
+ TreeN KeyBar{} ts -> ts
+ _ -> mempty
+ spanBar =
+ Seq.spanl $ \case
+ TreeN (KeyBar n _) _ | n == name -> True
+ _ -> False
+
+gatherColon :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
+gatherColon name =
+ Seq.spanl $ \case
+ TreeN (KeyBar n _) _ -> n == name
+ TreeN (KeyGreat n _) _ -> n == name
+ _ -> False
+
+{-
+gatherColon :: Trees Key Tokens -> Maybe (Name, Tokens, Trees Key Tokens, Trees Key Tokens)
+gatherColon ts =
+ case Seq.viewl ts of
+ TreeN (KeyColon name _) (toList -> [Tree0 head]) :< (spanBar name -> (body,ts')) ->
+ Just (name,head,body,ts')
+ _ -> Nothing
+ where
+ spanBar name =
+ Seq.spanl $ \case
+ TreeN (KeyBar n _) _ | n == name -> True
+ _ -> False
+-}
+
gatherLI ::
(Key -> Bool) ->
Trees Key Tokens ->
TokenPlain{} -> False
_ -> True
-d_Tree :: [Key] -> Tree Key Tokens -> DTC
-d_Tree path (TreeN key@KeySection{} ts) =
+gatherName ::
+ Trees Key Tokens ->
+ (Name, Tokens, Attributes, Trees Key Tokens)
+gatherName ts = dbg "gatherName" $
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
+ Tree0 (toList -> [TokenPlain name]) :< body ->
+ case Text.splitOn "\n" name of
+ n:[] -> (n,mempty,attrs,body)
+ n:ns -> (n,tokens [TokenPlain $ Text.intercalate "\n" ns],attrs,body)
+ [] -> (name,mempty,attrs,body)
+ Tree0 name :< body -> ("",name,attrs,body)
+ _ -> ("",mempty,attrs,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 ts = do
+d_Tree :: Inh_DTC -> Tree Key Tokens -> DTC
+d_Tree inh (TreeN KeySection{} ts) =
+ let inh' = inh
+ { inh_dtc_para = D.para
+ } in
+ case gatherName ts of
+ ("",Tokens (null->True),attrs,body) ->
+ d_Attributes attrs $
+ D.section $ d_Trees inh' body
+ ("",names,attrs,body) ->
+ d_Attributes (setAttrId (TL.toStrict $ Write.t_Tokens names) attrs) $
+ D.section $ do
+ D.name $ d_Tokens names
+ d_Trees inh' body
+ (name,names,attrs,body) ->
+ d_Attributes (setAttrId name attrs) $
+ D.section ! DA.name (attrValue name) $ do
+ when (not $ null $ unTokens names) $
+ D.name $ d_Tokens names
+ d_Trees inh' body
+d_Tree inh (TreeN key@(KeyColon typ _) ts) =
+ if inh_dtc_figure inh
+ then
+ case gatherName ts of
+ ("",names,attrs,body) ->
+ d_Attributes attrs $
+ D.figure ! DA.type_ (attrValue typ) $ do
+ when (not $ null $ unTokens names) $
+ D.name $ d_Tokens names
+ d_Trees inh body
+ (name,names,attrs,body) ->
+ d_Attributes attrs $
+ D.figure ! DA.type_ (attrValue typ)
+ ! DA.name (attrValue name) $ do
+ when (not $ null $ unTokens names) $
+ D.name $ d_Tokens names
+ d_Trees inh body
+ else
+ let (attrs,body) = partitionAttributesChildren ts in
+ d_Attributes attrs $
+ d_Key inh key body
+d_Tree path (TreeN key ts) = d_Key path key ts
+d_Tree inh (Tree0 ts) =
+ case ts of
+ (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens ts
+ _ -> inh_dtc_para inh $ d_Tokens ts
+
+setAttrId :: Text -> Attributes -> Attributes
+setAttrId = Map.insertWith (\_new old -> old) "id"
+
+d_Key :: Inh_DTC -> Key -> Trees Key Tokens -> DTC
+d_Key inh key ts = 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) ts
- KeyDash -> D.li $ d_Trees (key:path) ts
+ KeyDot _n -> D.li $ d_Trees inh ts
+ KeyDash -> D.li $ d_Trees inh ts
KeyDashDash -> B.Comment (B.Text $ TL.toStrict com) ()
- where com =
+ where
+ com =
Write.text Write.config_text $
mapTreeKey cell1 (\_path -> cell1) <$> ts
- KeyLower n as -> D.artwork $ d_Trees (key:path) ts
+ KeyLower n as ->
+ D.artwork $ d_Trees inh{inh_dtc_para = id} ts
where
d_key :: Text -> DTC
d_key name | null ts =
B.CustomLeaf (B.Text name) True mempty
d_key name =
B.CustomParent (B.Text name) $
- d_Trees (key:path) ts
+ d_Trees inh ts
-d_Tokens :: [Key] -> Tokens -> DTC
-d_Tokens _path tok = goTokens tok
+d_Tokens :: Tokens -> DTC
+d_Tokens tok = goTokens tok
where
-- indent = Text.replicate (columnPos pos - 1) " "
go :: Token -> DTC
-- * Type 'Attributes'
type Attributes = Map Name Text
-d_attrs :: Attributes -> DTC -> DTC
-d_attrs = flip $ Map.foldrWithKey $ \n v ->
+d_Attributes :: Attributes -> DTC -> DTC
+d_Attributes = flip $ Map.foldrWithKey $ \n v ->
B.AddCustomAttribute (B.Text n) (B.Text v)
partitionAttributesChildren ::
sourcephile / git / doclang.git / commitdiff