From 7c47259474709d95e5c33a5915409efa7a7c289f Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+hdoc@autogeree.net>
Date: Fri, 11 Jan 2019 02:57:33 +0000
Subject: [PATCH] DTC: add <page-ref> draft
---
Hdoc/DTC/Analyze/Collect.hs | 8 ++++++
Hdoc/DTC/Document.hs | 50 ++++++++++++++++++++++-------------
Hdoc/DTC/Sym.hs | 4 +++
Hdoc/DTC/Write/HTML5.hs | 41 ++++++++++++++++++++--------
Hdoc/DTC/Write/HTML5/Base.hs | 2 ++
Hdoc/DTC/Write/HTML5/Ident.hs | 13 +++++++--
Hdoc/TCT/Read/Token.hs | 4 +--
Hdoc/TCT/Write/XML.hs | 46 +++++++++++++++++++++++---------
style/dtc-html5.css | 5 ++++
9 files changed, 127 insertions(+), 46 deletions(-)
diff --git a/Hdoc/DTC/Analyze/Collect.hs b/Hdoc/DTC/Analyze/Collect.hs
index 8b48074..76515b6 100644
--- a/Hdoc/DTC/Analyze/Collect.hs
+++ b/Hdoc/DTC/Analyze/Collect.hs
@@ -47,6 +47,7 @@ data All = All
, all_notes :: TS.Trees (Seq [Para])
, all_reference :: HM.HashMap Ident (Seq Reference)
, all_ref :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
+ , all_pageRef :: HM.HashMap PathPage (Seq ((TCT.Location, XML.Pos), Section))
, all_section :: HM.HashMap Ident (Seq Section)
, all_at :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
, all_tag :: HM.HashMap Ident (Seq ((TCT.Location, XML.Pos), Section))
@@ -61,6 +62,7 @@ instance Default All where
, all_notes = def
, all_reference = def
, all_ref = def
+ , all_pageRef = def
, all_section = def
, all_at = def
, all_tag = def
@@ -75,6 +77,7 @@ instance Semigroup All where
, all_notes = ts_union (all_notes x) (all_notes y)
, all_reference = hm_union all_reference
, all_ref = hm_union all_ref
+ , all_pageRef = hm_union all_pageRef
, all_section = hm_union all_section
, all_at = hm_union all_at
, all_tag = hm_union all_tag
@@ -230,6 +233,11 @@ instance Collect (Tree PlainNode) where
return def
{ all_ref = HM.singleton ref_ident $ pure ((ref_locTCT, ref_posXML), reader_section)
} <> collect ts
+ PlainPageRef{..} -> do
+ Reader{..} <- R.ask
+ return def
+ { all_pageRef = HM.singleton pageRef_path $ pure ((pageRef_locTCT, pageRef_posXML), reader_section)
+ } <> collect ts
instance Collect Reference where
collect Reference{..} =
collect reference_about
diff --git a/Hdoc/DTC/Document.hs b/Hdoc/DTC/Document.hs
index 9770bb7..e6f4730 100644
--- a/Hdoc/DTC/Document.hs
+++ b/Hdoc/DTC/Document.hs
@@ -322,6 +322,11 @@ data PlainNode
, ref_posXML :: !XML.Pos
, ref_ident :: !Ident
} -- ^ Reference reference
+ | PlainPageRef { pageRef_locTCT :: !TCT.Location
+ , pageRef_posXML :: !XML.Pos
+ , pageRef_at :: !(Maybe Ident)
+ , pageRef_path :: !PathPage
+ } -- ^ Page reference
| PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
-- Leafs
| PlainBreak -- ^ Line break (\n)
@@ -382,6 +387,9 @@ data Anchor = Anchor
, anchor_count :: !Nat1
} deriving (Eq,Ord,Show)
+-- * Type 'PathPage'
+type PathPage = TL.Text
+
-- * Type 'Name'
newtype Name = Name { unName :: TL.Text }
deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
@@ -407,6 +415,9 @@ similarPlain = foldMap $ \(TS.Tree n ts) ->
PlainRef{..} -> pure $ TS.Tree PlainRef{ ref_locTCT = def
, ref_posXML = def
, .. } skip
+ PlainPageRef{..} -> pure $ TS.Tree PlainPageRef{ pageRef_locTCT = def
+ , pageRef_posXML = def
+ , .. } skip
PlainSpan attrs -> pure $ TS.Tree n' skip
where n' = PlainSpan{attrs = CommonAttrs{ attrs_id = Nothing
, attrs_classes = List.sort $ attrs_classes attrs }}
@@ -435,25 +446,26 @@ instance Hashable Title where
h (TS.Tree n ts) s =
(`hs` ts) $
case n of
- PlainGroup -> s
- PlainNote{} -> s
- PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
- PlainTag{..} -> s`hashWithSalt`(1::Int)`hashWithSalt`tag_ident`hashWithSalt`tag_back
- PlainAt{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
- PlainSpan{..} -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
- PlainB -> s`hashWithSalt`(4::Int)
- PlainCode -> s`hashWithSalt`(5::Int)
- PlainDel -> s`hashWithSalt`(6::Int)
- PlainI -> s`hashWithSalt`(7::Int)
- PlainQ -> s`hashWithSalt`(8::Int)
- PlainSC -> s`hashWithSalt`(9::Int)
- PlainSub -> s`hashWithSalt`(10::Int)
- PlainSup -> s`hashWithSalt`(11::Int)
- PlainU -> s`hashWithSalt`(12::Int)
- PlainEref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
- PlainRef{..} -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
- PlainBreak -> s`hashWithSalt`(15::Int)
- PlainText t -> s`hashWithSalt`(16::Int)`hashWithSalt`t
+ PlainGroup -> s
+ PlainNote{} -> s
+ PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
+ PlainTag{..} -> s`hashWithSalt`(1::Int)`hashWithSalt`tag_ident`hashWithSalt`tag_back
+ PlainAt{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
+ PlainSpan{..} -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
+ PlainB -> s`hashWithSalt`(4::Int)
+ PlainCode -> s`hashWithSalt`(5::Int)
+ PlainDel -> s`hashWithSalt`(6::Int)
+ PlainI -> s`hashWithSalt`(7::Int)
+ PlainQ -> s`hashWithSalt`(8::Int)
+ PlainSC -> s`hashWithSalt`(9::Int)
+ PlainSub -> s`hashWithSalt`(10::Int)
+ PlainSup -> s`hashWithSalt`(11::Int)
+ PlainU -> s`hashWithSalt`(12::Int)
+ PlainEref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
+ PlainRef{..} -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
+ PlainPageRef{..} -> s`hashWithSalt`(15::Int)`hashWithSalt`pageRef_at`hashWithSalt`pageRef_path
+ PlainBreak -> s`hashWithSalt`(16::Int)
+ PlainText t -> s`hashWithSalt`(17::Int)`hashWithSalt`t
-- * Type 'Entity'
data Entity = Entity
diff --git a/Hdoc/DTC/Sym.hs b/Hdoc/DTC/Sym.hs
index 10c9783..8b3824e 100644
--- a/Hdoc/DTC/Sym.hs
+++ b/Hdoc/DTC/Sym.hs
@@ -311,6 +311,10 @@ class (Sym_RNC repr, Sym_RNC_Extra repr) => Sym_DTC repr where
, element "at" $ tree0 <$> (DTC.PlainAt <$> locationTCT <*> positionXML <*> to <*> pure False)
, element "at-back" $ tree0 <$> (DTC.PlainAt <$> locationTCT <*> positionXML <*> to <*> pure True )
, element "ref" $ Tree <$> (DTC.PlainRef <$> locationTCT <*> positionXML <*> to) <*> plain
+ , element "page-ref" $ Tree <$> (DTC.PlainPageRef <$> locationTCT <*> positionXML
+ <*> optional (attribute "at" ident)
+ <*> attribute "page" text
+ ) <*> plain
]
{-
header =
diff --git a/Hdoc/DTC/Write/HTML5.hs b/Hdoc/DTC/Write/HTML5.hs
index 74ee2c6..7ba6cab 100644
--- a/Hdoc/DTC/Write/HTML5.hs
+++ b/Hdoc/DTC/Write/HTML5.hs
@@ -701,17 +701,14 @@ instance Html5ify (Tree PlainNode)
case toList ps of
[] -> ref
[Tree (PlainText "") _] -> do
- refs <- composeLift $ RWS.asks $ Analyze.all_reference . reader_all
- case toList <$> HM.lookup ref_ident refs of
- Just [Reference{reference_about=About{..}}] -> do
- forM_ (List.take 1 about_titles) $ \(Title title) -> do
- html5ify $ Tree PlainQ $
- case List.filter ((\rel -> rel == "" || rel == "self") . link_rel) about_links of
- [] -> title
- Link{..}:_ -> pure $ Tree (PlainEref link_url) title
- " "::HTML5
- ref
- _ -> mempty
+ let About{..} = reference_about
+ forM_ (List.take 1 about_titles) $ \(Title title) -> do
+ html5ify $ Tree PlainQ $
+ case List.filter ((\rel -> rel == "" || rel == "self") . link_rel) about_links of
+ [] -> title
+ Link{..}:_ -> pure $ Tree (PlainEref link_url) title
+ " "::HTML5
+ ref
_ -> do
a $$ html5ify ps
H.span ! HA.class_ "print-only" $$ do
@@ -729,6 +726,28 @@ instance Html5ify (Tree PlainNode)
"["::HTML5
html5ify ref_ident
"]"
+ -- <page-ref>
+ PlainPageRef{..} -> do
+ Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
+ State{..} <- composeLift RWS.get
+ let idNum = HM.lookupDefault (Nat1 1) pageRef_path state_pageRef
+ composeLift $ RWS.modify $ \s -> s
+ { state_pageRef = HM.insert pageRef_path (succNat1 idNum) state_pageRef }
+ let href_at = attrify pageRef_path <>
+ maybe mempty (\at -> refIdent (identifyAt "" at Nothing)) pageRef_at
+ let ref = do
+ H.sup
+ ! HA.id (attrify $ identifyPage "" pageRef_path $ Just idNum) $$ do
+ "["::HTML5
+ H.a ! HA.href (attrify pageRef_path) $$
+ html5ify pageRef_path
+ "]"
+ H.span ! HA.class_ "page-ref" $$ do
+ H.a ! HA.href href_at $$
+ html5ify pageRef_at
+ H.span ! HA.class_ "print-only" $$ do
+ " "::HTML5
+ ref
-- <iref>
PlainIref{..} ->
case pathFromWords iref_term of
diff --git a/Hdoc/DTC/Write/HTML5/Base.hs b/Hdoc/DTC/Write/HTML5/Base.hs
index daadc61..331770a 100644
--- a/Hdoc/DTC/Write/HTML5/Base.hs
+++ b/Hdoc/DTC/Write/HTML5/Base.hs
@@ -116,6 +116,7 @@ instance Monoid Writer where
data State = State
{ state_errors :: !(Analyze.Errors Nat1)
, state_ref :: !(HM.HashMap Ident Nat1)
+ , state_pageRef :: !(HM.HashMap PathPage Nat1)
, state_at :: !(HM.HashMap Ident Nat1)
, state_tag :: !(HM.HashMap Ident Nat1)
, state_irefs :: !(TM.TreeMap Word Nat1)
@@ -129,6 +130,7 @@ instance Default State where
def = State
{ state_errors = def
, state_ref = def
+ , state_pageRef = def
, state_at = def
, state_tag = def
, state_irefs = def
diff --git a/Hdoc/DTC/Write/HTML5/Ident.hs b/Hdoc/DTC/Write/HTML5/Ident.hs
index 8a224f9..2646a36 100644
--- a/Hdoc/DTC/Write/HTML5/Ident.hs
+++ b/Hdoc/DTC/Write/HTML5/Ident.hs
@@ -26,6 +26,7 @@ import qualified Data.Text.Lazy.Builder as TL.Builder
import qualified Data.Text.Lazy.Builder.Int as TL.Builder
import qualified Data.Text.Lazy.Encoding as TL
import qualified Text.Blaze.Html5 as H
+import qualified Language.Symantic.XML as XML
import Text.Blaze.Utils
@@ -55,7 +56,7 @@ instance Identify XML.Ancestors where
(if TL.null acc then acc else acc <> ".") <>
(if Just name == nameParent
then unIdent $ identify $ show rank
- else identifyString (show name)<>"."<>identifyString (show rank))
+ else identifyString (show $ XML.qNameLocal name)<>"."<>identifyString (show rank))
)
)
(Nothing, mempty)
@@ -129,10 +130,18 @@ identifyAt suffix ref count =
<> escapeIdent (unIdent ref)
<> maybe "" (("."<>) . identify) count
+identifyPage :: Ident -> PathPage -> Maybe Nat1 -> Ident
+identifyPage suffix page count =
+ (if suffix == Ident ""
+ then ""
+ else "page" <> suffix <> ".")
+ <> escapeIdent page
+ <> maybe "" (("."<>) . identify) count
+
identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
identifyReference suffix to count =
"reference" <> suffix
- <> "." <> to
+ <> "." <> escapeIdent (unIdent to)
<> maybe "" (("."<>) . identify) count
cleanPlain :: Plain -> Plain
diff --git a/Hdoc/TCT/Read/Token.hs b/Hdoc/TCT/Read/Token.hs
index 8327d11..852f135 100644
--- a/Hdoc/TCT/Read/Token.hs
+++ b/Hdoc/TCT/Read/Token.hs
@@ -170,7 +170,7 @@ data Lexeme
-- see 'orientLexemePairAny'
| LexemePairBoth !(NonEmpty (Cell Pair))
| LexemeEscape !(Cell Char)
- | LexemeLink !(Cell TL.Text)
+ | LexemeLink !(Cell Link)
| LexemeWhite !(Cell TL.Text)
| LexemeAlphaNum !(Cell TL.Text)
| LexemeOther !(Cell TL.Text)
@@ -303,7 +303,7 @@ p_BackOpen = debugParser "BackOpen" $
p_Escape :: Parser e s Char
p_Escape = P.char '\\' *> P.satisfy Char.isPrint
-p_Link :: P.Tokens s ~ TL.Text => Parser e s TL.Text
+p_Link :: P.Tokens s ~ TL.Text => Parser e s Link
p_Link =
P.try (P.char '<' *> p <* P.char '>') <|>
p
diff --git a/Hdoc/TCT/Write/XML.hs b/Hdoc/TCT/Write/XML.hs
index 1986d85..244d026 100644
--- a/Hdoc/TCT/Write/XML.hs
+++ b/Hdoc/TCT/Write/XML.hs
@@ -5,6 +5,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.TCT.Write.XML where
+import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
@@ -129,7 +130,7 @@ instance Xmlify Roots where
xmlify inh roots =
case Seq.viewl roots of
EmptyL -> mempty
- r@(Tree cr@(Sourced src nr) ts) :< rs ->
+ r0@(Tree cr@(Sourced src nr) ts) :< rs ->
case nr of
----------------------
-- NOTE: HeaderColon becomes parent
@@ -165,13 +166,31 @@ instance Xmlify Roots where
NodeText x
| Tree (cy@(unSourced -> NodeText y)) ys :< rs' <- Seq.viewl rs ->
xmlify inh $ Tree (NodeText <$> (x <$ cr) <> (y <$ cy)) (ts <> ys) <| rs'
+ ----------------------
+ -- NOTE: detect @some text@{some page/and more}
+ NodePair (PairAt False)
+ | Tree (Sourced _src (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs
+ , [Tree (Sourced srcPage (NodeToken (TokenText pageRef))) _] <- toList bracket
+ , '.':'/':page <- TL.unpack pageRef ->
+ (<| xmlify inh rs') $
+ element src "page-ref" $
+ xmlAttrs
+ [ Sourced src (fromString "at", Plain.writePlain ts)
+ , Sourced srcPage (fromString "page", TL.pack page)
+ ]
+ {-
+ if null ts -- NOTE: preserve empty parens
+ then Seq.singleton $ tree0 (XML.NodeText mempty <$ cr)
+ else xmlify inh ts
+ -}
----------------------
-- NOTE: detect (some text)[http://some.url] or (some text)[SomeRef]
NodePair PairParen
| Tree (Sourced sb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
(<| xmlify inh rs') $
case bracket of
- (toList -> [unTree -> Sourced sl (NodeToken (TokenLink lnk))]) ->
+ (toList -> [unTree -> Sourced sl (NodeToken tok)])
+ | TokenLink lnk <- tok ->
element src "eref" $
xmlAttrs [Sourced sl (fromString "to", lnk)] <>
xmlify inh ts
@@ -206,12 +225,12 @@ instance Xmlify Roots where
_ -> False
----------------------
NodePara | para:inh_para <- inh_para inh ->
- para inh r <|
+ para inh r0 <|
xmlify inh{inh_para} rs
----------------------
-- NOTE: context-free Root
_ ->
- xmlify inh r `XML.union`
+ xmlify inh r0 `XML.union`
xmlify inh rs
instance Xmlify Root where
xmlify inh tn@(Tree (Sourced src@(sn:|ssn) nod) ts) =
@@ -355,7 +374,9 @@ instance Xmlify Root where
NodePair pair ->
case pair of
PairBracket | to <- Plain.writePlain ts
- , TL.all (\c -> c/='[' && c/=']' && Char.isPrint c && not (Char.isSpace c)) to ->
+ , TL.all (\c -> c/='[' && c/=']'
+ && Char.isPrint c
+ && not (Char.isSpace c)) to ->
Seq.singleton $
element src "ref" $
xmlAttrs [Sourced src (fromString "to",to)]
@@ -370,16 +391,16 @@ instance Xmlify Root where
case ts of
(Seq.viewl -> Tree0 (Sourced sl (NodeToken (TokenText l))) :< ls) ->
case Seq.viewr ls of
- m :> Tree0 (Sourced sr (NodeToken (TokenText r))) ->
+ m :> Tree0 (Sourced sr (NodeToken (TokenText r0))) ->
xmlify inh $
Tree0 (Sourced sl (NodeToken (TokenText (TL.dropWhile Char.isSpace l))))
- Seq.<|(m Seq.|>Tree0 (Sourced sr (NodeToken (TokenText (TL.dropWhileEnd Char.isSpace r)))))
+ Seq.<|(m Seq.|>Tree0 (Sourced sr (NodeToken (TokenText (TL.dropWhileEnd Char.isSpace r0)))))
_ ->
xmlify inh $
Tree0 (Sourced sl (NodeToken (TokenText (TL.dropAround Char.isSpace l)))) Seq.<| ls
- (Seq.viewr -> rs :> Tree0 (Sourced sr (NodeToken (TokenText r)))) ->
+ (Seq.viewr -> rs :> Tree0 (Sourced sr (NodeToken (TokenText r0)))) ->
xmlify inh $
- rs Seq.|> Tree0 (Sourced sr (NodeToken (TokenText (TL.dropAround Char.isSpace r))))
+ rs Seq.|> Tree0 (Sourced sr (NodeToken (TokenText (TL.dropAround Char.isSpace r0))))
_ -> xmlify inh ts
PairTag isBackref ->
Seq.singleton $
@@ -400,10 +421,10 @@ instance Xmlify Root where
xmlify inh ts
_ ->
Seq.singleton (Tree0 $ Sourced (sn{fileRange_end=bn'}:|ssn) $
- XML.NodeText [XML.EscapedPlain open]) `XML.union`
+ XML.NodeText (XML.EscapedText $ pure $ XML.EscapedPlain open)) `XML.union`
xmlify inh ts `XML.union`
Seq.singleton (Tree0 $ Sourced (sn{fileRange_begin=en'}:|ssn) $
- XML.NodeText [XML.EscapedPlain close])
+ XML.NodeText $ XML.EscapedText $ pure $ XML.EscapedPlain close)
where
(open, close) = pairBorders pair ts
bn' = (fileRange_begin sn){filePos_column=filePos_column (fileRange_begin sn) + int (TL.length open)}
@@ -413,7 +434,7 @@ instance Xmlify Root where
----------------------
NodeToken tok ->
case tok of
- TokenEscape c -> Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText [XML.escapeChar c]
+ TokenEscape c -> Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText $ XML.EscapedText $ pure $ XML.escapeChar c
TokenText t -> Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText $ XML.escapeText t
TokenAt b to -> Seq.singleton $ element src (if b then "at-back" else "at") $
xmlAttrs [Sourced src (fromString "to", to)]
@@ -498,6 +519,7 @@ elems = Set.fromList $ fromString <$>
, "ol"
, "organization"
, "para"
+ , "page-ref"
, "postamble"
, "preamble"
, "q"
diff --git a/style/dtc-html5.css b/style/dtc-html5.css
index 0db15af..cca31b4 100644
--- a/style/dtc-html5.css
+++ b/style/dtc-html5.css
@@ -595,6 +595,11 @@
text-decoration-color:red;
text-decoration-style:double;
}
+/* .page-ref */
+ .page-ref > a,
+ .page-ref > sup > a {
+ color:green;
+ }
/* .shortcuts */
ul.shortcuts {
list-style-type:none;
--
2.47.2