import Data.Text (Text)
import Text.Show (Show)
import qualified Data.Sequence as Seq
+import Language.TCT.Write.XML (XmlPos(..))
-- * Class 'Default'
class Default a where
, title :: Title
, aliases :: [Alias]
, body :: [Body]
+ , pos :: XmlPos
}
| Verticals [Vertical]
deriving (Eq,Show)
data Vertical
= Para { attrs :: CommonAttrs
, horis :: Horizontals
+ , pos :: XmlPos
}
| OL { attrs :: CommonAttrs
, items :: [Verticals]
+ , pos :: XmlPos
}
| UL { attrs :: CommonAttrs
, items :: [Verticals]
+ , pos :: XmlPos
}
| RL { attrs :: CommonAttrs
, refs :: [Reference]
+ , pos :: XmlPos
}
| ToC { attrs :: CommonAttrs
, depth :: Maybe Int
+ , pos :: XmlPos
}
| ToF { attrs :: CommonAttrs
, depth :: Maybe Int
+ , pos :: XmlPos
}
| Index { attrs :: CommonAttrs
+ , pos :: XmlPos
}
| Figure { type_ :: Text
, attrs :: CommonAttrs
, title :: Title
, verts :: Verticals
+ , pos :: XmlPos
}
| Artwork { attrs :: CommonAttrs
, art :: Artwork
+ , pos :: XmlPos
}
| Comment Text
deriving (Eq,Show)
, classes :: [Text]
} deriving (Eq,Show)
+-- * Type 'Auto'
+data Auto
+ = Auto
+ { auto_id :: Ident
+ } deriving (Eq,Show)
+
-- * Type 'Verticals'
type Verticals = [Vertical]
-- | Read DTC from TCT.
module Language.DTC.Read.TCT where
+-- import Control.Monad.Trans.Class (MonadTrans(..))
+-- import qualified Control.Monad.Trans.Reader as R
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Functor ((<$>), (<$))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Tuple (snd)
import GHC.Exts (toList)
+import Prelude (Num(..))
import Text.Read (readMaybe)
import Text.Show (Show(..))
+import qualified Control.Monad.Trans.State as S
import qualified Data.List as List
+import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Perm as P
-import Language.TCT hiding (Parser)
-import Language.TCT.Write.XML (XML,XMLs,XmlLeaf(..))
import Language.DTC.Document (Nat(..), Nat1(..))
+import Language.TCT hiding (Parser)
+import Language.TCT.Write.XML (XML,XMLs,XmlLeaf(..),XmlPos(..))
import qualified Language.DTC.Document as DTC
import qualified Language.DTC.Sym as DTC
import qualified Language.RNC.Sym as RNC
import qualified Language.TCT.Write.XML as XML
-- * Type 'Parser'
-type Parser = P.Parsec Error XMLs
+-- type Parser = P.Parsec Error XMLs
+type Parser = S.StateT XmlPos (P.Parsec Error XMLs)
instance RNC.Sym_Rule Parser where
-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
instance RNC.Sym_RNC Parser where
none = P.label "none" $ P.eof
any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
- anyElem p = P.dbg "anyElem" $ P.label "anyElem" $ do
+ anyElem p = P.label "anyElem" $ do
(n,ts) <- P.token check $ Just expected
parserXMLs (p n) ts
where
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
+ position p = do
+ st <- S.get
+ ($ st) <$> p
element n p = do
ts <- P.token check $ Just expected
- parserXMLs p ts
+ xp <- S.get
+ S.put xp
+ { xmlPosAncestors = (n,maybe 1 (+1) $ Map.lookup n $ xmlPosPrecedingsSiblings xp):xmlPosAncestors xp
+ , xmlPosPrecedingsSiblings = mempty
+ }
+ parserXMLs p ts <* S.put xp
+ { xmlPosPrecedingsSiblings =
+ Map.insertWith (\_new old -> old + 1) n 1 $
+ xmlPosPrecedingsSiblings xp
+ }
where
expected = TreeN (cell0 n) mempty
check (TreeN (unCell -> e) ts) | e == n = Right ts
DTC.Sym_DTC Parser =>
XMLs ->
Either (P.ParseError (P.Token XMLs) Error) DTC.Document
-readDTC = parseXMLs (P.initialPos "") DTC.document
+readDTC =
+ parseXMLs
+ XmlPos { xmlPosAncestors = []
+ , xmlPosPrecedingsSiblings = mempty
+ }
+ (P.initialPos "")
+ DTC.document
parseXMLs ::
DTC.Sym_DTC Parser =>
+ XmlPos ->
P.SourcePos -> Parser a -> XMLs ->
Either (P.ParseError (P.Token XMLs) Error) a
-parseXMLs pos p i =
- snd $ P.runParser' (p <* RNC.none)
+parseXMLs xp pos p i =
+ snd $
+ P.runParser' ((`S.evalStateT` xp) $ p <* RNC.none)
P.State
{ P.stateInput = i
, P.statePos = pure $
, P.stateTokensProcessed = 0
}
--- | @parserXMLs pos p xs@ returns a 'Parser' parsing @xs@ with @p@.
+-- | @parserXMLs xp pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from position @xp@.
parserXMLs ::
DTC.Sym_DTC Parser =>
Parser a -> XMLs -> Parser a
parserXMLs p xs = do
pos <- P.getPosition
- case parseXMLs pos p xs of
+ xp <- S.get
+ case parseXMLs xp pos p xs of
Left (P.TrivialError (posErr:|_) un ex) -> do
P.setPosition posErr
P.failure un ex
sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
sourcePos _ = Nothing
--- ** Type 'XMLs'
instance P.Stream XMLs where
type Token XMLs = XML
type Tokens XMLs = XMLs
choice
[ rule "section" $
element "section" $
+ position $
DTC.Section
<$> commonAttrs
<*> title
vertical = rule "vertical" $
choice
[ DTC.Comment <$> comment
- , element "para" $ DTC.Para
+ , element "para" $
+ position $
+ DTC.Para
<$> commonAttrs
<*> horizontals
- , element "ol" $ DTC.OL
+ , element "ol" $
+ position $
+ DTC.OL
<$> commonAttrs
<*> many (element "li" $ many vertical)
- , element "ul" $ DTC.UL
+ , element "ul" $
+ position $
+ DTC.UL
<$> commonAttrs
<*> many (element "li" $ many vertical)
- , element "rl" $ DTC.RL
+ , element "rl" $
+ position $
+ DTC.RL
<$> commonAttrs
<*> many reference
- , element "toc" $ DTC.ToC
+ , element "toc" $
+ position $
+ DTC.ToC
<$> commonAttrs
<*> optional (attribute "depth" int)
- , element "tof" $ DTC.ToF
+ , element "tof" $
+ position $
+ DTC.ToF
<$> commonAttrs
<*> optional (attribute "depth" int)
- , element "index" $ DTC.Index
+ , element "index" $
+ position $
+ DTC.Index
<$> commonAttrs
<* any
, figure
figure =
rule "figure" $
element "figure" $
+ position $
DTC.Figure
<$> attribute "type" text
<*> commonAttrs
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a DTC source file in HTML5.
module Language.DTC.Write.HTML5 where
-import Control.Monad (forM_, mapM_)
+-- import Control.Monad.Trans.Class (MonadTrans(..))
-- import Data.Bool
-- import Data.Eq (Eq(..))
+-- import Data.String (IsString(..))
+-- import Prelude (Num(..), undefined)
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..), forM_, mapM_)
+import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.Maybe (Maybe(..))
+import Data.Function (($), (.), const)
+import Data.Functor (Functor(..), (<$>), ($>))
+import Data.Functor.Compose (Compose(..))
+import Data.Functor.Identity (Identity(..))
+import Data.Int (Int)
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
+import Data.Text (Text)
+import Data.Tuple (snd)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
-import qualified Data.List as L
+import Text.Show (Show(..))
+import qualified Control.Monad.Trans.State as S
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import Language.DTC.Document (Document)
import Language.DTC.Write.XML ()
+import Language.TCT.Write.XML (XmlName(..), XmlPos(..))
import qualified Language.DTC.Document as DTC
+-- import Debug.Trace (trace)
+
instance H.ToMarkup DTC.Ident where
toMarkup (DTC.Ident i) = H.toMarkup i
+instance AttrValue XmlPos where
+ attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
+
+-- * Type 'InhHtml5'
+data InhHtml5
+ = InhHtml5
+inhHtml5 :: InhHtml5
+inhHtml5 = InhHtml5
+
+{- NOTE: composing state and markups
+type HtmlM st = Compose (S.State st) H.MarkupM
+instance Monad (HtmlM st) where
+ return = pure
+ Compose sma >>= a2csmb =
+ Compose $ sma >>= \ma ->
+ case ma >>= H.Empty . a2csmb of
+ H.Append _ma (H.Empty csmb) ->
+ H.Append ma <$> getCompose csmb
+ _ -> undefined
+
+($$) :: (Html -> Html) -> HTML -> HTML
+($$) f m = Compose $ f <$> getCompose m
+infixr 0 $$
+-}
+
+unMarkupValue :: H.MarkupM a -> b -> H.MarkupM b
+unMarkupValue = \case
+ H.Parent x0 x1 x2 m -> H.Parent x0 x1 x2 . unMarkupValue m
+ H.CustomParent x0 m -> H.CustomParent x0 . unMarkupValue m
+ H.Leaf x0 x1 x2 _ -> H.Leaf x0 x1 x2
+ H.CustomLeaf x0 x1 _ -> H.CustomLeaf x0 x1
+ H.Content x0 _ -> H.Content x0
+ H.Comment x0 _ -> H.Comment x0
+ H.Append x0 m -> H.Append x0 . unMarkupValue m
+ H.AddAttribute x0 x1 x2 m -> H.AddAttribute x0 x1 x2 . unMarkupValue m
+ H.AddCustomAttribute x0 x1 m -> H.AddCustomAttribute x0 x1 . unMarkupValue m
+ H.Empty _ -> H.Empty
+
+markupValue :: H.MarkupM a -> a
+markupValue m0 = case m0 of
+ H.Parent _ _ _ m1 -> markupValue m1
+ H.CustomParent _ m1 -> markupValue m1
+ H.Leaf _ _ _ x -> x
+ H.CustomLeaf _ _ x -> x
+ H.Content _ x -> x
+ H.Comment _ x -> x
+ H.Append _ m1 -> markupValue m1
+ H.AddAttribute _ _ _ m1 -> markupValue m1
+ H.AddCustomAttribute _ _ m1 -> markupValue m1
+ H.Empty x -> x
html5Document :: Document -> Html
html5Document DTC.Document{..} = do
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
- let t = textHorizontals $ L.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
+ let t = textHorizontals $ List.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
H.title $ H.toMarkup t
-- link ! rel "Chapter" ! title "SomeTitle">
H.link ! HA.rel "stylesheet"
! HA.href "style/dtc-html5.css"
H.body $
forM_ body html5Body
-
html5Body :: DTC.Body -> Html
html5Body = \case
DTC.Section{..} ->
- html5CommonAttrs attrs $
- H.section $ do
- H.table ! HA.class_ "section-header" $
- H.tbody $
- H.tr $ do
- H.td ! HA.class_ "section-number" $
- "N.N.N"
- H.td ! HA.class_ "section-title" $
- html5Horizontals $ DTC.unTitle title
+ H.section
+ ! HA.class_ "section"
+ ! HA.id (attrValue pos) $ do
+ html5CommonAttrs attrs $
+ H.table ! HA.class_ "section-header" $
+ H.tbody $
+ H.tr $ do
+ H.td ! HA.class_ "section-number" $ do
+ html5SectionNumber $ xmlPosAncestors pos
+ H.td ! HA.class_ "section-title" $ do
+ html5Horizontals $ DTC.unTitle title
forM_ body html5Body
{- aliases :: [Alias]
-}
DTC.Verticals vs -> html5Verticals vs
+textXmlPosAncestors :: [(XmlName,Int)] -> Text
+textXmlPosAncestors =
+ snd . foldr (\(n,c) (nParent,acc) ->
+ (n,
+ (if Text.null acc
+ then acc
+ else acc <> ".") <>
+ Text.pack
+ (if n == nParent
+ then show c
+ else show n<>show c)
+ )
+ ) ("","")
+
+html5SectionNumber :: [(XmlName,Int)] -> Html
+html5SectionNumber = go [] . List.reverse
+ where
+ go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html
+ go _rs [] = mempty
+ go rs (a@(_n,cnt):as) = do
+ H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $
+ H.toMarkup $ show cnt
+ H.toMarkup '.'
+ go (a:rs) as
+
html5Verticals :: [DTC.Vertical] -> Html
html5Verticals = foldMap html5Vertical
html5Vertical = \case
DTC.Para{..} ->
html5CommonAttrs attrs $
- H.div ! HA.class_ "para" $
+ H.div ! HA.class_ "para"
+ ! HA.id (attrValue pos) $ do
html5Horizontals horis
DTC.OL{..} ->
html5CommonAttrs attrs $
- H.ol ! HA.class_ "ol" $
+ H.ol ! HA.class_ "ol"
+ ! HA.id (attrValue pos) $ do
forM_ items $ \item ->
H.li $ html5Verticals item
DTC.UL{..} ->
html5CommonAttrs attrs $
- H.ul ! HA.class_ "ul" $
+ H.ul ! HA.class_ "ul"
+ ! HA.id (attrValue pos) $ do
forM_ items $ \item ->
H.li $ html5Verticals item
DTC.RL{..} ->
html5CommonAttrs attrs $
- H.div ! HA.class_ "rl" $
+ H.div ! HA.class_ "rl"
+ ! HA.id (attrValue pos) $ do
H.table $
forM_ refs html5Reference
DTC.Comment t ->
H.Comment (H.Text t) ()
DTC.Figure{..} ->
html5CommonAttrs attrs $
- H.div ! HA.class_ (attrValue $ "figure-"<>type_) $ do
+ H.div ! HA.class_ (attrValue $ "figure-"<>type_)
+ ! HA.id (attrValue pos) $ do
H.table ! HA.class_ "figure-caption" $
H.tbody $
H.tr $ do
H.div ! HA.class_ "figure-content" $ do
html5Verticals verts
DTC.ToC{..} ->
- H.nav ! HA.class_ "toc" $ ""
+ H.nav ! HA.class_ "toc"
+ ! HA.id (attrValue pos) $
+ ""
DTC.ToF{..} ->
- H.nav ! HA.class_ "tof" $ ""
+ H.nav ! HA.class_ "tof"
+ ! HA.id (attrValue pos) $
+ ""
{-
Index{..} ->
Artwork{..} ->
DTC.U hs -> H.span ! HA.class_ "underline" $ html5Horizontals hs
DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $ html5Horizontals text
DTC.Iref{..} -> H.a ! HA.class_ "iref" ! HA.href (attrValue to) $ html5Horizontals text
- DTC.Ref{..} -> H.a ! HA.class_ "ref" ! HA.href (attrValue to) $ html5Horizontals text
+ DTC.Ref{..} ->
+ H.a ! HA.class_ "ref"
+ ! HA.href ("#"<>attrValue to) $
+ if null text
+ then H.toMarkup to
+ else html5Horizontals text
DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to) $ html5Horizontals text
DTC.Plain t -> H.toMarkup t
xmlVertical :: DTC.Vertical -> XML
xmlVertical = \case
- DTC.Para as hs ->
- xmlCommonAttrs as $
- XML.para $ xmlHorizontals hs
- DTC.OL as vs ->
- xmlCommonAttrs as $
- XML.ol $ forM_ vs $ XML.li . xmlVerticals
- DTC.UL as vs ->
- xmlCommonAttrs as $
- XML.ul $ forM_ vs $ XML.li . xmlVerticals
- DTC.ToC as d ->
- xmlCommonAttrs as $
+ DTC.Para{..} ->
+ xmlCommonAttrs attrs $
+ XML.para $ xmlHorizontals horis
+ DTC.OL{..} ->
+ xmlCommonAttrs attrs $
+ XML.ol $ forM_ items $ XML.li . xmlVerticals
+ DTC.UL{..} ->
+ xmlCommonAttrs attrs $
+ XML.ul $ forM_ items $ XML.li . xmlVerticals
+ DTC.ToC{..} ->
+ xmlCommonAttrs attrs $
XML.toc
- !?? mayAttr XA.depth d
- DTC.ToF as d ->
- xmlCommonAttrs as $
+ !?? mayAttr XA.depth depth
+ DTC.ToF{..} ->
+ xmlCommonAttrs attrs $
XML.tof
- !?? mayAttr XA.depth d
- DTC.RL as rs ->
- xmlCommonAttrs as $
- XML.rl $ forM_ rs $ xmlReference
+ !?? mayAttr XA.depth depth
+ DTC.RL{..} ->
+ xmlCommonAttrs attrs $
+ XML.rl $ forM_ refs $ xmlReference
-- DTC.Index -> XML.index
DTC.Figure{..} ->
xmlCommonAttrs attrs $
xmlVerticals verts
DTC.Comment c ->
XML.comment c
- DTC.Artwork as _art ->
- xmlCommonAttrs as $
+ DTC.Artwork{..} ->
+ xmlCommonAttrs attrs $
XML.artwork mempty
xmlHorizontals :: DTC.Horizontals -> XML
{-# LANGUAGE TypeFamilyDependencies #-}
module Language.RNC.Sym where
-import Control.Applicative (Applicative(..), (<$>), (<$))
+import Control.Applicative (Applicative(..), (<$>))
import Data.Foldable (Foldable,foldl',foldr)
import Data.Function (($),(.),id,flip)
import Data.Int (Int)
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..))
import Data.Text (Text)
import Text.Show (Show)
-import qualified Data.Text as Text
-import Language.DTC.Document (Default(..), MayText(..))
-import Language.TCT.Write.XML (XmlName(..))
+import Language.DTC.Document (Default(..))
+import Language.TCT.Write.XML (XmlName(..), XmlPos)
import qualified Language.DTC.Document as DTC
foldlApp :: (DTC.Default a, Foldable t) => t (a -> a) -> a
, Sym_Rule repr
, Sym_Interleaved repr
) => Sym_RNC repr where
+ position :: repr (XmlPos -> a) -> repr a
element :: XmlName -> repr a -> repr a
attribute :: XmlName -> repr a -> repr a
comment :: repr Text
Compose (Writer . unWriter <$> ws <>
[Writer $ unWriter $ many $ Writer w])
instance Sym_RNC Writer where
+ position (Writer w) = Writer w
element n (Writer w) = Writer $ \rm po pp ->
pairInfix pp po op $
"element \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
import Data.Function (($), (.))
import Data.Functor (Functor)
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..))
, P.Token s ~ Char
, Ord e
, IsString (P.Tokens s)
+ , P.ShowErrorComponent e
) => P.Parsec e s a
p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
p_ColNum = intOfPos . P.sourceColumn <$> P.getPosition
-- * Debug
-pdbg :: ( Show a
- , P.Token s ~ Char
- , P.ShowToken (P.Token s)
- , P.Stream s
- ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
+pdbg :: Show a => String -> Parser e s a -> Parser e s a
-- pdbg m p = P.dbg m p
pdbg _m p = p
{-# INLINE pdbg #-}
import Language.TCT.Read.Elem
import Language.TCT.Read.Cell
-{-
-import Debug.Trace (trace)
-dbg m x = trace (m <> ": " <> show x) x
-pdbg m p = P.dbg m p
--}
-
textOf :: Buildable a => a -> Text
textOf = TL.toStrict . Builder.toLazyText . build
LexemeWhite (unCell -> "") -> acc
LexemeWhite cs -> appendToken acc $ TokenPlain <$> cs
LexemeAlphaNum cs -> appendToken acc $ TokenPlain . Text.pack <$> cs
- LexemeChar c -> appendToken acc $ TokenPlain . Text.singleton <$> c
+ LexemeAny cs -> appendToken acc $ TokenPlain . Text.pack <$> cs
LexemeToken ts -> appendTokens acc ts
-- * Type 'Lexeme'
| LexemeLink !(Cell Text)
| LexemeWhite !(Cell White)
| LexemeAlphaNum !(Cell [Char])
- | LexemeChar !(Cell Char)
+ | LexemeAny !(Cell [Char])
| LexemeToken !Tokens
deriving (Eq, Show)
(p_Lexeme >>= \next -> go $ mangleLexemes $ next:acc)
mangleLexemes = \case
- w@LexemeWhite{} :p@LexemePairAny{}:acc -> w:any2close p:acc
- p@LexemePairAny{}:w@LexemeWhite{} :acc -> any2open p:w:acc
-
- l@LexemeAlphaNum{}:c@LexemeChar{} :p@LexemePairAny{}:acc -> l:c:any2close p:acc
- l@LexemeAlphaNum{}:p@LexemePairAny{}:c@LexemeChar{}:acc -> l:any2open p:c:acc
-
- acc -> acc
+ LexemeAny (Cell _bx ex x):LexemeAny (Cell by _ey y):acc -> LexemeAny (Cell by ex (x<>y)):acc
+
+ -- "
+ w@LexemeWhite{}:LexemePairAny p:acc -> w:LexemePairClose p:acc
+ -- "
+ LexemePairAny p:w@LexemeWhite{}:acc -> LexemePairOpen p:w:acc
- any2close,any2open :: Lexeme -> Lexeme
- any2close (LexemePairAny ps) = LexemePairClose ps
- any2close c = c
- any2open (LexemePairAny ps) = LexemePairOpen ps
- any2open c = c
+ -- ,,,"
+ LexemePairAny p:a@LexemeAny{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc
+ -- ",,,
+ w@LexemeWhite{}:a@LexemeAny{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc
+
+ -- ",,,AAA
+ an@LexemeAlphaNum{}:a@LexemeAny{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc
+ -- ,,,"AAA
+ an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeAny{}:acc -> an:LexemePairOpen p:a:acc
+
+ -- ")
+ c@LexemePairClose{}:LexemePairAny p:acc -> c:LexemePairClose p:acc
+ -- ("
+ LexemePairAny p:o@LexemePairOpen{}:acc -> LexemePairOpen p:o:acc
+
+ acc -> acc
pairAny :: Char -> Maybe Pair
pairAny = \case
, P.try $ LexemeEscape <$> p_Cell p_Escape
, P.try $ LexemeLink <$> p_Cell p_Link
, P.try $ LexemeAlphaNum <$> p_Cell (P.some p_AlphaNum)
- , LexemeChar <$> p_Cell P.anyChar
+ , LexemeAny <$> p_Cell (pure <$> P.anyChar)
]
p_AlphaNum :: Parser e s Char
import Data.Foldable (null, foldl', any)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
+import Data.Int (Int)
+import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
| XmlText Text
deriving (Eq,Ord,Show)
+-- ** Type 'XmlPos'
+data XmlPos
+ = XmlPos
+ { xmlPosAncestors :: [(XmlName,Count)]
+ , xmlPosPrecedingsSiblings :: Map XmlName Count
+ } deriving (Eq,Show)
+type Count = Int
+
-- * Type 'InhXml'
data InhXml
= InhXml
goTokens $
rs |> Cell br er (TokenPlain (Text.dropAround Char.isSpace r))
_ -> goTokens toks
- TokenPair PairHash (toList -> [unCell -> TokenPlain t]) ->
+ TokenPair PairHash to ->
Seq.singleton $
TreeN (cell "ref") $
- xmlAttrs [cell ("to",t)]
+ xmlAttrs [cell ("to",TL.toStrict $ Write.textTokens to)]
TokenPair (PairElem name attrs) ts ->
Seq.singleton $
TreeN (cell $ xmlLocalName name) $
sourcephile / git / doclang.git / commitdiff