From fc9c5cecd76ebfc99c47ebae2347e6eb9d500e5f Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sun, 24 Dec 2017 08:33:09 +0100 Subject: [PATCH 01/16] Add Plainify. --- Language/DTC/Write/HTML5.hs | 351 +++++++++-------------- Language/DTC/Write/Plain.hs | 222 ++++++++++++++ Language/DTC/Write/XML.hs | 16 +- Language/TCT/Write/HTML5.hs | 18 +- Language/TCT/Write/{Text.hs => Plain.hs} | 105 ++++--- Language/TCT/Write/XML.hs | 107 ++++--- Text/Blaze/DTC.hs | 8 +- Text/Blaze/Utils.hs | 26 +- Text/Blaze/XML.hs | 20 +- hdoc.cabal | 3 +- 10 files changed, 510 insertions(+), 366 deletions(-) create mode 100644 Language/DTC/Write/Plain.hs rename Language/TCT/Write/{Text.hs => Plain.hs} (67%) diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs index a7a1bda..2ee0a77 100644 --- a/Language/DTC/Write/HTML5.hs +++ b/Language/DTC/Write/HTML5.hs @@ -21,7 +21,7 @@ import Control.Category import Control.Monad import Data.Bool import Data.Char (Char) -import Data.Eq (Eq(..)) +import Data.Default.Class (Default(..)) import Data.Foldable (Foldable(..), concat) import Data.Function (($), const, flip, on) import Data.Functor (Functor(..), (<$>)) @@ -58,8 +58,9 @@ import Text.Blaze.Utils import Data.Locale hiding (localize, Index) import qualified Data.Locale as Locale -import Language.DTC.Document (Document) import Language.DTC.Write.XML () +import Language.DTC.Write.Plain (Plain, Plainify(..)) +import qualified Language.DTC.Write.Plain as Plain import qualified Language.DTC.Document as DTC import qualified Language.DTC.Anchor as Anchor @@ -75,22 +76,22 @@ data State = State { state_styles :: Map FilePath CSS , state_scripts :: Map FilePath Script - , state_localize :: MsgHtml5 -> Html5 , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs) , state_rrefs :: Anchor.Rrefs , state_figures :: Map Text (Map DTC.Pos DTC.Title) , state_references :: Map DTC.Ident DTC.About + , state_plainify :: Plain.State } -state :: State -state = State - { state_styles = mempty - , state_scripts = mempty - , state_localize = html5ify . show - , state_indexs = mempty - , state_rrefs = mempty - , state_figures = mempty - , state_references = mempty - } +instance Default State where + def = State + { state_styles = mempty + , state_scripts = mempty + , state_indexs = mempty + , state_rrefs = mempty + , state_figures = mempty + , state_references = mempty + , state_plainify = def + } type CSS = Text type Script = Text @@ -128,6 +129,8 @@ instance Html5ify Char where html5ify = html5ify . H.toMarkup instance Html5ify Text where html5ify = html5ify . H.toMarkup +instance Html5ify TL.Text where + html5ify = html5ify . H.toMarkup instance Html5ify String where html5ify = html5ify . H.toMarkup instance Html5ify H.Markup where @@ -138,11 +141,17 @@ instance Html5ify DTC.Para where html5ify = mapM_ html5ify instance Html5ify DTC.Ident where html5ify (DTC.Ident i) = html5ify i +instance Html5ify Int where + html5ify = html5ify . show +instance Html5ify DTC.Nat where + html5ify (DTC.Nat n) = html5ify n +instance Html5ify DTC.Nat1 where + html5ify (DTC.Nat1 n) = html5ify n html5Document :: - Localize ls Html5 MsgHtml5 => + Localize ls Plain Plain.L10n => Locales ls => - LocaleIn ls -> Document -> Html + LocaleIn ls -> DTC.Document -> Html html5Document locale DTC.Document{..} = do let Keys{..} = keys body let (body',state_rrefs,state_indexs) = @@ -155,27 +164,28 @@ html5Document locale DTC.Document{..} = do (terms,) $ TreeMap.intersection const state_irefs $ Anchor.irefsOfTerms terms + let state_plainify = def + { Plain.state_localize = Locale.localize locale } let (html5Body, State{state_styles,state_scripts}) = - runStateMarkup state + runStateMarkup def { state_indexs , state_rrefs , state_figures = keys_figure , state_references = keys_reference - } $ do - liftStateMarkup $ S.modify $ \s -> s{state_localize = Locale.localize locale} - html5ify body' + , state_plainify + } $ html5ify body' H.docType - H.html ! HA.lang (attrValue $ countryCode locale) $ do + H.html ! HA.lang (attrify $ countryCode locale) $ do H.head $ do H.meta ! HA.httpEquiv "Content-Type" ! HA.content "text/html; charset=UTF-8" whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts -> H.title $ - H.toMarkup $ plainify $ List.head ts + H.toMarkup $ Plain.text state_plainify $ List.head ts forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} -> - H.link ! HA.rel (attrValue rel) - ! HA.href (attrValue href) + H.link ! HA.rel (attrify rel) + ! HA.href (attrify href) H.meta ! HA.name "generator" ! HA.content "tct" let chapters = @@ -184,8 +194,8 @@ html5Document locale DTC.Document{..} = do _ -> Nothing forM_ chapters $ \DTC.Section{..} -> H.link ! HA.rel "Chapter" - ! HA.title (attrValue $ plainify title) - ! HA.href ("#"<>attrValue pos) + ! HA.title (attrify $ plainify title) + ! HA.href ("#"<>attrify pos) H.link ! HA.rel "stylesheet" ! HA.type_ "text/css" ! HA.href "style/dtc-html5.css" @@ -217,7 +227,7 @@ html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5 html5BodyKey z = \case DTC.Section{..} -> H.section ! HA.class_ "section" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do html5CommonAttrs attrs $ H.table ! HA.class_ "section-header" $$ H.tbody $$ @@ -241,31 +251,31 @@ html5BodyValue z = \case DTC.Block b -> html5ify b DTC.ToC{..} -> do H.nav ! HA.class_ "toc" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do H.span ! HA.class_ "toc-name" $$ - H.a ! HA.href (attrValue pos) $$ - html5ify MsgHTML5_Table_of_Contents + H.a ! HA.href (attrify pos) $$ + html5ify Plain.L10n_Table_of_Contents H.ul $$ forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $ html5ifyToC depth DTC.ToF{..} -> do H.nav ! HA.class_ "tof" - ! HA.id (attrValue pos) $$ + ! HA.id (attrify pos) $$ H.table ! HA.class_ "tof" $$ H.tbody $$ html5ifyToF types DTC.Figure{..} -> html5CommonAttrs attrs $ - H.div ! HA.class_ ("figure " <> attrValue ("figure-"<>type_)) - ! HA.id (attrValue pos) $$ do + H.div ! HA.class_ ("figure " <> attrify ("figure-"<>type_)) + ! HA.id (attrify pos) $$ do H.table ! HA.class_ "figure-caption" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "figure-number" $$ do - H.a ! HA.href ("#"<>attrValue pos) $$ do + H.a ! HA.href ("#"<>attrify pos) $$ do html5ify type_ html5ify $ DTC.posAncestors pos - html5ify $ MsgHTML5_Colon + html5ify $ Plain.L10n_Colon " " H.td ! HA.class_ "figure-name" $$ html5ify title @@ -275,15 +285,15 @@ html5BodyValue z = \case (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs let chars = Anchor.termsByChar allTerms H.div ! HA.class_ "index" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do H.nav ! HA.class_ "index-nav" $$ do forM_ (Map.keys chars) $ \char -> - H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$ + H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$ html5ify char H.dl ! HA.class_ "index-chars" $$ forM_ (Map.toList chars) $ \(char,terms) -> do H.dt $$ - let i = attrValue pos <> "." <> attrValue char in + let i = attrify pos <> "." <> attrify char in H.a ! HA.id i ! HA.href ("#"<>i) $$ html5ify char @@ -293,7 +303,7 @@ html5BodyValue z = \case H.dt $$ H.ul ! HA.class_ "index-aliases" $$ forM_ (List.take 1 aliases) $ \term -> - H.li ! HA.id (attrValue term) $$ + H.li ! HA.id (attrify term) $$ html5ify term H.dd $$ let anchs = @@ -306,12 +316,12 @@ html5BodyValue z = \case html5CommasDot $ (<$> anchs) $ \(term,DTC.Anchor{..}) -> H.a ! HA.class_ "index-iref" - ! HA.href ("#"<>attrValue (term,count)) $$ + ! HA.href ("#"<>attrify (term,count)) $$ html5ify $ DTC.posAncestors section DTC.References{..} -> html5CommonAttrs attrs $ H.div ! HA.class_ "references" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do H.table $$ forM_ refs html5ify @@ -363,7 +373,7 @@ html5ifyToF types = do forM_ (Map.toList figs) $ \(pos, (type_, title)) -> H.tr $$ do H.td ! HA.class_ "figure-number" $$ - H.a ! HA.href ("#"<>attrValue pos) $$ do + H.a ! HA.href ("#"<>attrify pos) $$ do html5ify type_ html5ify $ DTC.posAncestors pos H.td ! HA.class_ "figure-name" $$ @@ -376,18 +386,18 @@ instance Html5ify DTC.Block where DTC.Para{..} -> html5CommonAttrs attrs $ H.p ! HA.class_ "para" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do html5ify para DTC.OL{..} -> html5CommonAttrs attrs $ H.ol ! HA.class_ "ol" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do forM_ items $ \item -> H.li $$ html5ify item DTC.UL{..} -> html5CommonAttrs attrs $ H.ul ! HA.class_ "ul" - ! HA.id (attrValue pos) $$ do + ! HA.id (attrify pos) $$ do forM_ items $ \item -> H.li $$ html5ify item DTC.Comment t -> @@ -403,20 +413,43 @@ instance Html5ify DTC.Lines where DTC.B -> H.strong $$ html5ify ls DTC.Code -> H.code $$ html5ify ls DTC.Del -> H.del $$ html5ify ls - DTC.I -> H.i $$ html5ify ls + DTC.I -> do + i <- liftStateMarkup $ do + i <- S.gets $ Plain.state_italic . state_plainify + S.modify $ \s -> + s{state_plainify= + (state_plainify s){Plain.state_italic= + not i}} + return i + H.em ! HA.class_ (if i then "even" else "odd") $$ + html5ify ls + liftStateMarkup $ + S.modify $ \s -> + s{state_plainify= + (state_plainify s){Plain.state_italic=i}} DTC.Sub -> H.sub $$ html5ify ls DTC.Sup -> H.sup $$ html5ify ls DTC.SC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls DTC.U -> H.span ! HA.class_ "underline" $$ html5ify ls DTC.Note -> "" - DTC.Q -> + DTC.Q -> do + d <- liftStateMarkup $ do + d <- S.gets $ Plain.state_quote . state_plainify + S.modify $ \s -> s{state_plainify= + (state_plainify s){Plain.state_quote= + DTC.succNat d}} + return d H.span ! HA.class_ "q" $$ do - html5ify MsgHTML5_QuoteOpen - H.i $$ html5ify ls - html5ify MsgHTML5_QuoteClose + html5ify $ Plain.L10n_QuoteOpen d + html5ify $ TreeN DTC.I ls + html5ify $ Plain.L10n_QuoteClose d + liftStateMarkup $ + S.modify $ \s -> + s{state_plainify= + (state_plainify s){Plain.state_quote = d}} DTC.Eref{..} -> H.a ! HA.class_ "eref" - ! HA.href (attrValue href) $$ + ! HA.href (attrify href) $$ if null ls then html5ify $ DTC.unURL href else html5ify ls @@ -425,49 +458,52 @@ instance Html5ify DTC.Lines where Nothing -> html5ify ls Just DTC.Anchor{..} -> H.span ! HA.class_ "iref" - ! HA.id (attrValue (term,count)) $$ + ! HA.id (attrify (term,count)) $$ html5ify ls DTC.Ref{..} -> H.a ! HA.class_ "ref" - ! HA.href ("#"<>attrValue to) $$ + ! HA.href ("#"<>attrify to) $$ if null ls then html5ify to else html5ify ls DTC.Rref{..} -> do - when (not $ null ls) $ do - refs <- liftStateMarkup $ S.gets state_references - case Map.lookup to refs of - Nothing -> pure () - Just DTC.About{..} -> + refs <- liftStateMarkup $ S.gets state_references + case Map.lookup to refs of + Nothing -> do + "["::Html5 + H.span ! HA.class_ "rref-broken" $$ + html5ify to + "]" + Just DTC.About{..} -> do + when (not $ null ls) $ forM_ (List.take 1 titles) $ \(DTC.Title title) -> do html5ify $ TreeN DTC.Q $ case url of Nothing -> title Just u -> pure $ TreeN (DTC.Eref u) title " "::Html5 - Nothing -> html5ify ls - "["::Html5 - H.a ! HA.class_ "rref" - ! HA.href ("#rref."<>attrValue to) - ! HA.id ("rref."<>attrValue to<>maybe "" (\DTC.Anchor{..} -> "."<>attrValue count) anchor) $$ - html5ify to - "]" + "["::Html5 + H.a ! HA.class_ "rref" + ! HA.href ("#rref."<>attrify to) + ! HA.id ("rref."<>attrify to<>maybe "" (\DTC.Anchor{..} -> "."<>attrify count) anchor) $$ + html5ify to + "]" instance Html5ify DTC.URL where html5ify (DTC.URL url) = H.a ! HA.class_ "eref" - ! HA.href (attrValue url) $$ + ! HA.href (attrify url) $$ html5ify url -instance AttrValue DTC.Words where - attrValue term = - "iref" <> "." <> attrValue (Anchor.plainifyWords term) -instance AttrValue (DTC.Words,DTC.Nat1) where - attrValue (term,count) = +instance Attrify DTC.Words where + attrify term = + "iref" <> "." <> attrify (Anchor.plainifyWords term) +instance Attrify (DTC.Words,DTC.Nat1) where + attrify (term,count) = "iref" - <> "." <> attrValue (Anchor.plainifyWords term) - <> "." <> attrValue count + <> "." <> attrify (Anchor.plainifyWords term) + <> "." <> attrify count instance Html5ify DTC.Date where - html5ify = html5ify . MsgHTML5_Date + html5ify = html5ify . Plain.L10n_Date instance Html5ify DTC.About where html5ify DTC.About{..} = html5CommasDot $ concat $ @@ -484,13 +520,17 @@ instance Html5ify DTC.About where where html5Serie DTC.Serie{..} = do html5ify key - html5ify MsgHTML5_Colon + html5ify Plain.L10n_Colon html5ify name html5Entity DTC.Entity{url=mu, ..} = html5ify @DTC.Lines $ case () of - _ | not (Text.null email) -> TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $ pure $ Tree0 $ DTC.Plain name - _ | Just u <- mu -> TreeN (DTC.Eref u) $ pure $ Tree0 $ DTC.Plain name + _ | not (Text.null email) -> + TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $ + pure $ Tree0 $ DTC.Plain name + _ | Just u <- mu -> + TreeN (DTC.Eref u) $ + pure $ Tree0 $ DTC.Plain name _ -> Tree0 $ DTC.Plain name instance Html5ify DTC.Reference where html5ify DTC.Reference{id=id_, ..} = @@ -507,7 +547,7 @@ instance Html5ify DTC.Reference where html5CommasDot $ (<$> List.reverse anchs) $ \DTC.Anchor{..} -> H.a ! HA.class_ "reference-rref" - ! HA.href ("#rref."<>attrValue id_<>"."<>attrValue count) $$ + ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$ html5ify $ DTC.posAncestors section html5CommasDot :: [Html5] -> Html5 @@ -535,7 +575,7 @@ html5SectionNumber = go mempty case Seq.viewl next of Seq.EmptyL -> pure () a@(_n,rank) Seq.:< as -> do - H.a ! HA.href ("#"<>attrValue (prev Seq.|>a)) $$ + H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$ html5ify $ show rank when (not (null as) || null prev) $ do html5ify '.' @@ -543,7 +583,7 @@ html5SectionNumber = go mempty html5SectionRef :: DTC.PosPath -> Html5 html5SectionRef as = - H.a ! HA.href ("#"<>attrValue as) $$ + H.a ! HA.href ("#"<>attrify as) $$ html5ify as instance Html5ify DTC.PosPath where @@ -556,135 +596,28 @@ instance Html5ify DTC.PosPath where html5ify $ Text.intercalate "." $ Text.pack . show . snd <$> as +instance Html5ify Plain where + html5ify p = do + sp <- liftStateMarkup $ S.gets state_plainify + let (t,sp') = Plain.runPlain p sp + html5ify t + liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'} +instance Attrify Plain where + attrify p = + let (t,_) = Plain.runPlain p def in + attrify t -instance AttrValue DTC.PosPath where - attrValue = attrValue . plainify -instance AttrValue DTC.Pos where - attrValue = attrValue . DTC.posAncestors - --- * Class 'Plainify' -class Plainify a where - plainify :: a -> TL.Text -instance Plainify TL.Text where - plainify = id -instance Plainify Text where - plainify = TL.fromStrict -instance Plainify DTC.Para where - plainify = foldMap plainify -instance Plainify DTC.Lines where - plainify = \case - Tree0 v -> - case v of - DTC.BR -> "\n" - DTC.Plain p -> plainify p - TreeN k ls -> - case k of - DTC.B -> "*"<>plainify ls<>"*" - DTC.Code -> "`"<>plainify ls<>"`" - DTC.Del -> "-"<>plainify ls<>"-" - DTC.I -> "/"<>plainify ls<>"/" - DTC.Note -> "" - DTC.Q -> "« "<>plainify ls<>" »" - DTC.SC -> plainify ls - DTC.Sub -> plainify ls - DTC.Sup -> plainify ls - DTC.U -> "_"<>plainify ls<>"_" - DTC.Eref{..} -> plainify ls - DTC.Iref{..} -> plainify ls - DTC.Ref{..} -> plainify ls - DTC.Rref{..} -> plainify ls -instance Plainify DTC.Title where - plainify (DTC.Title t) = plainify t -instance Plainify DTC.PosPath where - plainify = - snd . foldl' (\(nParent,acc) (n,c) -> - (n, - (if TL.null acc - then acc - else acc <> ".") <> - TL.pack - (if n == nParent - then show c - else show n<>show c) - ) - ) - ("","") -instance Html5ify Int where - html5ify = html5ify . show -instance Html5ify DTC.Nat where - html5ify (DTC.Nat n) = html5ify n -instance Html5ify DTC.Nat1 where - html5ify (DTC.Nat1 n) = html5ify n +instance Attrify DTC.PosPath where + attrify = attrify . plainify +instance Attrify DTC.Pos where + attrify = attrify . DTC.posAncestors --- * Type 'MsgHtml5' -data MsgHtml5 - = MsgHTML5_Table_of_Contents - | MsgHTML5_Colon - | MsgHTML5_QuoteOpen - | MsgHTML5_QuoteClose - | MsgHTML5_Date DTC.Date - deriving (Show) -instance Html5ify MsgHtml5 where - html5ify msg = do - loc <- liftStateMarkup $ S.gets state_localize - loc msg -instance LocalizeIn FR Html5 MsgHtml5 where - localizeIn _ = \case - MsgHTML5_Table_of_Contents -> "Sommaire" - MsgHTML5_Colon -> " :" - MsgHTML5_QuoteOpen -> "« " - MsgHTML5_QuoteClose -> " »" - MsgHTML5_Date DTC.Date{..} -> - sequence_ $ - List.intersperse " " $ - concat - [ maybe [] (pure . html5ify) day - , case month of - Nothing -> [] - Just (DTC.Nat1 m) -> - case m of - 1 -> pure "janvier" - 2 -> pure "février" - 3 -> pure "mars" - 4 -> pure "avril" - 5 -> pure "mai" - 6 -> pure "juin" - 7 -> pure "juillet" - 8 -> pure "août" - 9 -> pure "septembre" - 10 -> pure "octobre" - 11 -> pure "novembre" - 12 -> pure "décembre" - _ -> [] - , [html5ify year] - ] -instance LocalizeIn EN Html5 MsgHtml5 where - localizeIn _ = \case - MsgHTML5_Table_of_Contents -> "Summary" - MsgHTML5_Colon -> ":" - MsgHTML5_QuoteOpen -> "“" - MsgHTML5_QuoteClose -> "”" - MsgHTML5_Date DTC.Date{..} -> - sequence_ $ - List.intersperse " " $ - concat - [ maybe [] (pure . html5ify) day - , case month of - Nothing -> [] - Just (DTC.Nat1 m) -> - case m of - 1 -> pure "January" - 2 -> pure "February" - 3 -> pure "March" - 4 -> pure "April" - 5 -> pure "May" - 6 -> pure "June" - 7 -> pure "July" - 8 -> pure "August" - 9 -> pure "September" - 10 -> pure "October" - 11 -> pure "November" - 12 -> pure "December" - _ -> [] - , [html5ify year] - ] +-- * Type 'L10n' +instance Html5ify Plain.L10n where + html5ify = html5ify . plainify +instance Localize ls Plain Plain.L10n => Localize ls Html5 Plain.L10n where + localize loc a = html5ify (Locale.localize loc a::Plain) +instance LocalizeIn FR Html5 Plain.L10n where + localizeIn loc = html5ify @Plain . localizeIn loc +instance LocalizeIn EN Html5 Plain.L10n where + localizeIn loc = html5ify @Plain . localizeIn loc diff --git a/Language/DTC/Write/Plain.hs b/Language/DTC/Write/Plain.hs new file mode 100644 index 0000000..5481086 --- /dev/null +++ b/Language/DTC/Write/Plain.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.DTC.Write.Plain where + +import Control.Applicative (Applicative(..), liftA2) +import Control.Category +import Control.Monad +import Data.Bool +import Data.Default.Class (Default(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..), concat) +import Data.Function (($)) +import Data.Int (Int) +import Data.Maybe (Maybe(..), maybe) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String) +import Data.Text (Text) +import Data.TreeSeq.Strict (Tree(..)) +import Data.Tuple (fst, snd) +import Data.String (IsString(..)) +import Prelude (mod) +import Text.Show (Show(..)) +import qualified Control.Monad.Trans.State as S +import qualified Data.List as List +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB + +import Data.Locale hiding (localize, Index) + +import Language.DTC.Write.XML () +import qualified Language.DTC.Document as DTC + +-- * Type 'Plain' +type Plain = S.State State TLB.Builder + +runPlain :: Plain -> State -> (TL.Text, State) +runPlain p s = + let (b,s') = S.runState p s in + (TLB.toLazyText b, s') + +text :: Plainify a => State -> a -> TL.Text +text st a = fst $ runPlain (plainify a) st + +instance IsString Plain where + fromString = return . fromString +instance Semigroup Plain where + (<>) = liftA2 (<>) +instance Monoid Plain where + mempty = return "" + mappend = (<>) + +-- ** Type 'State' +data State + = State + { state_localize :: L10n -> Plain + , state_italic :: Bool + , state_quote :: DTC.Nat + } +instance Default State where + def = State + { state_localize = plainify . show + , state_italic = False + , state_quote = DTC.Nat 0 + } + + +-- * Class 'Plainify' +class Plainify a where + plainify :: a -> Plain +instance Plainify String where + plainify = return . TLB.fromString +instance Plainify Text where + plainify = return . TLB.fromText +instance Plainify TL.Text where + plainify = return . TLB.fromLazyText +instance Plainify DTC.Para where + plainify = foldMap plainify +instance Plainify DTC.Lines where + plainify = \case + Tree0 v -> + case v of + DTC.BR -> "\n" + DTC.Plain p -> plainify p + TreeN k ls -> + case k of + DTC.B -> "*"<>plainify ls<>"*" + DTC.Code -> "`"<>plainify ls<>"`" + DTC.Del -> "-"<>plainify ls<>"-" + DTC.I -> "/"<>plainify ls<>"/" + DTC.Note -> "" + DTC.Q -> + let depth = DTC.Nat 0 in + plainify (L10n_QuoteOpen{..}) <> + plainify ls <> + plainify (L10n_QuoteClose{..}) + DTC.SC -> plainify ls + DTC.Sub -> plainify ls + DTC.Sup -> plainify ls + DTC.U -> "_"<>plainify ls<>"_" + DTC.Eref{..} -> plainify ls + DTC.Iref{..} -> plainify ls + DTC.Ref{..} -> plainify ls + DTC.Rref{..} -> plainify ls +instance Plainify DTC.Title where + plainify (DTC.Title t) = plainify t +instance Plainify DTC.PosPath where + plainify = + plainify . + snd . foldl' (\(nParent,acc) (n,c) -> + (n, + (if TL.null acc then acc else acc <> ".") <> + (if n == nParent + then TL.pack (show c) + else TL.pack (show n)<>TL.pack (show c)) + ) + ) + ("","") +instance Plainify DTC.XmlName where + plainify = plainify . show +instance Plainify Int where + plainify = plainify . show +instance Plainify DTC.Nat where + plainify (DTC.Nat n) = plainify n +instance Plainify DTC.Nat1 where + plainify (DTC.Nat1 n) = plainify n + +-- * Type 'L10n' +data L10n + = L10n_Table_of_Contents + | L10n_Colon + | L10n_QuoteOpen {depth :: DTC.Nat} + | L10n_QuoteClose {depth :: DTC.Nat} + | L10n_Date DTC.Date + deriving (Show) +instance Plainify L10n where + plainify msg = do + loc <- S.gets state_localize + loc msg +instance LocalizeIn FR Plain L10n where + localizeIn _ = \case + L10n_Table_of_Contents -> "Sommaire" + L10n_Colon -> " :" + L10n_QuoteOpen{..} -> + case DTC.unNat depth `mod` 3 of + 0 -> "« " + 1 -> "“" + _ -> "‟" + L10n_QuoteClose{..} -> + case DTC.unNat depth `mod` 3 of + 0 -> " »" + 1 -> "”" + _ -> "„" + L10n_Date DTC.Date{..} -> + mconcat $ + List.intersperse " " $ + concat + [ maybe [] (pure . plainify) day + , case month of + Nothing -> [] + Just (DTC.Nat1 m) -> + case m of + 1 -> pure "janvier" + 2 -> pure "février" + 3 -> pure "mars" + 4 -> pure "avril" + 5 -> pure "mai" + 6 -> pure "juin" + 7 -> pure "juillet" + 8 -> pure "août" + 9 -> pure "septembre" + 10 -> pure "octobre" + 11 -> pure "novembre" + 12 -> pure "décembre" + _ -> [] + , [plainify year] + ] +instance LocalizeIn EN Plain L10n where + localizeIn _ = \case + L10n_Table_of_Contents -> "Summary" + L10n_Colon -> ":" + L10n_QuoteOpen{..} -> + case DTC.unNat depth `mod` 3 of + 0 -> "“" + 1 -> "« " + _ -> "‟" + L10n_QuoteClose{..} -> + case DTC.unNat depth `mod` 3 of + 0 -> "”" + 1 -> " »" + _ -> "„" + L10n_Date DTC.Date{..} -> + mconcat $ + List.intersperse " " $ + concat + [ maybe [] (pure . plainify) day + , case month of + Nothing -> [] + Just (DTC.Nat1 m) -> + case m of + 1 -> pure "January" + 2 -> pure "February" + 3 -> pure "March" + 4 -> pure "April" + 5 -> pure "May" + 6 -> pure "June" + 7 -> pure "July" + 8 -> pure "August" + 9 -> pure "September" + 10 -> pure "October" + 11 -> pure "November" + 12 -> pure "December" + _ -> [] + , [plainify year] + ] diff --git a/Language/DTC/Write/XML.hs b/Language/DTC/Write/XML.hs index 76b10cd..0c43c1c 100644 --- a/Language/DTC/Write/XML.hs +++ b/Language/DTC/Write/XML.hs @@ -83,7 +83,7 @@ xmlBodyValue = \case DTC.Figure{..} -> xmlCommonAttrs attrs $ XML.figure - ! XA.type_ (attrValue type_) $ do + ! XA.type_ (attrify type_) $ do xmlTitle title xmlBlocks blocks DTC.References{..} -> @@ -105,7 +105,7 @@ xmlAbout DTC.About{..} = do xmlInclude :: DTC.Include -> XML xmlInclude DTC.Include{..} = XML.include True - ! XA.href (attrValue href) + ! XA.href (attrify href) xmlKeyword :: Text -> XML xmlKeyword = XML.keyword . xmlText @@ -116,7 +116,7 @@ xmlVersion (MayText t) = XML.version $ xmlText t xmlDate :: DTC.Date -> XML xmlDate DTC.Date{..} = XML.date - ! XA.year (attrValue year) + ! XA.year (attrify year) !?? mayAttr XA.month month !?? mayAttr XA.day day @@ -148,7 +148,7 @@ xmlAlias :: DTC.Alias -> XML xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id xmlId :: DTC.Ident -> B.Attribute -xmlId (DTC.Ident i) = XA.id $ attrValue i +xmlId (DTC.Ident i) = XA.id $ attrify i xmlBlocks :: DTC.Blocks -> XML xmlBlocks = (`forM_` xmlBlock) @@ -200,10 +200,10 @@ xmlLine = \case DTC.Sub -> XML.sub $ xmlPara ls DTC.Sup -> XML.sup $ xmlPara ls DTC.U -> XML.u $ xmlPara ls - DTC.Eref to -> XML.eref ! XA.to (attrValue to) $ xmlPara ls - DTC.Iref{..} -> XML.iref ! XA.term (attrValue $ plainifyWords term) $ xmlPara ls - DTC.Ref to -> XML.ref ! XA.to (attrValue to) $ xmlPara ls - DTC.Rref{..} -> XML.rref ! XA.to (attrValue to) $ xmlPara ls + DTC.Eref to -> XML.eref ! XA.to (attrify to) $ xmlPara ls + DTC.Iref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlPara ls + DTC.Ref to -> XML.ref ! XA.to (attrify to) $ xmlPara ls + DTC.Rref{..} -> XML.rref ! XA.to (attrify to) $ xmlPara ls xmlReference :: DTC.Reference -> XML xmlReference DTC.Reference{..} = diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index 511596d..8c29b05 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -31,7 +31,7 @@ import qualified Text.Blaze.Html5.Attributes as HA import Text.Blaze.Utils import Language.TCT -import Language.TCT.Write.Text +import Language.TCT.Write.Plain html5Document :: TCTs -> Html html5Document tct = do @@ -42,7 +42,7 @@ html5Document tct = do ! HA.content "text/html; charset=UTF-8" whenJust (tokensTitle tct) $ \ts -> H.title $ H.toMarkup $ L.head $ - TL.lines (textTokens ts) <> [""] + TL.lines (plainifyTokens ts) <> [""] -- link ! rel "Chapter" ! title "SomeTitle"> H.link ! HA.rel "stylesheet" ! HA.type_ "text/css" @@ -88,7 +88,7 @@ html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do h 4 = H.h4 h 5 = H.h5 h 6 = H.h6 - h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n) + h n | n > 0 = H.span ! HA.class_ ("h h"<>attrify n) h _ = undefined html5TreeCell (Tree0 (posEnd,toks)) = case Seq.viewl toks of @@ -103,7 +103,7 @@ html5IndentCell (Pos lineLast colLast,Pos line col) | lineLast < line = do forM_ [lineLast+1..line] $ \lnum -> do H.toMarkup '\n' - H.a ! HA.id ("line-"<>attrValue lnum) $ return () + H.a ! HA.id ("line-"<>attrify lnum) $ return () H.toMarkup $ Text.replicate (col - 1) " " | lineLast == line && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " " @@ -121,7 +121,7 @@ html5CellKey (Cell _pos _posEnd key) ts = do KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash" KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash" KeyLower name attrs -> do - H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do + H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $ do H.span ! HA.class_ "key-mark" $ H.toMarkup '<' H.span ! HA.class_ "key-name" $ H.toMarkup name html5Attrs attrs @@ -130,7 +130,7 @@ html5CellKey (Cell _pos _posEnd key) ts = do html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html html5Key markBegin whmb name whn markEnd whme cl = do -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1) - H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do + H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $ do when (markBegin/="") $ H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin H.toMarkup whmb @@ -160,7 +160,7 @@ html5IndentToken toks = let lnums = H.toMarkup : [ \line -> do H.toMarkup '\n' - H.a ! HA.id ("line-"<>attrValue lnum) $ return () + H.a ! HA.id ("line-"<>attrify lnum) $ return () H.toMarkup indent H.toMarkup line | lnum <- [lin+1..] @@ -175,12 +175,12 @@ html5IndentToken toks = TokenEscape c -> return $ H.toMarkup ['\\',c] TokenLink lnk -> return $ - H.a ! HA.href (attrValue lnk) $ + H.a ! HA.href (attrify lnk) $ H.toMarkup lnk TokenPair (PairElem name attrs) ts -> do h <- goTokens ts return $ do - let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name] + let cl = mconcat ["pair-PairElem", " pair-elem-", attrify name] H.span ! HA.class_ cl $ do whenMarkup o $ H.span ! HA.class_ "pair-open" $ o whenMarkup h $ H.span ! HA.class_ "pair-content" $ h diff --git a/Language/TCT/Write/Text.hs b/Language/TCT/Write/Plain.hs similarity index 67% rename from Language/TCT/Write/Text.hs rename to Language/TCT/Write/Plain.hs index 9f89d5c..703e48a 100644 --- a/Language/TCT/Write/Text.hs +++ b/Language/TCT/Write/Plain.hs @@ -2,10 +2,11 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Render a TCT file in plain Text. -module Language.TCT.Write.Text where +module Language.TCT.Write.Plain where import Control.Monad (Monad(..), mapM) import Data.Bool +import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) @@ -33,20 +34,18 @@ import Language.TCT.Elem tl :: Text -> TL.Text tl = TL.fromStrict --- * Type 'Config_Text' -data Config_Text - = Config_Text - { config_text_escape :: Bool +-- * Type 'Inh' +data Inh + = Inh + { inh_escape :: Bool } deriving (Eq, Show) - -config_text :: Config_Text -config_text = - Config_Text - { config_text_escape = True +instance Default Inh where + def = Inh + { inh_escape = True } -text :: Config_Text -> Trees (Cell Key) Tokens -> TL.Text -text cfg = textTreesCell cfg . treePosLastCell +plainify :: Inh -> Trees (Cell Key) Tokens -> TL.Text +plainify inh = plainifyTreesCell inh . treePosLastCell treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a) treeRackUpLeft t = go t @@ -88,31 +87,31 @@ treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1) int64 :: Integral i => i -> Int64 int64 = fromInteger . toInteger -textTreeCell :: - Config_Text -> +plainifyTreeCell :: + Inh -> Tree (Pos,Cell Key) (Pos,Tokens) -> TL.Text -textTreeCell cfg (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = - textIndentCell (posEnd,pos) <> +plainifyTreeCell inh (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = + plainifyIndentCell (posEnd,pos) <> TL.replicate (int64 lvl) "#" <> " " <> (case Seq.viewl ts of Tree0 (_,title) :< _ -> - textIndentToken cfg title + plainifyIndentToken inh title _ -> "") <> - textTreesCell cfg + plainifyTreesCell inh (case Seq.viewl ts of Tree0{} :< ts' -> ts' _ -> ts) -textTreeCell cfg (Tree0 (posEnd,toks)) = +plainifyTreeCell inh (Tree0 (posEnd,toks)) = case Seq.viewl toks of - EmptyL -> textIndentToken cfg toks - t0:<_ -> textIndentCell (posEnd,posCell t0) <> textIndentToken cfg toks -textTreeCell cfg (TreeN (posEnd,cell@(Cell pos _ _)) cs) = - textIndentCell (posEnd,pos) <> - textCellKey cfg cell cs - -textIndentCell :: (Pos,Pos) -> TL.Text -textIndentCell (Pos lineLast colLast,Pos line col) + EmptyL -> plainifyIndentToken inh toks + t0:<_ -> plainifyIndentCell (posEnd,posCell t0) <> plainifyIndentToken inh toks +plainifyTreeCell inh (TreeN (posEnd,cell@(Cell pos _ _)) cs) = + plainifyIndentCell (posEnd,pos) <> + plainifyCellKey inh cell cs + +plainifyIndentCell :: (Pos,Pos) -> TL.Text +plainifyIndentCell (Pos lineLast colLast,Pos line col) | lineLast < line = TL.replicate (int64 $ line - (lineLast+1)) "\n" <> TL.replicate (int64 $ col - 1) " " @@ -120,12 +119,12 @@ textIndentCell (Pos lineLast colLast,Pos line col) TL.replicate (int64 $ col - colLast) " " | otherwise = undefined -textCellKey :: - Config_Text -> +plainifyCellKey :: + Inh -> Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> TL.Text -textCellKey cfg (Cell _pos _posEnd key) cells = do +plainifyCellKey inh (Cell _pos _posEnd key) cells = do case key of KeyColon n wh -> textKey n wh ":" KeyGreat n wh -> textKey n wh ">" @@ -134,27 +133,27 @@ textCellKey cfg (Cell _pos _posEnd key) cells = do KeyDash -> textKey "" "" "- " KeyDashDash -> textKey "" "" "-- " KeyLower name attrs -> - "<" <> tl name <> textAttrs attrs <> - textTreesCell cfg cells + "<" <> tl name <> plainifyAttrs attrs <> + plainifyTreesCell inh cells KeySection{} -> undefined KeyDotSlash p -> "./" <> TL.pack p <> - textTreesCell cfg cells + plainifyTreesCell inh cells where textKey :: Text -> White -> TL.Text -> TL.Text textKey name wh mark = tl name <> tl wh <> mark <> - textTreesCell cfg cells + plainifyTreesCell inh cells -textTreesCell :: - Config_Text -> +plainifyTreesCell :: + Inh -> Trees (Pos,Cell Key) (Pos,Tokens) -> TL.Text -textTreesCell cfg = foldMap (textTreeCell cfg) +plainifyTreesCell inh = foldMap (plainifyTreeCell inh) -textIndentToken :: Config_Text -> Tokens -> TL.Text -textIndentToken _cfg (Seq.viewl -> EmptyL) = "" -textIndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) = +plainifyIndentToken :: Inh -> Tokens -> TL.Text +plainifyIndentToken _cfg (Seq.viewl -> EmptyL) = "" +plainifyIndentToken inh toks@(Seq.viewl -> Cell pos _ _ :< _) = goTokens toks `S.evalState` linePos pos where indent = TL.replicate (int64 $ columnPos pos - 1) " " @@ -172,7 +171,7 @@ textIndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) = TokenTag v -> return $ "#"<>tl v TokenEscape c -> return $ - if config_text_escape cfg + if inh_escape inh then tl $ Text.pack ['\\',c] else TL.singleton c TokenLink lnk -> return $ tl lnk @@ -185,11 +184,11 @@ textIndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) = ts' <- go`mapM`ts return $ foldr (<>) mempty ts' -textAttrs :: Attrs -> TL.Text -textAttrs = foldMap textAttr +plainifyAttrs :: Attrs -> TL.Text +plainifyAttrs = foldMap plainifyAttr -textAttr :: (Text,Attr) -> TL.Text -textAttr (attr_white,Attr{..}) = +plainifyAttr :: (Text,Attr) -> TL.Text +plainifyAttr (attr_white,Attr{..}) = mconcat $ tl <$> [ attr_white , attr_name @@ -198,13 +197,13 @@ textAttr (attr_white,Attr{..}) = , attr_close ] -textToken :: Token -> TL.Text -textToken (TokenPlain txt) = tl txt -textToken (TokenTag v) = "#"<>tl v -textToken (TokenEscape c) = TL.singleton c -- tl $ Text.pack ['\\',c] -textToken (TokenLink lnk) = tl lnk -textToken (TokenPair grp t) = tl o<>textTokens t<>tl c +plainifyToken :: Token -> TL.Text +plainifyToken (TokenPlain txt) = tl txt +plainifyToken (TokenTag v) = "#"<>tl v +plainifyToken (TokenEscape c) = TL.singleton c -- tl $ Text.pack ['\\',c] +plainifyToken (TokenLink lnk) = tl lnk +plainifyToken (TokenPair grp t) = tl o<>plainifyTokens t<>tl c where (o,c) = pairBorders grp t -textTokens :: Tokens -> TL.Text -textTokens ts = foldMap (textToken . unCell) ts +plainifyTokens :: Tokens -> TL.Text +plainifyTokens ts = foldMap (plainifyToken . unCell) ts diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index aaef1c2..79e170f 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -9,6 +9,7 @@ module Language.TCT.Write.XML where import Control.Arrow (first) import Control.Monad (Monad(..), (=<<)) import Data.Bool +import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (null, foldl', any) import Data.Function (($), (.), id) @@ -27,7 +28,7 @@ import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TL -import qualified Language.TCT.Write.Text as Write +import qualified Language.TCT.Write.Plain as Plain import qualified System.FilePath as FP import Text.Blaze.XML () @@ -35,19 +36,19 @@ import Language.TCT hiding (Parser) import Language.XML import qualified Data.TreeSeq.Strict as TreeSeq --- * Type 'InhXml' -data InhXml - = InhXml - { inhXml_figure :: Bool - , inhXml_tree0 :: [Pos -> XMLs -> XML] - , inhXml_titles :: Seq Tokens - } -inhXml :: InhXml -inhXml = InhXml - { inhXml_figure = False - , inhXml_tree0 = [] - , inhXml_titles = mempty +-- * Type 'Inh' +data Inh + = Inh + { inh_figure :: Bool + , inh_tree0 :: [Pos -> XMLs -> XML] + , inh_titles :: Seq Tokens } +instance Default Inh where + def = Inh + { inh_figure = False + , inh_tree0 = [] + , inh_titles = mempty + } mimetype :: Text -> Maybe Text mimetype "hs" = Just "text/x-haskell" @@ -80,19 +81,19 @@ xmlDocument trees = Just{} -> vs' Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs' in - xmlTCTs inhXml - { inhXml_titles = titles - , inhXml_figure = True - , inhXml_tree0 = List.repeat xmlPara + xmlTCTs def + { inh_titles = titles + , inh_figure = True + , inh_tree0 = List.repeat xmlPara } vs'' <> - xmlTCTs inhXml ts - _ -> xmlTCTs inhXml trees - _ -> xmlTCTs inhXml trees + xmlTCTs def ts + _ -> xmlTCTs def trees + _ -> xmlTCTs def trees -xmlTCTs :: InhXml -> TCTs -> XMLs +xmlTCTs :: Inh -> TCTs -> XMLs xmlTCTs inh_orig = go inh_orig where - go :: InhXml -> TCTs -> XMLs + go :: Inh -> TCTs -> XMLs go inh trees = case Seq.viewl trees of TreeN (Cell bp ep (KeyBar n _)) _ :< _ @@ -101,7 +102,7 @@ xmlTCTs inh_orig = go inh_orig (<| go inh ts) $ TreeN (Cell bp ep "artwork") $ maybe id (\v -> (Tree0 (Cell bp ep (XmlAttr "type" v)) <|)) (mimetype n) $ - body >>= xmlTCT inh{inhXml_tree0=[]} + body >>= xmlTCT inh{inh_tree0=[]} TreeN key@(unCell -> KeyColon n _) cs :< ts | (cs',ts') <- spanlKeyColon n ts @@ -119,28 +120,28 @@ xmlTCTs inh_orig = go inh_orig , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ul -> (<| go inh ts) $ TreeN (Cell bp ep "ul") $ - ul >>= xmlTCT inh{inhXml_tree0=List.repeat xmlPara} + ul >>= xmlTCT inh{inh_tree0=List.repeat xmlPara} _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trees , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ol -> (<| go inh ts) $ TreeN (Cell bp ep "ol") $ - ol >>= xmlTCT inh{inhXml_tree0=List.repeat xmlPara} + ol >>= xmlTCT inh{inh_tree0=List.repeat xmlPara} t@(Tree0 toks) :< ts | isTokenElem toks -> xmlTCT inh_orig t <> go inh ts t@(Tree0 toks) :< ts -> - case inhXml_tree0 inh of + case inh_tree0 inh of [] -> xmlTCT inh_orig t <> - go inh{inhXml_tree0=[]} ts + go inh{inh_tree0=[]} ts x:xs -> case Seq.viewl toks of - EmptyL -> go inh{inhXml_tree0=xs} ts + EmptyL -> go inh{inh_tree0=xs} ts Cell bp _ep _ :< _ -> - (<| go inh{inhXml_tree0=xs} ts) $ + (<| go inh{inh_tree0=xs} ts) $ x bp $ xmlTCT inh_orig t @@ -150,14 +151,14 @@ xmlTCTs inh_orig = go inh_orig _ -> mempty -xmlTCT :: InhXml -> TCT -> XMLs +xmlTCT :: Inh -> TCT -> XMLs xmlTCT inh tr = case tr of TreeN (Cell bp ep KeySection{}) ts -> let (attrs,body) = partitionAttributesChildren ts in let inh' = inh - { inhXml_tree0 = xmlTitle : List.repeat xmlPara - , inhXml_figure = True + { inh_tree0 = xmlTitle : List.repeat xmlPara + , inh_figure = True } in Seq.singleton $ TreeN (Cell bp ep "section") $ @@ -166,7 +167,7 @@ xmlTCT inh tr = TreeN key@(Cell bp ep (KeyColon kn _)) ts -> let (attrs,body) = partitionAttributesChildren ts in - let inh' = inh { inhXml_tree0 = + let inh' = inh { inh_tree0 = case kn of "about" -> xmlTitle : xmlTitle : List.repeat xmlPara "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara @@ -177,13 +178,13 @@ xmlTCT inh tr = case () of _ | kn == "about" -> xmlAbout inh' key attrs body - _ | inhXml_figure inh && not (kn`List.elem`elems) -> + _ | inh_figure inh && not (kn`List.elem`elems) -> Seq.singleton $ TreeN (Cell bp ep "figure") $ xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <> case toList body of - [Tree0{}] -> xmlTCTs inh'{inhXml_tree0 = List.repeat xmlPara} body - _ -> xmlTCTs inh'{inhXml_tree0 = xmlTitle : List.repeat xmlPara} body + [Tree0{}] -> xmlTCTs inh'{inh_tree0 = List.repeat xmlPara} body + _ -> xmlTCTs inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body _ -> Seq.singleton $ xmlKey inh' key attrs body @@ -192,21 +193,21 @@ xmlTCT inh tr = Tree0 ts -> xmlTokens ts xmlAbout :: - InhXml -> + Inh -> Cell Key -> Seq (Cell (XmlName, Text)) -> TCTs -> XMLs xmlAbout inh key attrs body = Seq.singleton $ xmlKey inh key attrs $ - case Seq.viewl (inhXml_titles inh) of + case Seq.viewl (inh_titles inh) of (Seq.viewl -> Cell bt _et _ :< _) :< _ -> - ((<$> inhXml_titles inh) $ \title -> + ((<$> inh_titles inh) $ \title -> TreeN (Cell bt bt $ KeyColon "title" "") $ Seq.singleton $ Tree0 title) <> body _ -> body -xmlKey :: InhXml -> Cell Key -> Seq (Cell (XmlName, Text)) -> TCTs -> XML +xmlKey :: Inh -> Cell Key -> Seq (Cell (XmlName, Text)) -> TCTs -> XML xmlKey inh (Cell bp ep key) attrs ts = case key of KeyColon n _wh -> d_key n @@ -219,13 +220,13 @@ xmlKey inh (Cell bp ep key) attrs ts = where com :: TL.Text com = - Write.text Write.config_text $ + Plain.plainify def $ TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> ts KeyLower n as -> TreeN (cell "artwork") $ xmlTCTs inh ts KeyBrackets ident -> - let inh' = inh{inhXml_figure = False} in + let inh' = inh{inh_figure = False} in let (attrs',body) = partitionAttributesChildren ts in TreeN (cell "reference") $ xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <> @@ -255,7 +256,7 @@ xmlTokens tok = goTokens tok TokenLink lnk -> Seq.singleton $ TreeN (cell "eref") $ xmlAttrs [cell ("to",lnk)] - TokenPair PairBracket ts | to <- Write.textTokens ts + TokenPair PairBracket ts | to <- Plain.plainifyTokens ts , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> Seq.singleton $ TreeN (cell "rref") $ @@ -283,7 +284,7 @@ xmlTokens tok = goTokens tok TokenPair PairHash to -> Seq.singleton $ TreeN (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Write.textTokens to)] + xmlAttrs [cell ("to",TL.toStrict $ Plain.plainifyTokens to)] TokenPair (PairElem name attrs) ts -> Seq.singleton $ TreeN (cell $ xmlLocalName name) $ @@ -312,7 +313,7 @@ xmlTokens tok = goTokens tok goTokens paren _ -> TreeN (Cell bp eb "rref") $ - xmlAttrs [Cell bb eb ("to",TL.toStrict $ Write.textTokens bracket)] <> + xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.plainifyTokens bracket)] <> goTokens paren t :< ts -> go t `unionXml` goTokens ts Seq.EmptyL -> mempty @@ -404,7 +405,7 @@ spanlTokens = getAttrId :: TCTs -> Text getAttrId ts = case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of - Just (Tree0 toks) -> TL.toStrict $ Write.textTokens toks + Just (Tree0 toks) -> TL.toStrict $ Plain.plainifyTokens toks _ -> "" setXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text)) @@ -422,18 +423,6 @@ defXmlAttr a@(unCell -> (k, _v)) as = xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs xmlAttrs = ((\(Cell bp ep (n,v)) -> Tree0 (Cell bp ep $ XmlAttr n v)) <$>) -{- -xmlAttr :: XmlAttrs -> (Text,Attr) -> XmlAttrs -xmlAttr acc (_,Attr{..}) = Map.insert (xmlLocalName attr_name) attr_value acc - -- TODO: conflict --} - -{- -d_Attributes :: XmlAttrs -> DTC -> DTC -d_Attributes = flip $ Map.foldrWithKey $ \n v -> - B.AddCustomAttribute (B.Text n) (B.Text v) --} - partitionAttributesChildren :: TCTs -> (Seq (Cell (XmlName, Text)), TCTs) partitionAttributesChildren ts = (attrs,cs) where @@ -446,7 +435,7 @@ partitionAttributesChildren ts = (attrs,cs) Cell bp ep (xmlLocalName n, v) where v = TL.toStrict $ - Write.text Write.config_text{Write.config_text_escape = False} $ + Plain.plainify def{Plain.inh_escape = False} $ TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> a _ -> undefined diff --git a/Text/Blaze/DTC.hs b/Text/Blaze/DTC.hs index 327efec..4ba9251 100644 --- a/Text/Blaze/DTC.hs +++ b/Text/Blaze/DTC.hs @@ -17,25 +17,25 @@ xmlModel :: Text -> DTC xmlModel rnc = Leaf "xml-model" "\n" () ! attribute "type" " type=\"" "application/relax-ng-compact-syntax" - ! attribute "href" " href=\"" (attrValue rnc) + ! attribute "href" " href=\"" (attrify rnc) xmlStylesheet :: Text -> DTC xmlStylesheet xsl = Leaf "xml-stylesheet" "\n" () ! attribute "type" " type=\"" "text/xsl" - ! attribute "href" " href=\"" (attrValue xsl) + ! attribute "href" " href=\"" (attrify xsl) html5Stylesheet :: Text -> DTC html5Stylesheet xsl = Leaf "html5-stylesheet" "\n" () ! attribute "type" " type=\"" "text/xsl" - ! attribute "href" " href=\"" (attrValue xsl) + ! attribute "href" " href=\"" (attrify xsl) atomStylesheet :: Text -> DTC atomStylesheet xsl = Leaf "atom-stylesheet" "\n" () ! attribute "type" " type=\"" "text/xsl" - ! attribute "href" " href=\"" (attrValue xsl) + ! attribute "href" " href=\"" (attrify xsl) about :: DTC -> DTC about = Parent "about" "" diff --git a/Text/Blaze/Utils.hs b/Text/Blaze/Utils.hs index 9423396..51549a9 100644 --- a/Text/Blaze/Utils.hs +++ b/Text/Blaze/Utils.hs @@ -60,19 +60,19 @@ whenText t f = f t instance Semigroup H.AttributeValue where (<>) = mappend --- * Class 'AttrValue' -class AttrValue a where - attrValue :: a -> H.AttributeValue -instance AttrValue Char where - attrValue = fromString . pure -instance AttrValue Text where - attrValue = fromString . Text.unpack -instance AttrValue TL.Text where - attrValue = fromString . TL.unpack -instance AttrValue Int where - attrValue = fromString . show -instance AttrValue [Char] where - attrValue = fromString +-- * Class 'Attrify' +class Attrify a where + attrify :: a -> H.AttributeValue +instance Attrify Char where + attrify = fromString . pure +instance Attrify Text where + attrify = fromString . Text.unpack +instance Attrify TL.Text where + attrify = fromString . TL.unpack +instance Attrify Int where + attrify = fromString . show +instance Attrify [Char] where + attrify = fromString -- * Class 'MayAttr' class MayAttr a where diff --git a/Text/Blaze/XML.hs b/Text/Blaze/XML.hs index a2297b1..5c8570d 100644 --- a/Text/Blaze/XML.hs +++ b/Text/Blaze/XML.hs @@ -8,16 +8,16 @@ import Text.Blaze.Utils -- * Type 'XML' type XML = Markup -instance AttrValue URL where - attrValue (URL a) = attrValue a -instance AttrValue Path where - attrValue (Path a) = attrValue a -instance AttrValue Ident where - attrValue (Ident a) = attrValue a -instance AttrValue Nat where - attrValue (Nat a) = attrValue a -instance AttrValue Nat1 where - attrValue (Nat1 a) = attrValue a +instance Attrify URL where + attrify (URL a) = attrify a +instance Attrify Path where + attrify (Path a) = attrify a +instance Attrify Ident where + attrify (Ident a) = attrify a +instance Attrify Nat where + attrify (Nat a) = attrify a +instance Attrify Nat1 where + attrify (Nat1 a) = attrify a instance MayAttr URL where mayAttr a (URL t) = mayAttr a t diff --git a/hdoc.cabal b/hdoc.cabal index ecd1425..0707fbb 100644 --- a/hdoc.cabal +++ b/hdoc.cabal @@ -37,6 +37,7 @@ Library Language.DTC.Read.TCT Language.DTC.Sym Language.DTC.Write.HTML5 + Language.DTC.Write.Plain Language.DTC.Write.XML Language.RNC.Fixity Language.RNC.Sym @@ -52,7 +53,7 @@ Library Language.TCT.Token Language.TCT.Tree Language.TCT.Write.HTML5 - Language.TCT.Write.Text + Language.TCT.Write.Plain Language.TCT.Write.XML Language.XML Text.Blaze.DTC -- 2.42.0 From b1f54c6a5349b08729f2ed84bdb4c8aff394aef4 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sun, 24 Dec 2017 10:27:54 +0100 Subject: [PATCH 02/16] Add Html5ify for TCT. --- Language/DTC/Write/Plain.hs | 2 +- Language/TCT/Write/HTML5.hs | 335 ++++++++++++++++++------------------ Language/TCT/Write/Plain.hs | 299 +++++++++++++++++--------------- Language/TCT/Write/XML.hs | 12 +- exe/cli/Main.hs | 2 +- 5 files changed, 340 insertions(+), 310 deletions(-) diff --git a/Language/DTC/Write/Plain.hs b/Language/DTC/Write/Plain.hs index 5481086..3b516f5 100644 --- a/Language/DTC/Write/Plain.hs +++ b/Language/DTC/Write/Plain.hs @@ -54,7 +54,7 @@ instance IsString Plain where instance Semigroup Plain where (<>) = liftA2 (<>) instance Monoid Plain where - mempty = return "" + mempty = return "" mappend = (<>) -- ** Type 'State' diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index 8c29b05..1b4e3b2 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Render TCT as HTML5. module Language.TCT.Write.HTML5 where -import Control.Monad (Monad(..), forM_, mapM, when) +import Control.Monad (Monad(..), forM_, mapM_, mapM, when) import Data.Bool import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) @@ -31,28 +32,170 @@ import qualified Text.Blaze.Html5.Attributes as HA import Text.Blaze.Utils import Language.TCT -import Language.TCT.Write.Plain +import qualified Language.TCT.Write.Plain as Plain -html5Document :: TCTs -> Html -html5Document tct = do - H.docType - H.html $ do - H.head $ do - H.meta ! HA.httpEquiv "Content-Type" - ! HA.content "text/html; charset=UTF-8" - whenJust (tokensTitle tct) $ \ts -> - H.title $ H.toMarkup $ L.head $ - TL.lines (plainifyTokens ts) <> [""] - -- link ! rel "Chapter" ! title "SomeTitle"> - H.link ! HA.rel "stylesheet" - ! HA.type_ "text/css" - ! HA.href "style/tct-html5.css" - H.body $ do - H.a ! HA.id ("line-1") $ return () - html5TreesCell (treePosLastCell tct) +-- * Class 'Html5ify' +class Html5ify a where + html5ify :: a -> Html +instance Html5ify Text where + html5ify = H.toMarkup +instance Html5ify TCTs where + html5ify tct = do + H.docType + H.html $ do + H.head $ do + H.meta ! HA.httpEquiv "Content-Type" + ! HA.content "text/html; charset=UTF-8" + whenJust (tokensTitle tct) $ \ts -> + H.title $ H.toMarkup $ L.head $ + TL.lines (Plain.textify ts) <> [""] + -- link ! rel "Chapter" ! title "SomeTitle"> + H.link ! HA.rel "stylesheet" + ! HA.type_ "text/css" + ! HA.href "style/tct-html5.css" + H.body $ do + H.a ! HA.id ("line-1") $ return () + html5ify (Plain.treePosLastCell tct) +instance Html5ify (Trees (Pos,Cell Key) (Pos,Tokens)) where + html5ify = mapM_ html5ify +instance Html5ify (Tree (Pos,Cell Key) (Pos,Tokens)) where + html5ify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do + html5ifyIndentCell (posEnd,pos) + H.section $ do + H.span ! HA.class_ "section-title" $ do + H.span $ html5ify $ Text.replicate lvl "#" <> " " + case Seq.viewl ts of + Tree0 (_,title) :< _ -> h lvl $ html5ify title + _ -> return () + html5ify $ + case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts} + where + h 1 = H.h1 + h 2 = H.h2 + h 3 = H.h3 + h 4 = H.h4 + h 5 = H.h5 + h 6 = H.h6 + h n | n > 0 = H.span ! HA.class_ ("h h"<>attrify n) + h _ = undefined + html5ify (Tree0 (posEnd,toks)) = + case Seq.viewl toks of + EmptyL -> html5ify toks + t0:<_ -> html5ifyIndentCell (posEnd,posCell t0) <> html5ify toks + html5ify (TreeN (posEnd,cell@(Cell pos _ _)) cs) = + html5ifyIndentCell (posEnd,pos) <> + html5ify (cell, cs) +instance Html5ify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where + html5ify (Cell _pos _posEnd key, ts) = do + case key of + KeyColon n wh -> html5Key "" "" n wh ":" "" "colon" + KeyGreat n wh -> html5Key "" "" n wh ">" "" "great" + KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal" + KeyBar n wh -> html5Key "" "" n wh "|" "" "bar" + KeyDot n -> html5Key "" "" n "" "." "" "dot" + KeyDash -> html5Key "" "" "" "" "-" " " "dash" + KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash" + KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash" + KeyLower name attrs -> do + H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $ do + H.span ! HA.class_ "key-mark" $ H.toMarkup '<' + H.span ! HA.class_ "key-name" $ H.toMarkup name + html5ify attrs + html5ify ts + where + html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html + html5Key markBegin whmb name whn markEnd whme cl = do + -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1) + H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $ do + when (markBegin/="") $ + H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin + H.toMarkup whmb + when (name/="") $ + H.span ! HA.class_ "key-name" $ H.toMarkup name + H.toMarkup whn + when (markEnd/="") $ + H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd + H.toMarkup whme + H.span ! HA.class_ "key-value" $ + html5ify ts +instance Html5ify Tokens where + html5ify toks = + case Seq.viewl toks of + EmptyL -> "" + Cell pos _ _ :< _ -> + goTokens toks `S.evalState` linePos pos + where + indent = Text.replicate (columnPos pos - 1) " " + go :: Cell Token -> S.State Int Html + go tok = + case unCell tok of + TokenPlain txt -> do + lin <- S.get + let lines = Text.splitOn "\n" txt + let lnums = H.toMarkup : + [ \line -> do + H.toMarkup '\n' + H.a ! HA.id ("line-"<>attrify lnum) $ return () + H.toMarkup indent + H.toMarkup line + | lnum <- [lin+1..] + ] + S.put (lin - 1 + L.length lines) + return $ mconcat $ L.zipWith ($) lnums lines + TokenTag v -> + return $ + H.span ! HA.class_ "tag" $ do + H.span ! HA.class_ "tag-open" $ H.toMarkup '#' + H.toMarkup v + TokenEscape c -> return $ H.toMarkup ['\\',c] + TokenLink lnk -> + return $ + H.a ! HA.href (attrify lnk) $ + H.toMarkup lnk + TokenPair (PairElem name attrs) ts -> do + h <- goTokens ts + return $ do + let cl = mconcat ["pair-PairElem", " pair-elem-", attrify name] + H.span ! HA.class_ cl $ do + whenMarkup o $ H.span ! HA.class_ "pair-open" $ o + whenMarkup h $ H.span ! HA.class_ "pair-content" $ h + whenMarkup c $ H.span ! HA.class_ "pair-close" $ c + where + html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name + o,c :: Html + (o,c) = + if Seq.null ts + then + ( "<"<>html5name<>html5ify attrs<>"/>" + , mempty ) + else + ( "<"<>html5name<>html5ify attrs<>">" + , "html5name<>">" ) + TokenPair grp ts -> do + h <- goTokens ts + return $ do + let (o,c) = pairBorders grp ts + H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do + H.span ! HA.class_ "pair-open" $ H.toMarkup o + H.span ! HA.class_ "pair-content" $ h + H.span ! HA.class_ "pair-close" $ H.toMarkup c + goTokens :: Tokens -> S.State Int Html + goTokens ts = do + ts' <- go`mapM`ts + return $ foldr (<>) mempty ts' +instance Html5ify Attrs where + html5ify = mapM_ html5ify +instance Html5ify (Text,Attr) where + html5ify (attr_white,Attr{..}) = do + H.toMarkup attr_white + H.span ! HA.class_ "attr-name" $ + H.toMarkup attr_name + H.toMarkup attr_open + H.span ! HA.class_ "attr-value" $ + H.toMarkup attr_value + H.toMarkup attr_close -html5TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html -html5TreesCell = foldMap html5TreeCell +-- * Utilities tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens tokensTitle tct = @@ -63,43 +206,12 @@ tokensTitle tct = TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title _ -> Nothing -html5Text :: Text -> Html -html5Text = H.toMarkup - html5Spaces :: Int -> Html html5Spaces 0 = return () -html5Spaces sp = H.span $ html5Text $ Text.replicate sp " " - -html5TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html -html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do - html5IndentCell (posEnd,pos) - H.section $ do - H.span ! HA.class_ "section-title" $ do - H.span $ html5Text $ Text.replicate lvl "#" <> " " - case Seq.viewl ts of - Tree0 (_,title) :< _ -> h lvl $ html5IndentToken title - _ -> return () - html5TreesCell $ - case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts} - where - h 1 = H.h1 - h 2 = H.h2 - h 3 = H.h3 - h 4 = H.h4 - h 5 = H.h5 - h 6 = H.h6 - h n | n > 0 = H.span ! HA.class_ ("h h"<>attrify n) - h _ = undefined -html5TreeCell (Tree0 (posEnd,toks)) = - case Seq.viewl toks of - EmptyL -> html5IndentToken toks - t0:<_ -> html5IndentCell (posEnd,posCell t0) <> html5IndentToken toks -html5TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) = - html5IndentCell (posEnd,pos) <> - html5CellKey cell cs +html5Spaces sp = H.span $ html5ify $ Text.replicate sp " " -html5IndentCell :: (Pos,Pos) -> Html -html5IndentCell (Pos lineLast colLast,Pos line col) +html5ifyIndentCell :: (Pos,Pos) -> Html +html5ifyIndentCell (Pos lineLast colLast,Pos line col) | lineLast < line = do forM_ [lineLast+1..line] $ \lnum -> do H.toMarkup '\n' @@ -108,116 +220,3 @@ html5IndentCell (Pos lineLast colLast,Pos line col) | lineLast == line && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " " | otherwise = undefined - -html5CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html -html5CellKey (Cell _pos _posEnd key) ts = do - case key of - KeyColon n wh -> html5Key "" "" n wh ":" "" "colon" - KeyGreat n wh -> html5Key "" "" n wh ">" "" "great" - KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal" - KeyBar n wh -> html5Key "" "" n wh "|" "" "bar" - KeyDot n -> html5Key "" "" n "" "." "" "dot" - KeyDash -> html5Key "" "" "" "" "-" " " "dash" - KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash" - KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash" - KeyLower name attrs -> do - H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $ do - H.span ! HA.class_ "key-mark" $ H.toMarkup '<' - H.span ! HA.class_ "key-name" $ H.toMarkup name - html5Attrs attrs - html5TreesCell ts - where - html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html - html5Key markBegin whmb name whn markEnd whme cl = do - -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1) - H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $ do - when (markBegin/="") $ - H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin - H.toMarkup whmb - when (name/="") $ - H.span ! HA.class_ "key-name" $ H.toMarkup name - H.toMarkup whn - when (markEnd/="") $ - H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd - H.toMarkup whme - H.span ! HA.class_ "key-value" $ - html5TreesCell ts - -html5IndentToken :: Tokens -> Html -html5IndentToken toks = - case Seq.viewl toks of - EmptyL -> "" - Cell pos _ _ :< _ -> - goTokens toks `S.evalState` linePos pos - where - indent = Text.replicate (columnPos pos - 1) " " - go :: Cell Token -> S.State Int Html - go tok = - case unCell tok of - TokenPlain txt -> do - lin <- S.get - let lines = Text.splitOn "\n" txt - let lnums = H.toMarkup : - [ \line -> do - H.toMarkup '\n' - H.a ! HA.id ("line-"<>attrify lnum) $ return () - H.toMarkup indent - H.toMarkup line - | lnum <- [lin+1..] - ] - S.put (lin - 1 + L.length lines) - return $ mconcat $ L.zipWith ($) lnums lines - TokenTag v -> - return $ - H.span ! HA.class_ "tag" $ do - H.span ! HA.class_ "tag-open" $ H.toMarkup '#' - H.toMarkup v - TokenEscape c -> return $ H.toMarkup ['\\',c] - TokenLink lnk -> - return $ - H.a ! HA.href (attrify lnk) $ - H.toMarkup lnk - TokenPair (PairElem name attrs) ts -> do - h <- goTokens ts - return $ do - let cl = mconcat ["pair-PairElem", " pair-elem-", attrify name] - H.span ! HA.class_ cl $ do - whenMarkup o $ H.span ! HA.class_ "pair-open" $ o - whenMarkup h $ H.span ! HA.class_ "pair-content" $ h - whenMarkup c $ H.span ! HA.class_ "pair-close" $ c - where - html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name - o,c :: Html - (o,c) = - if Seq.null ts - then - ( "<"<>html5name<>html5Attrs attrs<>"/>" - , mempty ) - else - ( "<"<>html5name<>html5Attrs attrs<>">" - , "html5name<>">" ) - TokenPair grp ts -> do - h <- goTokens ts - return $ do - let (o,c) = pairBorders grp ts - H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do - H.span ! HA.class_ "pair-open" $ H.toMarkup o - H.span ! HA.class_ "pair-content" $ h - H.span ! HA.class_ "pair-close" $ H.toMarkup c - goTokens :: Tokens -> S.State Int Html - goTokens ts = do - ts' <- go`mapM`ts - return $ foldr (<>) mempty ts' - -html5Attrs :: Attrs -> Html -html5Attrs = foldMap html5Attr - -html5Attr :: (Text,Attr) -> Html -html5Attr (attr_white,Attr{..}) = do - H.toMarkup attr_white - H.span ! HA.class_ "attr-name" $ - H.toMarkup attr_name - H.toMarkup attr_open - H.span ! HA.class_ "attr-value" $ - H.toMarkup attr_value - H.toMarkup attr_close diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 703e48a..8ac6536 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -1,25 +1,30 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Render a TCT file in plain Text. module Language.TCT.Write.Plain where +import Control.Applicative (liftA2) import Control.Monad (Monad(..), mapM) import Data.Bool import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Function (($), (.)) +import Data.Function (($), (.), id) import Data.Functor ((<$>)) import Data.Int (Int,Int64) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..), ViewR(..)) +import Data.String (String) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..),Trees) +import GHC.Exts (IsString(..)) import Prelude (Num(..), undefined, Integral(..)) import Text.Show (Show(..)) +import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State as S import qualified Data.List as L import qualified Data.Sequence as Seq @@ -31,22 +36,168 @@ import Language.TCT.Cell import Language.TCT.Token import Language.TCT.Elem -tl :: Text -> TL.Text -tl = TL.fromStrict - --- * Type 'Inh' -data Inh - = Inh - { inh_escape :: Bool +-- * Type 'Plain' +type Plain = R.Reader State TL.Text +instance IsString Plain where + fromString = return . fromString +instance Semigroup Plain where + (<>) = liftA2 (<>) +instance Monoid Plain where + mempty = return "" + mappend = (<>) + +runPlain :: Plain -> State -> TL.Text +runPlain p s = {-TLB.toLazyText .-} R.runReader p s + +text :: Plainify a => State -> a -> TL.Text +text st a = runPlain (plainify a) st + +-- * Type 'State' +data State + = State + { state_escape :: Bool } deriving (Eq, Show) -instance Default Inh where - def = Inh - { inh_escape = True +instance Default State where + def = State + { state_escape = True } -plainify :: Inh -> Trees (Cell Key) Tokens -> TL.Text -plainify inh = plainifyTreesCell inh . treePosLastCell +-- * Class 'Plainify' +class Plainify a where + plainify :: a -> Plain +instance Plainify String where + plainify = return . fromString +instance Plainify Text where + plainify = return . TL.fromStrict +instance Plainify TL.Text where + plainify = return +instance Plainify (Trees (Cell Key) Tokens) where + plainify = plainify . treePosLastCell +instance Plainify (Trees (Pos,Cell Key) (Pos,Tokens)) where + plainify = foldMap plainify +instance Plainify (Tree (Pos,Cell Key) (Pos,Tokens)) where + plainify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = + plainifyIndentCell (posEnd,pos) <> + plainify (TL.replicate (int64 lvl) "#") <> " " <> + (case Seq.viewl ts of + Tree0 (_,title) :< _ -> + plainify title + _ -> "") <> + plainify + (case Seq.viewl ts of + Tree0{} :< ts' -> ts' + _ -> ts) + plainify (Tree0 (posEnd,toks)) = + case Seq.viewl toks of + EmptyL -> plainify toks + t0:<_ -> plainifyIndentCell (posEnd,posCell t0) <> plainify toks + plainify (TreeN (posEnd,cell@(Cell pos _ _)) cs) = + plainifyIndentCell (posEnd,pos) <> + plainify (cell, cs) +instance Plainify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where + plainify (Cell _pos _posEnd key, cells) = do + case key of + KeyColon n wh -> textKey n wh ":" + KeyGreat n wh -> textKey n wh ">" + KeyEqual n wh -> textKey n wh "=" + KeyBar n wh -> textKey n wh "|" + KeyDash -> textKey "" "" "- " + KeyDashDash -> textKey "" "" "-- " + KeyLower name attrs -> + "<" <> + plainify name <> + plainify attrs <> + plainify cells + KeySection{} -> undefined + KeyDotSlash p -> + plainify ("./"::TL.Text) <> + plainify p <> + plainify cells + where + textKey :: Text -> White -> TL.Text -> Plain + textKey name wh mark = + plainify (textify name <> textify wh <> mark) <> + plainify cells +instance Plainify Tokens where + plainify toks = + case Seq.viewl toks of + EmptyL -> "" + Cell pos _ _ :< _ -> do + st <- R.ask + return $ goTokens st toks `S.evalState` linePos pos + where + indent = TL.replicate (int64 $ columnPos pos - 1) " " + go :: State -> Cell Token -> S.State Int TL.Text + go st@State{..} tok = + case unCell tok of + TokenPlain txt -> do + lnum <- S.get + let lines = Text.splitOn "\n" txt + S.put (lnum - 1 + L.length lines) + return $ + case lines of + [] -> undefined + (l0:ls) -> textify l0 <> mconcat ((\l -> "\n"<>indent<>textify l)<$>ls) + TokenTag v -> return $ "#"<>textify v + TokenEscape c -> do + return $ + if state_escape + then textify $ Text.pack ['\\',c] + else TL.singleton c + TokenLink lnk -> return $ textify lnk + TokenPair grp ts -> do + ts' <- goTokens st ts + return $ textify o<>ts'<>textify c + where (o,c) = pairBorders grp ts + goTokens :: State -> Tokens -> S.State Int TL.Text + goTokens st ts = do + ts' <- go st`mapM`ts + return $ foldr (<>) mempty ts' +instance Plainify Attrs where + plainify = plainify . textify + +-- * Class 'Textify' +class Textify a where + textify :: a -> TL.Text +instance Textify Text where + textify = TL.fromStrict +instance Textify TL.Text where + textify = id +instance Textify Attrs where + textify = foldMap textify +instance Textify (Text,Attr) where + textify (attr_white,Attr{..}) = + mconcat $ textify <$> + [ attr_white + , attr_name + , attr_open + , attr_value + , attr_close + ] +instance Textify Token where + textify (TokenPlain txt) = textify txt + textify (TokenTag v) = "#"<>textify v + textify (TokenEscape c) = TL.singleton c -- textify $ Text.pack ['\\',c] + textify (TokenLink lnk) = textify lnk + textify (TokenPair grp t) = textify o<>textify t<>textify c + where (o,c) = pairBorders grp t +instance Textify Tokens where + textify ts = foldMap (textify . unCell) ts + +-- * Utilities + +plainifyIndentCell :: (Pos,Pos) -> Plain +plainifyIndentCell (Pos lineLast colLast,Pos line col) + | lineLast < line = + return $ + TL.replicate (int64 $ line - (lineLast+1)) "\n" <> + TL.replicate (int64 $ col - 1) " " + | lineLast == line && colLast <= col = + return $ + TL.replicate (int64 $ col - colLast) " " + | otherwise = undefined +-- ** 'Tree' treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a) treeRackUpLeft t = go t where @@ -84,126 +235,6 @@ treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1) ts' <- go`mapM`ts return $ TreeN (lastPos,cell) ts' +-- ** 'Int64' int64 :: Integral i => i -> Int64 int64 = fromInteger . toInteger - -plainifyTreeCell :: - Inh -> - Tree (Pos,Cell Key) (Pos,Tokens) -> - TL.Text -plainifyTreeCell inh (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = - plainifyIndentCell (posEnd,pos) <> - TL.replicate (int64 lvl) "#" <> " " <> - (case Seq.viewl ts of - Tree0 (_,title) :< _ -> - plainifyIndentToken inh title - _ -> "") <> - plainifyTreesCell inh - (case Seq.viewl ts of - Tree0{} :< ts' -> ts' - _ -> ts) -plainifyTreeCell inh (Tree0 (posEnd,toks)) = - case Seq.viewl toks of - EmptyL -> plainifyIndentToken inh toks - t0:<_ -> plainifyIndentCell (posEnd,posCell t0) <> plainifyIndentToken inh toks -plainifyTreeCell inh (TreeN (posEnd,cell@(Cell pos _ _)) cs) = - plainifyIndentCell (posEnd,pos) <> - plainifyCellKey inh cell cs - -plainifyIndentCell :: (Pos,Pos) -> TL.Text -plainifyIndentCell (Pos lineLast colLast,Pos line col) - | lineLast < line = - TL.replicate (int64 $ line - (lineLast+1)) "\n" <> - TL.replicate (int64 $ col - 1) " " - | lineLast == line && colLast <= col = - TL.replicate (int64 $ col - colLast) " " - | otherwise = undefined - -plainifyCellKey :: - Inh -> - Cell Key -> - Trees (Pos,Cell Key) (Pos,Tokens) -> - TL.Text -plainifyCellKey inh (Cell _pos _posEnd key) cells = do - case key of - KeyColon n wh -> textKey n wh ":" - KeyGreat n wh -> textKey n wh ">" - KeyEqual n wh -> textKey n wh "=" - KeyBar n wh -> textKey n wh "|" - KeyDash -> textKey "" "" "- " - KeyDashDash -> textKey "" "" "-- " - KeyLower name attrs -> - "<" <> tl name <> plainifyAttrs attrs <> - plainifyTreesCell inh cells - KeySection{} -> undefined - KeyDotSlash p -> - "./" <> TL.pack p <> - plainifyTreesCell inh cells - where - textKey :: Text -> White -> TL.Text -> TL.Text - textKey name wh mark = - tl name <> tl wh <> mark <> - plainifyTreesCell inh cells - -plainifyTreesCell :: - Inh -> - Trees (Pos,Cell Key) (Pos,Tokens) -> - TL.Text -plainifyTreesCell inh = foldMap (plainifyTreeCell inh) - -plainifyIndentToken :: Inh -> Tokens -> TL.Text -plainifyIndentToken _cfg (Seq.viewl -> EmptyL) = "" -plainifyIndentToken inh toks@(Seq.viewl -> Cell pos _ _ :< _) = - goTokens toks `S.evalState` linePos pos - where - indent = TL.replicate (int64 $ columnPos pos - 1) " " - go :: Cell Token -> S.State Int TL.Text - go tok = - case unCell tok of - TokenPlain txt -> do - lnum <- S.get - let lines = Text.splitOn "\n" txt - S.put (lnum - 1 + L.length lines) - return $ - case lines of - [] -> undefined - (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls) - TokenTag v -> return $ "#"<>tl v - TokenEscape c -> - return $ - if inh_escape inh - then tl $ Text.pack ['\\',c] - else TL.singleton c - TokenLink lnk -> return $ tl lnk - TokenPair grp ts -> do - ts' <- goTokens ts - return $ tl o<>ts'<>tl c - where (o,c) = pairBorders grp ts - goTokens :: Tokens -> S.State Int TL.Text - goTokens ts = do - ts' <- go`mapM`ts - return $ foldr (<>) mempty ts' - -plainifyAttrs :: Attrs -> TL.Text -plainifyAttrs = foldMap plainifyAttr - -plainifyAttr :: (Text,Attr) -> TL.Text -plainifyAttr (attr_white,Attr{..}) = - mconcat $ tl <$> - [ attr_white - , attr_name - , attr_open - , attr_value - , attr_close - ] - -plainifyToken :: Token -> TL.Text -plainifyToken (TokenPlain txt) = tl txt -plainifyToken (TokenTag v) = "#"<>tl v -plainifyToken (TokenEscape c) = TL.singleton c -- tl $ Text.pack ['\\',c] -plainifyToken (TokenLink lnk) = tl lnk -plainifyToken (TokenPair grp t) = tl o<>plainifyTokens t<>tl c - where (o,c) = pairBorders grp t - -plainifyTokens :: Tokens -> TL.Text -plainifyTokens ts = foldMap (plainifyToken . unCell) ts diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 79e170f..69c7d65 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -220,7 +220,7 @@ xmlKey inh (Cell bp ep key) attrs ts = where com :: TL.Text com = - Plain.plainify def $ + Plain.text def $ TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> ts @@ -256,7 +256,7 @@ xmlTokens tok = goTokens tok TokenLink lnk -> Seq.singleton $ TreeN (cell "eref") $ xmlAttrs [cell ("to",lnk)] - TokenPair PairBracket ts | to <- Plain.plainifyTokens ts + TokenPair PairBracket ts | to <- Plain.textify ts , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> Seq.singleton $ TreeN (cell "rref") $ @@ -284,7 +284,7 @@ xmlTokens tok = goTokens tok TokenPair PairHash to -> Seq.singleton $ TreeN (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Plain.plainifyTokens to)] + xmlAttrs [cell ("to",TL.toStrict $ Plain.textify to)] TokenPair (PairElem name attrs) ts -> Seq.singleton $ TreeN (cell $ xmlLocalName name) $ @@ -313,7 +313,7 @@ xmlTokens tok = goTokens tok goTokens paren _ -> TreeN (Cell bp eb "rref") $ - xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.plainifyTokens bracket)] <> + xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.textify bracket)] <> goTokens paren t :< ts -> go t `unionXml` goTokens ts Seq.EmptyL -> mempty @@ -405,7 +405,7 @@ spanlTokens = getAttrId :: TCTs -> Text getAttrId ts = case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of - Just (Tree0 toks) -> TL.toStrict $ Plain.plainifyTokens toks + Just (Tree0 toks) -> TL.toStrict $ Plain.textify toks _ -> "" setXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text)) @@ -435,7 +435,7 @@ partitionAttributesChildren ts = (attrs,cs) Cell bp ep (xmlLocalName n, v) where v = TL.toStrict $ - Plain.plainify def{Plain.inh_escape = False} $ + Plain.text def{Plain.state_escape = False} $ TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> a _ -> undefined diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index 332985e..ea6037e 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -81,7 +81,7 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = case format of TctFormatHTML5 -> Blaze.renderMarkupToByteStringIO BS.putStr $ - TCT.Write.HTML5.html5Document tct + TCT.Write.HTML5.html5ify tct mainWithCommand (CommandDTC ArgsDTC{..}) = readFile input $ \_fp txt -> case TCT.readTCTs input txt of -- 2.42.0 From a638b5e0c76efbf8137f0e867b8a25903341dadc Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 25 Dec 2017 09:05:37 +0100 Subject: [PATCH 03/16] Fix Reference. --- Language/DTC/Document.hs | 6 ++-- Language/DTC/Sym.hs | 9 +++--- Language/DTC/Write/HTML5.hs | 59 +++++++++++++++++++++++++------------ Language/DTC/Write/Plain.hs | 4 +-- Language/TCT/Write/XML.hs | 4 ++- 5 files changed, 54 insertions(+), 28 deletions(-) diff --git a/Language/DTC/Document.hs b/Language/DTC/Document.hs index bdee41a..2a47916 100644 --- a/Language/DTC/Document.hs +++ b/Language/DTC/Document.hs @@ -19,7 +19,7 @@ import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq) import Data.Text (Text) -import Data.TreeSeq.Strict (Tree, Trees) +import Data.TreeSeq.Strict (Tree(..), Trees) import Text.Show (Show) import Language.XML @@ -237,7 +237,7 @@ data LineValue -- * Type 'Title' newtype Title = Title { unTitle :: Para } - deriving (Eq,Show,Default) + deriving (Eq,Show,Semigroup,Monoid,Default) -- ** Type 'Entity' data Entity @@ -252,6 +252,7 @@ data Entity , tel :: Text , fax :: Text , url :: Maybe URL + , org :: Maybe Entity } deriving (Eq,Show) instance Default Entity where def = Entity @@ -265,6 +266,7 @@ instance Default Entity where , tel = def , fax = def , url = def + , org = def } instance Semigroup Entity where _x <> y = y diff --git a/Language/DTC/Sym.hs b/Language/DTC/Sym.hs index 51d185d..fae7c86 100644 --- a/Language/DTC/Sym.hs +++ b/Language/DTC/Sym.hs @@ -236,7 +236,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where entity = rule "entity" $ interleaved $ DTC.Entity - <$?> (def, attribute "name" text) + <$?> (def, name) <|?> (def, attribute "street" text) <|?> (def, attribute "zipcode" text) <|?> (def, attribute "city" text) @@ -246,17 +246,18 @@ class RNC.Sym_RNC repr => Sym_DTC repr where <|?> (def, attribute "tel" text) <|?> (def, attribute "fax" text) <|?> (def, Just <$> attribute "url" url) + <|?> (def, Just <$> attribute "org" entity) serie = rule "serie" $ element "serie" $ interleaved $ DTC.Serie - <$?> (def, attribute "name" text) - <|?> (def, attribute "key" text) + <$?> (def, name) + <|?> (def, attribute "key" text) link = rule "link" $ element "link" $ interleaved $ (\n h r ls -> DTC.Link n h r (Seq.fromList ls)) - <$?> (def, attribute "name" text) + <$?> (def, name) <|?> (def, attribute "href" url) <|?> (def, attribute "rel" text) <|*> lines diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs index 2ee0a77..b43b362 100644 --- a/Language/DTC/Write/HTML5.hs +++ b/Language/DTC/Write/HTML5.hs @@ -41,6 +41,7 @@ import Text.Blaze ((!)) import Text.Blaze.Html (Html) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S +import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq @@ -276,7 +277,6 @@ html5BodyValue z = \case html5ify type_ html5ify $ DTC.posAncestors pos html5ify $ Plain.L10n_Colon - " " H.td ! HA.class_ "figure-name" $$ html5ify title H.div ! HA.class_ "figure-content" $$ do @@ -507,31 +507,52 @@ instance Html5ify DTC.Date where instance Html5ify DTC.About where html5ify DTC.About{..} = html5CommasDot $ concat $ - [ (<$> List.take 1 titles) $ \(DTC.Title title) -> - html5ify $ TreeN DTC.Q $ - case url of - Nothing -> title - Just u -> pure $ TreeN (DTC.Eref u) title + [ html5Titles titles , html5Entity <$> authors - , html5ify <$> maybeToList date + , html5ify <$> maybeToList date , html5Entity <$> maybeToList editor - , html5Serie <$> series + , html5Serie <$> series ] where + html5Titles :: [DTC.Title] -> [Html5] + html5Titles ts | null ts = [] + html5Titles ts = [html5Title $ fold $ List.intersperse (DTC.Title " — ") $ toList ts] + html5Title (DTC.Title title) = + html5ify $ TreeN DTC.Q $ + case url of + Nothing -> title + Just u -> pure $ TreeN (DTC.Eref u) title + html5SerieHref href DTC.Serie{..} = do + sp <- liftStateMarkup $ S.gets state_plainify + html5ify $ + TreeN DTC.Eref{href} $ + Seq.fromList + [ Tree0 $ DTC.Plain $ name + , Tree0 $ DTC.Plain $ TL.toStrict $ Plain.text sp Plain.L10n_Colon + , Tree0 $ DTC.Plain key + ] + html5Serie s@DTC.Serie{name="RFC", key} | Text.all Char.isDigit key = + html5SerieHref (DTC.URL $ "https://tools.ietf.org/html/rfc"<>key) s + html5Serie s@DTC.Serie{name="DOI", key} = + html5SerieHref (DTC.URL $ "https://dx.doi.org/"<>key) s html5Serie DTC.Serie{..} = do - html5ify key - html5ify Plain.L10n_Colon html5ify name - html5Entity DTC.Entity{url=mu, ..} = + html5ify Plain.L10n_Colon + html5ify key + html5Entity DTC.Entity{url=mu, ..} = do html5ify @DTC.Lines $ - case () of - _ | not (Text.null email) -> - TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $ - pure $ Tree0 $ DTC.Plain name - _ | Just u <- mu -> - TreeN (DTC.Eref u) $ - pure $ Tree0 $ DTC.Plain name - _ -> Tree0 $ DTC.Plain name + case () of + _ | not (Text.null email) -> + TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $ + pure $ Tree0 $ DTC.Plain name + _ | Just u <- mu -> + TreeN (DTC.Eref u) $ + pure $ Tree0 $ DTC.Plain name + _ -> Tree0 $ DTC.Plain name + forM_ org $ \o -> do + " ("::Html5 + html5Entity o + ")"::Html5 instance Html5ify DTC.Reference where html5ify DTC.Reference{id=id_, ..} = H.tr $$ do diff --git a/Language/DTC/Write/Plain.hs b/Language/DTC/Write/Plain.hs index 3b516f5..0561da5 100644 --- a/Language/DTC/Write/Plain.hs +++ b/Language/DTC/Write/Plain.hs @@ -147,7 +147,7 @@ instance Plainify L10n where instance LocalizeIn FR Plain L10n where localizeIn _ = \case L10n_Table_of_Contents -> "Sommaire" - L10n_Colon -> " :" + L10n_Colon -> " : " L10n_QuoteOpen{..} -> case DTC.unNat depth `mod` 3 of 0 -> "« " @@ -185,7 +185,7 @@ instance LocalizeIn FR Plain L10n where instance LocalizeIn EN Plain L10n where localizeIn _ = \case L10n_Table_of_Contents -> "Summary" - L10n_Colon -> ":" + L10n_Colon -> ": " L10n_QuoteOpen{..} -> case DTC.unNat depth `mod` 3 of 0 -> "“" diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 69c7d65..f117151 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -171,8 +171,10 @@ xmlTCT inh tr = case kn of "about" -> xmlTitle : xmlTitle : List.repeat xmlPara "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara + "serie" -> List.repeat xmlName "author" -> List.repeat xmlName "editor" -> List.repeat xmlName + "org" -> List.repeat xmlName _ -> [] } in case () of @@ -230,7 +232,7 @@ xmlKey inh (Cell bp ep key) attrs ts = let (attrs',body) = partitionAttributesChildren ts in TreeN (cell "reference") $ xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <> - xmlTCTs inh' body + xmlTCTs inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body KeyDotSlash p -> TreeN (cell "include") $ xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <> -- 2.42.0 From f3c0e812ab3202b91963d9f69f880420e8025df8 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 25 Dec 2017 10:24:17 +0100 Subject: [PATCH 04/16] Fix RNC rendering for DTC. --- Language/DTC/Sym.hs | 4 +++- Language/DTC/Write/HTML5.hs | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/Language/DTC/Sym.hs b/Language/DTC/Sym.hs index fae7c86..0a6e1ad 100644 --- a/Language/DTC/Sym.hs +++ b/Language/DTC/Sym.hs @@ -195,6 +195,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where <*> many reference para = rule "para" $ (Seq.fromList <$>) $ many lines lines = + rule "lines" $ choice [ element "b" $ TreeN DTC.B <$> para , element "code" $ TreeN DTC.Code <$> para @@ -274,7 +275,8 @@ class RNC.Sym_RNC repr => Sym_DTC repr where instance Sym_DTC RNC.Writer where position = RNC.writeText "" -deriving instance Sym_DTC RNC.RuleWriter +instance Sym_DTC RNC.RuleWriter where + position = RNC.RuleWriter position dtcRNC :: [RNC.RuleWriter ()] dtcRNC = diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs index b43b362..28bf90d 100644 --- a/Language/DTC/Write/HTML5.hs +++ b/Language/DTC/Write/HTML5.hs @@ -516,7 +516,8 @@ instance Html5ify DTC.About where where html5Titles :: [DTC.Title] -> [Html5] html5Titles ts | null ts = [] - html5Titles ts = [html5Title $ fold $ List.intersperse (DTC.Title " — ") $ toList ts] + html5Titles ts = [html5Title $ fold $ List.intersperse t $ toList ts] + where t = DTC.Title $ Seq.singleton $ Tree0 $ DTC.Plain " — " html5Title (DTC.Title title) = html5ify $ TreeN DTC.Q $ case url of -- 2.42.0 From d90e8fad379dde7226954ef78336f7fc113d869c Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 25 Dec 2017 11:33:10 +0100 Subject: [PATCH 05/16] Add Xmlify. --- Language/DTC/Anchor.hs | 6 +- Language/TCT/Write/XML.hs | 381 +++++++++++++++++++------------------- 2 files changed, 191 insertions(+), 196 deletions(-) diff --git a/Language/DTC/Anchor.hs b/Language/DTC/Anchor.hs index b6ba4dd..20e6869 100644 --- a/Language/DTC/Anchor.hs +++ b/Language/DTC/Anchor.hs @@ -35,7 +35,7 @@ import qualified Data.TreeMap.Strict as TreeMap import Language.DTC.Document --- ** Type 'PathWord' +-- * Type 'PathWord' type PathWord = TreeMap.Path Word pathFromWords :: Words -> Maybe PathWord @@ -48,7 +48,7 @@ pathFromWords ws = Space -> [] Word w -> [w] --- ** Type 'Irefs' +-- * Type 'Irefs' type Irefs = TreeMap Word [Anchor] irefsOfTerms :: Terms -> Irefs @@ -57,7 +57,7 @@ irefsOfTerms = TreeMap.fromList const . (>>= f) . concat f [] = [] f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws --- ** Type 'Rrefs' +-- * Type 'Rrefs' type Rrefs = Map Ident [Anchor] -- * Type 'State' diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index f117151..9796843 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -50,6 +50,181 @@ instance Default Inh where , inh_titles = mempty } +-- * Class 'Xmlify' +class Xmlify a where + xmlify :: Inh -> a -> XMLs +instance Xmlify TCTs where + xmlify inh_orig = go inh_orig + where + go :: Inh -> TCTs -> XMLs + go inh trees = + case Seq.viewl trees of + TreeN (Cell bp ep (KeyBar n _)) _ :< _ + | (body,ts) <- spanlBar n trees + , not (null body) -> + (<| go inh ts) $ + TreeN (Cell bp ep "artwork") $ + maybe id (\v -> (Tree0 (Cell bp ep (XmlAttr "type" v)) <|)) (mimetype n) $ + body >>= xmlify inh{inh_tree0=[]} + + TreeN key@(unCell -> KeyColon n _) cs :< ts + | (cs',ts') <- spanlKeyColon n ts + , not (null cs') -> + go inh $ TreeN key (cs<>cs') <| ts' + + TreeN (Cell bp ep KeyBrackets{}) _ :< _ + | (rl,ts) <- spanlBrackets trees + , not (null rl) -> + (<| go inh ts) $ + TreeN (Cell bp ep "references") $ + rl >>= xmlify inh_orig + + _ | (ul,ts) <- spanlItems (==KeyDash) trees + , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ul -> + (<| go inh ts) $ + TreeN (Cell bp ep "ul") $ + ul >>= xmlify inh{inh_tree0=List.repeat xmlPara} + + _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trees + , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ol -> + (<| go inh ts) $ + TreeN (Cell bp ep "ol") $ + ol >>= xmlify inh{inh_tree0=List.repeat xmlPara} + + t@(Tree0 toks) :< ts | isTokenElem toks -> + xmlify inh_orig t <> + go inh ts + + t@(Tree0 toks) :< ts -> + case inh_tree0 inh of + [] -> + xmlify inh_orig t <> + go inh{inh_tree0=[]} ts + x:xs -> + case Seq.viewl toks of + EmptyL -> go inh{inh_tree0=xs} ts + Cell bp _ep _ :< _ -> + (<| go inh{inh_tree0=xs} ts) $ + x bp $ + xmlify inh_orig t + + t: + xmlify inh_orig t <> + go inh ts + + _ -> mempty +instance Xmlify TCT where + xmlify inh tr = + case tr of + TreeN (Cell bp ep KeySection{}) ts -> + let (attrs,body) = partitionAttributesChildren ts in + let inh' = inh + { inh_tree0 = xmlTitle : List.repeat xmlPara + , inh_figure = True + } in + Seq.singleton $ + TreeN (Cell bp ep "section") $ + xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <> + xmlify inh' body + + TreeN key@(Cell bp ep (KeyColon kn _)) ts -> + let (attrs,body) = partitionAttributesChildren ts in + let inh' = inh { inh_tree0 = + case kn of + "about" -> xmlTitle : xmlTitle : List.repeat xmlPara + "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara + "serie" -> List.repeat xmlName + "author" -> List.repeat xmlName + "editor" -> List.repeat xmlName + "org" -> List.repeat xmlName + _ -> [] + } in + case () of + _ | kn == "about" -> xmlAbout inh' key attrs body + + _ | inh_figure inh && not (kn`List.elem`elems) -> + Seq.singleton $ + TreeN (Cell bp ep "figure") $ + xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <> + case toList body of + [Tree0{}] -> xmlify inh'{inh_tree0 = List.repeat xmlPara} body + _ -> xmlify inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body + + _ -> Seq.singleton $ xmlKey inh' key attrs body + + TreeN key ts -> Seq.singleton $ xmlKey inh key mempty ts + + Tree0 ts -> xmlify inh ts +instance Xmlify Tokens where + xmlify inh toks = + case Seq.viewl toks of + Cell bp _ep (TokenPair PairParen paren) + :< (Seq.viewl -> Cell bb eb (TokenPair PairBracket bracket) + :< ts) -> + (<| xmlify inh ts) $ + case bracket of + (toList -> [Cell bl el (TokenLink lnk)]) -> + TreeN (Cell bp eb "eref") $ + xmlAttrs [Cell bl el ("to",lnk)] <> + xmlify inh paren + _ -> + TreeN (Cell bp eb "rref") $ + xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.textify bracket)] <> + xmlify inh paren + t :< ts -> xmlify inh t `unionXml` xmlify inh ts + Seq.EmptyL -> mempty +instance Xmlify (Cell Token) where + xmlify inh (Cell bp ep tk) = + case tk of + TokenPlain t -> Seq.singleton $ Tree0 $ cell $ XmlText t + TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)] + TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c + TokenLink lnk -> Seq.singleton $ + TreeN (cell "eref") $ + xmlAttrs [cell ("to",lnk)] + TokenPair PairBracket ts | to <- Plain.textify ts + , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> + Seq.singleton $ + TreeN (cell "rref") $ + xmlAttrs [cell ("to",TL.toStrict to)] + TokenPair PairStar ts -> Seq.singleton $ TreeN (cell "b") $ xmlify inh ts + TokenPair PairSlash ts -> Seq.singleton $ TreeN (cell "i") $ xmlify inh ts + TokenPair PairBackquote ts -> Seq.singleton $ TreeN (cell "code") $ xmlify inh ts + TokenPair PairFrenchquote toks@ts -> + Seq.singleton $ + TreeN (cell "q") $ + case ts of + (Seq.viewl -> Cell bl el (TokenPlain l) :< ls) -> + case Seq.viewr ls of + m :> Cell br er (TokenPlain r) -> + xmlify inh $ + Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)) + <|(m|>Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))) + _ -> + xmlify inh $ + Cell bl el (TokenPlain (Text.dropAround Char.isSpace l)) <| ls + (Seq.viewr -> rs :> Cell br er (TokenPlain r)) -> + xmlify inh $ + rs |> Cell br er (TokenPlain (Text.dropAround Char.isSpace r)) + _ -> xmlify inh toks + TokenPair PairHash to -> + Seq.singleton $ + TreeN (cell "ref") $ + xmlAttrs [cell ("to",TL.toStrict $ Plain.textify to)] + TokenPair (PairElem name attrs) ts -> + Seq.singleton $ + TreeN (cell $ xmlLocalName name) $ + xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> cell (xmlLocalName attr_name,attr_value)) <$> attrs) <> + xmlify inh ts + TokenPair p ts -> + let (o,c) = pairBorders p ts in + Seq.singleton (Tree0 $ Cell bp bp $ XmlText o) `unionXml` + xmlify inh ts `unionXml` + Seq.singleton (Tree0 $ Cell ep ep $ XmlText c) + where + cell :: a -> Cell a + cell = Cell bp ep + mimetype :: Text -> Maybe Text mimetype "hs" = Just "text/x-haskell" mimetype "sh" = Just "text/x-shellscript" @@ -78,121 +253,16 @@ xmlDocument trees = (\case TreeN (unCell -> KeyColon "about" _) _ -> True _ -> False) vs' of - Just{} -> vs' Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs' - in - xmlTCTs def + Just{} -> vs' in + xmlify def { inh_titles = titles , inh_figure = True , inh_tree0 = List.repeat xmlPara } vs'' <> - xmlTCTs def ts - _ -> xmlTCTs def trees - _ -> xmlTCTs def trees - -xmlTCTs :: Inh -> TCTs -> XMLs -xmlTCTs inh_orig = go inh_orig - where - go :: Inh -> TCTs -> XMLs - go inh trees = - case Seq.viewl trees of - TreeN (Cell bp ep (KeyBar n _)) _ :< _ - | (body,ts) <- spanlBar n trees - , not (null body) -> - (<| go inh ts) $ - TreeN (Cell bp ep "artwork") $ - maybe id (\v -> (Tree0 (Cell bp ep (XmlAttr "type" v)) <|)) (mimetype n) $ - body >>= xmlTCT inh{inh_tree0=[]} - - TreeN key@(unCell -> KeyColon n _) cs :< ts - | (cs',ts') <- spanlKeyColon n ts - , not (null cs') -> - go inh $ TreeN key (cs<>cs') <| ts' - - TreeN (Cell bp ep KeyBrackets{}) _ :< _ - | (rl,ts) <- spanlBrackets trees - , not (null rl) -> - (<| go inh ts) $ - TreeN (Cell bp ep "references") $ - rl >>= xmlTCT inh_orig - - _ | (ul,ts) <- spanlItems (==KeyDash) trees - , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ul -> - (<| go inh ts) $ - TreeN (Cell bp ep "ul") $ - ul >>= xmlTCT inh{inh_tree0=List.repeat xmlPara} - - _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trees - , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ol -> - (<| go inh ts) $ - TreeN (Cell bp ep "ol") $ - ol >>= xmlTCT inh{inh_tree0=List.repeat xmlPara} - - t@(Tree0 toks) :< ts | isTokenElem toks -> - xmlTCT inh_orig t <> - go inh ts - - t@(Tree0 toks) :< ts -> - case inh_tree0 inh of - [] -> - xmlTCT inh_orig t <> - go inh{inh_tree0=[]} ts - x:xs -> - case Seq.viewl toks of - EmptyL -> go inh{inh_tree0=xs} ts - Cell bp _ep _ :< _ -> - (<| go inh{inh_tree0=xs} ts) $ - x bp $ - xmlTCT inh_orig t - - t: - xmlTCT inh_orig t <> - go inh ts - - _ -> mempty - -xmlTCT :: Inh -> TCT -> XMLs -xmlTCT inh tr = - case tr of - TreeN (Cell bp ep KeySection{}) ts -> - let (attrs,body) = partitionAttributesChildren ts in - let inh' = inh - { inh_tree0 = xmlTitle : List.repeat xmlPara - , inh_figure = True - } in - Seq.singleton $ - TreeN (Cell bp ep "section") $ - xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <> - xmlTCTs inh' body - - TreeN key@(Cell bp ep (KeyColon kn _)) ts -> - let (attrs,body) = partitionAttributesChildren ts in - let inh' = inh { inh_tree0 = - case kn of - "about" -> xmlTitle : xmlTitle : List.repeat xmlPara - "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara - "serie" -> List.repeat xmlName - "author" -> List.repeat xmlName - "editor" -> List.repeat xmlName - "org" -> List.repeat xmlName - _ -> [] - } in - case () of - _ | kn == "about" -> xmlAbout inh' key attrs body - - _ | inh_figure inh && not (kn`List.elem`elems) -> - Seq.singleton $ - TreeN (Cell bp ep "figure") $ - xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <> - case toList body of - [Tree0{}] -> xmlTCTs inh'{inh_tree0 = List.repeat xmlPara} body - _ -> xmlTCTs inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body - - _ -> Seq.singleton $ xmlKey inh' key attrs body - - TreeN key ts -> Seq.singleton $ xmlKey inh key mempty ts - - Tree0 ts -> xmlTokens ts + xmlify def ts + _ -> xmlify def trees + _ -> xmlify def trees xmlAbout :: Inh -> @@ -216,8 +286,8 @@ xmlKey inh (Cell bp ep key) attrs ts = KeyGreat n _wh -> d_key n KeyEqual n _wh -> d_key n KeyBar n _wh -> d_key n - KeyDot _n -> TreeN (cell "li") $ xmlTCTs inh ts - KeyDash -> TreeN (cell "li") $ xmlTCTs inh ts + KeyDot _n -> TreeN (cell "li") $ xmlify inh ts + KeyDash -> TreeN (cell "li") $ xmlify inh ts KeyDashDash -> Tree0 $ cell $ XmlComment $ TL.toStrict com where com :: TL.Text @@ -226,17 +296,17 @@ xmlKey inh (Cell bp ep key) attrs ts = TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> ts - KeyLower n as -> TreeN (cell "artwork") $ xmlTCTs inh ts + KeyLower n as -> TreeN (cell "artwork") $ xmlify inh ts KeyBrackets ident -> let inh' = inh{inh_figure = False} in let (attrs',body) = partitionAttributesChildren ts in TreeN (cell "reference") $ xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <> - xmlTCTs inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body + xmlify inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body KeyDotSlash p -> TreeN (cell "include") $ xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <> - xmlTCTs inh ts + xmlify inh ts where cell :: a -> Cell a cell = Cell bp ep @@ -244,81 +314,10 @@ xmlKey inh (Cell bp ep key) attrs ts = d_key n = TreeN (cell $ xmlLocalName n) $ xmlAttrs attrs <> - xmlTCTs inh ts + xmlify inh ts -xmlTokens :: Tokens -> XMLs -xmlTokens tok = goTokens tok - where - go :: Cell Token -> XMLs - go (Cell bp ep tk) = - case tk of - TokenPlain t -> Seq.singleton $ Tree0 $ cell $ XmlText t - TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)] - TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c - TokenLink lnk -> Seq.singleton $ - TreeN (cell "eref") $ - xmlAttrs [cell ("to",lnk)] - TokenPair PairBracket ts | to <- Plain.textify ts - , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> - Seq.singleton $ - TreeN (cell "rref") $ - xmlAttrs [cell ("to",TL.toStrict to)] - TokenPair PairStar ts -> Seq.singleton $ TreeN (cell "b") $ goTokens ts - TokenPair PairSlash ts -> Seq.singleton $ TreeN (cell "i") $ goTokens ts - TokenPair PairBackquote ts -> Seq.singleton $ TreeN (cell "code") $ goTokens ts - TokenPair PairFrenchquote toks@ts -> - Seq.singleton $ - TreeN (cell "q") $ - case ts of - (Seq.viewl -> Cell bl el (TokenPlain l) :< ls) -> - case Seq.viewr ls of - m :> Cell br er (TokenPlain r) -> - goTokens $ - Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)) - <|(m|>Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))) - _ -> - goTokens $ - Cell bl el (TokenPlain (Text.dropAround Char.isSpace l)) <| ls - (Seq.viewr -> rs :> Cell br er (TokenPlain r)) -> - goTokens $ - rs |> Cell br er (TokenPlain (Text.dropAround Char.isSpace r)) - _ -> goTokens toks - TokenPair PairHash to -> - Seq.singleton $ - TreeN (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Plain.textify to)] - TokenPair (PairElem name attrs) ts -> - Seq.singleton $ - TreeN (cell $ xmlLocalName name) $ - xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> cell (xmlLocalName attr_name,attr_value)) <$> attrs) <> - goTokens ts - TokenPair p ts -> - let (o,c) = pairBorders p ts in - Seq.singleton (Tree0 $ Cell bp bp $ XmlText o) `unionXml` - goTokens ts `unionXml` - Seq.singleton (Tree0 $ Cell ep ep $ XmlText c) - where - cell :: a -> Cell a - cell = Cell bp ep - - goTokens :: Tokens -> XMLs - goTokens toks = - case Seq.viewl toks of - Cell bp _ep (TokenPair PairParen paren) - :< (Seq.viewl -> Cell bb eb (TokenPair PairBracket bracket) - :< ts) -> - (<| goTokens ts) $ - case bracket of - (toList -> [Cell bl el (TokenLink lnk)]) -> - TreeN (Cell bp eb "eref") $ - xmlAttrs [Cell bl el ("to",lnk)] <> - goTokens paren - _ -> - TreeN (Cell bp eb "rref") $ - xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.textify bracket)] <> - goTokens paren - t :< ts -> go t `unionXml` goTokens ts - Seq.EmptyL -> mempty +xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs +xmlAttrs = ((\(Cell bp ep (n,v)) -> Tree0 (Cell bp ep $ XmlAttr n v)) <$>) -- | Unify two 'XMLs', merging border 'XmlText's if any. unionXml :: XMLs -> XMLs -> XMLs @@ -334,7 +333,6 @@ unionXml x y = (Seq.EmptyR, _) -> y (_, Seq.EmptyL) -> x - spanlBar :: Name -> TCTs -> (TCTs, TCTs) spanlBar name = first unKeyBar . spanBar where @@ -422,9 +420,6 @@ defXmlAttr a@(unCell -> (k, _v)) as = Just _idx -> as Nothing -> a <| as -xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs -xmlAttrs = ((\(Cell bp ep (n,v)) -> Tree0 (Cell bp ep $ XmlAttr n v)) <$>) - partitionAttributesChildren :: TCTs -> (Seq (Cell (XmlName, Text)), TCTs) partitionAttributesChildren ts = (attrs,cs) where -- 2.42.0 From ad1c8c9a4517a4d6fe931daec46b01f7eeb58ce3 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 25 Dec 2017 19:08:09 +0100 Subject: [PATCH 06/16] Add DTC support. --- Data/TreeSeq/Strict.hs | 2 +- Language/DTC/Anchor.hs | 74 ++++--- Language/DTC/Document.hs | 10 +- Language/DTC/Sym.hs | 4 +- Language/DTC/Write/HTML5.hs | 399 ++++++++++++++++++++---------------- Language/DTC/Write/Plain.hs | 2 +- Language/DTC/Write/XML.hs | 4 +- 7 files changed, 279 insertions(+), 216 deletions(-) diff --git a/Data/TreeSeq/Strict.hs b/Data/TreeSeq/Strict.hs index 37daefc..3c967bb 100644 --- a/Data/TreeSeq/Strict.hs +++ b/Data/TreeSeq/Strict.hs @@ -35,7 +35,7 @@ instance Traversable (Tree k) where sequenceA (TreeN k ts) = TreeN k <$> traverse sequenceA ts instance Foldable (Tree k) where foldMap f (TreeN _k ts) = foldMap (foldMap f) ts - foldMap f (Tree0 k) = f k + foldMap f (Tree0 a) = f a instance Applicative (Tree k) where pure = Tree0 (<*>) = ap diff --git a/Language/DTC/Anchor.hs b/Language/DTC/Anchor.hs index 20e6869..d2d5021 100644 --- a/Language/DTC/Anchor.hs +++ b/Language/DTC/Anchor.hs @@ -60,19 +60,24 @@ irefsOfTerms = TreeMap.fromList const . (>>= f) . concat -- * Type 'Rrefs' type Rrefs = Map Ident [Anchor] +-- * Type 'Notes' +type Notes = Map Pos [(Nat1,Para)] + -- * Type 'State' data State = State - { state_irefs :: Irefs + { state_section :: Pos + , state_irefs :: Irefs , state_rrefs :: Rrefs - , state_section :: Pos - } -state :: State -state = State - { state_irefs = mempty - , state_rrefs = mempty - , state_section = def + , state_notes :: Notes } +instance Default State where + def = State + { state_section = def + , state_irefs = mempty + , state_rrefs = mempty + , state_notes = mempty + } -- * Class 'Anchorify' class Anchorify a where @@ -101,8 +106,8 @@ instance Anchorify BodyKey where <*> pure aliases instance Anchorify BodyValue where anchorify = \case - d@ToC{} -> pure d - d@ToF{} -> pure d + d@ToC{} -> pure d + d@ToF{} -> pure d d@Index{} -> pure d Figure{..} -> Figure pos attrs type_ @@ -113,6 +118,8 @@ instance Anchorify BodyValue where <$> anchorify refs Block v -> Block <$> anchorify v +instance Anchorify a => Anchorify (Maybe a) where + anchorify = mapM anchorify instance Anchorify [Reference] where anchorify = mapM anchorify instance Anchorify [Block] where @@ -135,31 +142,38 @@ instance Anchorify Para where if null state_irefs then return ls else join <$> traverse indexifyLines ls - traverse referencifyLines indexed + traverse go indexed + where + go :: Lines -> S.State State Lines + go t = + case t of + Tree0{} -> return t + TreeN k ts -> + TreeN + <$> (case k of + Note{..} -> do + State{..} <- S.get + let notes = Map.findWithDefault [] state_section state_notes + let count | (cnt,_):_ <- notes = succNat1 cnt + | otherwise = Nat1 1 + S.modify $ \s -> s{state_notes= + Map.insert state_section ((count,ts):notes) state_notes} + return Note{number=Just count} + Rref{..} -> do + State{..} <- S.get + let anchs = Map.findWithDefault [] to state_rrefs + let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c + let anch = Anchor{count, section=state_section} + S.modify $ \s -> s{state_rrefs= + Map.insert to (anch:anchs) state_rrefs} + return Rref{anchor=Just anch, to} + _ -> return k) + <*> traverse go ts instance Anchorify Reference where anchorify = return instance Anchorify Artwork where anchorify = return -referencifyLines :: Lines -> S.State State Lines -referencifyLines t = - case t of - Tree0{} -> return t - TreeN k ts -> do - k' <- - case k of - Rref{..} -> do - State{..} <- S.get - let anchs = Map.findWithDefault [] to state_rrefs - let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c - let anch = Anchor{count, section=state_section} - S.modify $ \s -> s{state_rrefs= - Map.insert to (anch:anchs) state_rrefs} - return Rref{anchor=Just anch, to} - _ -> return k - TreeN k' - <$> traverse referencifyLines ts - indexifyLines :: Lines -> S.State State Para indexifyLines = \case Tree0 a -> indexifyPlain a diff --git a/Language/DTC/Document.hs b/Language/DTC/Document.hs index 2a47916..9752c92 100644 --- a/Language/DTC/Document.hs +++ b/Language/DTC/Document.hs @@ -112,7 +112,7 @@ data BodyValue | Figure { pos :: Pos , attrs :: CommonAttrs , type_ :: Text - , title :: Title + , title :: Maybe Title , blocks :: Blocks } | Index { pos :: Pos @@ -210,7 +210,7 @@ data LineKey | Code | Del | I - | Note + | Note {number :: Maybe Nat1} | Q | SC | Sub @@ -225,9 +225,9 @@ data LineKey -- ** Type 'Anchor' data Anchor = Anchor - { count :: Nat1 - , section :: Pos - } deriving (Eq,Show) + { section :: Pos + , count :: Nat1 + } deriving (Eq,Ord,Show) -- ** Type 'LineValue' data LineValue diff --git a/Language/DTC/Sym.hs b/Language/DTC/Sym.hs index 0a6e1ad..a37f465 100644 --- a/Language/DTC/Sym.hs +++ b/Language/DTC/Sym.hs @@ -185,7 +185,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where <$> position <*> commonAttrs <*> attribute "type" text - <*> title + <*> optional title <*> many block references = element "references" $ @@ -201,7 +201,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where , element "code" $ TreeN DTC.Code <$> para , element "del" $ TreeN DTC.Del <$> para , element "i" $ TreeN DTC.I <$> para - , element "note" $ TreeN DTC.Note <$> para + , element "note" $ TreeN (DTC.Note Nothing) <$> para , element "q" $ TreeN DTC.Q <$> para , element "sc" $ TreeN DTC.SC <$> para , element "sub" $ TreeN DTC.Sub <$> para diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs index 28bf90d..b394d6f 100644 --- a/Language/DTC/Write/HTML5.hs +++ b/Language/DTC/Write/HTML5.hs @@ -72,16 +72,17 @@ infixl 4 <&> -- * Type 'Html5' type Html5 = StateMarkup State () --- ** Type 'State' +-- * Type 'State' data State = State - { state_styles :: Map FilePath CSS - , state_scripts :: Map FilePath Script - , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs) - , state_rrefs :: Anchor.Rrefs - , state_figures :: Map Text (Map DTC.Pos DTC.Title) - , state_references :: Map DTC.Ident DTC.About - , state_plainify :: Plain.State + { state_styles :: Map FilePath CSS + , state_scripts :: Map FilePath Script + , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs) + , state_rrefs :: Anchor.Rrefs + , state_figures :: Map Text (Map DTC.Pos (Maybe DTC.Title)) + , state_references :: Map DTC.Ident DTC.About + , state_notes :: Anchor.Notes + , state_plainify :: Plain.State } instance Default State where def = State @@ -91,39 +92,56 @@ instance Default State where , state_rrefs = mempty , state_figures = mempty , state_references = mempty + , state_notes = mempty , state_plainify = def } type CSS = Text type Script = Text --- ** Type 'Keys' +-- * Type 'Keys' data Keys = Keys { keys_index :: Map DTC.Pos DTC.Terms - , keys_figure :: Map Text (Map DTC.Pos DTC.Title) + , keys_figure :: Map Text (Map DTC.Pos (Maybe DTC.Title)) , keys_reference :: Map DTC.Ident DTC.About } deriving (Show) +instance Default Keys where + def = Keys mempty mempty mempty -keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys -keys body = foldl' flt (Keys mempty mempty mempty) (Compose body) - where - flt acc = \case - DTC.Index{..} -> acc{keys_index = - Map.insert pos terms $ keys_index acc} - DTC.Figure{..} -> acc{keys_figure = - Map.insertWith (<>) - type_ (Map.singleton pos title) $ - keys_figure acc} - DTC.References{..} -> acc{keys_reference = - foldr - (\r -> Map.insert - (DTC.id (r::DTC.Reference)) - (DTC.about (r::DTC.Reference))) - (keys_reference acc) - refs} - _ -> acc +-- ** Class 'KeysOf' +class KeysOf a where + keys :: a -> S.State Keys () +instance KeysOf (Trees DTC.BodyKey DTC.BodyValue) where + keys = mapM_ keys +instance KeysOf (Tree DTC.BodyKey DTC.BodyValue) where + keys = \case + TreeN k ts -> + case k of + DTC.Section{..} -> + keys ts + Tree0 v -> + case v of + DTC.Index{..} -> + S.modify $ \s -> s{keys_index= + Map.insert pos terms $ keys_index s} + DTC.Figure{..} -> + S.modify $ \s -> s{keys_figure= + Map.insertWith (<>) + type_ (Map.singleton pos title) $ + keys_figure s} + DTC.References{..} -> + S.modify $ \s -> s{keys_reference= + foldr + (\r -> Map.insert + (DTC.id (r::DTC.Reference)) + (DTC.about (r::DTC.Reference))) + (keys_reference s) + refs} + DTC.ToC{} -> return () + DTC.ToF{} -> return () + DTC.Block{} -> return () --- ** Class 'Html5ify' +-- * Class 'Html5ify' class Html5ify a where html5ify :: a -> Html5 instance Html5ify Char where @@ -154,13 +172,13 @@ html5Document :: Locales ls => LocaleIn ls -> DTC.Document -> Html html5Document locale DTC.Document{..} = do - let Keys{..} = keys body - let (body',state_rrefs,state_indexs) = + let Keys{..} = keys body `S.execState` def + let (body',state_rrefs,state_notes,state_indexs) = let irefs = foldMap Anchor.irefsOfTerms keys_index in - let (body0, Anchor.State{state_irefs, state_rrefs=rrefs}) = + let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) = Anchor.anchorify body `S.runState` - Anchor.state{Anchor.state_irefs=irefs} in - (body0,rrefs,) $ + def{Anchor.state_irefs=irefs} in + (body0,rrefs,notes,) $ (<$> keys_index) $ \terms -> (terms,) $ TreeMap.intersection const state_irefs $ @@ -171,6 +189,7 @@ html5Document locale DTC.Document{..} = do runStateMarkup def { state_indexs , state_rrefs + , state_notes , state_figures = keys_figure , state_references = keys_reference , state_plainify @@ -217,114 +236,130 @@ instance Html5ify DTC.Body where forM_ (Tree.zippers body) $ \z -> forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $ html5ify - -instance Html5ify BodyCursor where - html5ify z = - case Tree.current z of - TreeN k _ts -> html5BodyKey z k - Tree0 v -> html5BodyValue z v - -html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5 -html5BodyKey z = \case - DTC.Section{..} -> - H.section ! HA.class_ "section" - ! HA.id (attrify pos) $$ do +instance Html5ify BodyCursor + where html5ify z = + case Tree.current z of + TreeN k _ts -> + case k of + DTC.Section{..} -> + H.section ! HA.class_ "section" + ! HA.id (attrify pos) $$ do + html5CommonAttrs attrs $ + H.table ! HA.class_ "section-header" $$ + H.tbody $$ + H.tr $$ do + H.td ! HA.class_ "section-number" $$ do + html5SectionNumber $ DTC.posAncestors pos + H.td ! HA.class_ "section-title" $$ do + (case List.length $ DTC.posAncestors pos of + 0 -> H.h1 + 1 -> H.h2 + 2 -> H.h3 + 3 -> H.h4 + 4 -> H.h5 + 5 -> H.h6 + _ -> H.h6) $$ + html5ify title + forM_ (Tree.axis_child `Tree.runAxis` z) $ + html5ify + notes <- liftStateMarkup $ S.gets state_notes + case Map.lookup pos notes of + Nothing -> return () + Just ns -> + H.aside ! HA.class_ "notes" $$ do + Compose $ pure H.hr + H.table $$ + H.tbody $$ + forM_ ns $ \(num,para) -> + H.tr $$ do + H.td ! HA.class_ "note-ref" $$ do + H.a ! HA.class_ "note-number" + ! HA.id ("note."<>attrify num) + ! HA.href ("#note."<>attrify num) $$ do + html5ify num + ". "::Html5 + H.a ! HA.href ("#note-ref."<>attrify num) $$ do + "↑" + H.td $$ + html5ify para + Tree0 v -> + case v of + DTC.Block b -> html5ify b + DTC.ToC{..} -> do + H.nav ! HA.class_ "toc" + ! HA.id (attrify pos) $$ do + H.span ! HA.class_ "toc-name" $$ + H.a ! HA.href (attrify pos) $$ + html5ify Plain.L10n_Table_of_Contents + H.ul $$ + forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $ + html5ifyToC depth + DTC.ToF{..} -> do + H.nav ! HA.class_ "tof" + ! HA.id (attrify pos) $$ + H.table ! HA.class_ "tof" $$ + H.tbody $$ + html5ifyToF types + DTC.Figure{..} -> html5CommonAttrs attrs $ - H.table ! HA.class_ "section-header" $$ + H.div ! HA.class_ ("figure " <> attrify ("figure-"<>type_)) + ! HA.id (attrify pos) $$ do + H.table ! HA.class_ "figure-caption" $$ H.tbody $$ H.tr $$ do - H.td ! HA.class_ "section-number" $$ do - html5SectionNumber $ DTC.posAncestors pos - H.td ! HA.class_ "section-title" $$ do - (case List.length $ DTC.posAncestors pos of - 0 -> H.h1 - 1 -> H.h2 - 2 -> H.h3 - 3 -> H.h4 - 4 -> H.h5 - 5 -> H.h6 - _ -> H.h6) $$ - html5ify title - forM_ (Tree.axis_child `Tree.runAxis` z) $ - html5ify -html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5 -html5BodyValue z = \case - DTC.Block b -> html5ify b - DTC.ToC{..} -> do - H.nav ! HA.class_ "toc" - ! HA.id (attrify pos) $$ do - H.span ! HA.class_ "toc-name" $$ - H.a ! HA.href (attrify pos) $$ - html5ify Plain.L10n_Table_of_Contents - H.ul $$ - forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $ - html5ifyToC depth - DTC.ToF{..} -> do - H.nav ! HA.class_ "tof" - ! HA.id (attrify pos) $$ - H.table ! HA.class_ "tof" $$ - H.tbody $$ - html5ifyToF types - DTC.Figure{..} -> - html5CommonAttrs attrs $ - H.div ! HA.class_ ("figure " <> attrify ("figure-"<>type_)) - ! HA.id (attrify pos) $$ do - H.table ! HA.class_ "figure-caption" $$ - H.tbody $$ - H.tr $$ do - H.td ! HA.class_ "figure-number" $$ do - H.a ! HA.href ("#"<>attrify pos) $$ do - html5ify type_ - html5ify $ DTC.posAncestors pos - html5ify $ Plain.L10n_Colon - H.td ! HA.class_ "figure-name" $$ - html5ify title - H.div ! HA.class_ "figure-content" $$ do - html5ify blocks - DTC.Index{pos} -> do - (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs - let chars = Anchor.termsByChar allTerms - H.div ! HA.class_ "index" - ! HA.id (attrify pos) $$ do - H.nav ! HA.class_ "index-nav" $$ do - forM_ (Map.keys chars) $ \char -> - H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$ - html5ify char - H.dl ! HA.class_ "index-chars" $$ - forM_ (Map.toList chars) $ \(char,terms) -> do - H.dt $$ - let i = attrify pos <> "." <> attrify char in - H.a ! HA.id i - ! HA.href ("#"<>i) $$ + H.td ! HA.class_ "figure-number" $$ do + H.a ! HA.href ("#"<>attrify pos) $$ do + html5ify type_ + html5ify $ DTC.posAncestors pos + forM_ title $ \ti -> do + html5ify $ Plain.L10n_Colon + H.td ! HA.class_ "figure-title" $$ + html5ify ti + H.div ! HA.class_ "figure-content" $$ do + html5ify blocks + DTC.Index{pos} -> do + (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs + let chars = Anchor.termsByChar allTerms + H.div ! HA.class_ "index" + ! HA.id (attrify pos) $$ do + H.nav ! HA.class_ "index-nav" $$ do + forM_ (Map.keys chars) $ \char -> + H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$ html5ify char - H.dd $$ - H.dl ! HA.class_ "index-term" $$ do - forM_ terms $ \aliases -> do - H.dt $$ - H.ul ! HA.class_ "index-aliases" $$ - forM_ (List.take 1 aliases) $ \term -> - H.li ! HA.id (attrify term) $$ - html5ify term - H.dd $$ - let anchs = - List.sortBy (compare `on` DTC.section . snd) $ - (`foldMap` aliases) $ \words -> - fromJust $ do - path <- Anchor.pathFromWords words - Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $ - TreeMap.lookup path refsByTerm in - html5CommasDot $ - (<$> anchs) $ \(term,DTC.Anchor{..}) -> - H.a ! HA.class_ "index-iref" - ! HA.href ("#"<>attrify (term,count)) $$ - html5ify $ DTC.posAncestors section - DTC.References{..} -> - html5CommonAttrs attrs $ - H.div ! HA.class_ "references" - ! HA.id (attrify pos) $$ do - H.table $$ - forM_ refs html5ify - + H.dl ! HA.class_ "index-chars" $$ + forM_ (Map.toList chars) $ \(char,terms) -> do + H.dt $$ + let i = attrify pos <> "." <> attrify char in + H.a ! HA.id i + ! HA.href ("#"<>i) $$ + html5ify char + H.dd $$ + H.dl ! HA.class_ "index-term" $$ do + forM_ terms $ \aliases -> do + H.dt $$ + H.ul ! HA.class_ "index-aliases" $$ + forM_ (List.take 1 aliases) $ \term -> + H.li ! HA.id (attrifyIref term) $$ + html5ify term + H.dd $$ + let anchs = + List.sortBy (compare `on` DTC.section . snd) $ + (`foldMap` aliases) $ \words -> + fromJust $ do + path <- Anchor.pathFromWords words + Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $ + TreeMap.lookup path refsByTerm in + html5CommasDot $ + (<$> anchs) $ \(term,DTC.Anchor{..}) -> + H.a ! HA.class_ "index-iref" + ! HA.href ("#"<>attrifyIrefCount term count) $$ + html5ify $ DTC.posAncestors section + DTC.References{..} -> + html5CommonAttrs attrs $ + H.div ! HA.class_ "references" + ! HA.id (attrify pos) $$ do + H.table $$ + forM_ refs html5ify instance Html5ify DTC.Words where html5ify = html5ify . Anchor.plainifyWords @@ -376,8 +411,9 @@ html5ifyToF types = do H.a ! HA.href ("#"<>attrify pos) $$ do html5ify type_ html5ify $ DTC.posAncestors pos - H.td ! HA.class_ "figure-name" $$ - html5ify $ cleanPara $ DTC.unTitle title + forM_ title $ \ti -> + H.td ! HA.class_ "figure-title" $$ + html5ify $ cleanPara $ DTC.unTitle ti instance Html5ify [DTC.Block] where html5ify = mapM_ html5ify @@ -431,22 +467,30 @@ instance Html5ify DTC.Lines where DTC.Sup -> H.sup $$ html5ify ls DTC.SC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls DTC.U -> H.span ! HA.class_ "underline" $$ html5ify ls - DTC.Note -> "" + DTC.Note{..} -> + case number of + Nothing -> "" + Just num -> + H.sup ! HA.class_ "note-number" $$ + H.a ! HA.class_ "note-ref" + ! HA.id ("note-ref."<>attrify num) + ! HA.href ("#note."<>attrify num) $$ + html5ify num DTC.Q -> do - d <- liftStateMarkup $ do - d <- S.gets $ Plain.state_quote . state_plainify + depth <- liftStateMarkup $ do + depth <- S.gets $ Plain.state_quote . state_plainify S.modify $ \s -> s{state_plainify= (state_plainify s){Plain.state_quote= - DTC.succNat d}} - return d + DTC.succNat depth}} + return depth H.span ! HA.class_ "q" $$ do - html5ify $ Plain.L10n_QuoteOpen d + html5ify $ Plain.L10n_QuoteOpen depth html5ify $ TreeN DTC.I ls - html5ify $ Plain.L10n_QuoteClose d + html5ify $ Plain.L10n_QuoteClose depth liftStateMarkup $ S.modify $ \s -> s{state_plainify= - (state_plainify s){Plain.state_quote = d}} + (state_plainify s){Plain.state_quote = depth}} DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrify href) $$ @@ -458,7 +502,7 @@ instance Html5ify DTC.Lines where Nothing -> html5ify ls Just DTC.Anchor{..} -> H.span ! HA.class_ "iref" - ! HA.id (attrify (term,count)) $$ + ! HA.id (attrifyIrefCount term count) $$ html5ify ls DTC.Ref{..} -> H.a ! HA.class_ "ref" @@ -493,15 +537,6 @@ instance Html5ify DTC.URL where H.a ! HA.class_ "eref" ! HA.href (attrify url) $$ html5ify url - -instance Attrify DTC.Words where - attrify term = - "iref" <> "." <> attrify (Anchor.plainifyWords term) -instance Attrify (DTC.Words,DTC.Nat1) where - attrify (term,count) = - "iref" - <> "." <> attrify (Anchor.plainifyWords term) - <> "." <> attrify count instance Html5ify DTC.Date where html5ify = html5ify . Plain.L10n_Date instance Html5ify DTC.About where @@ -571,6 +606,22 @@ instance Html5ify DTC.Reference where H.a ! HA.class_ "reference-rref" ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$ html5ify $ DTC.posAncestors section +instance Html5ify DTC.PosPath where + html5ify ancs = + case toList ancs of + [(_n,c)] -> do + html5ify $ show c + html5ify '.' + as -> + html5ify $ + Text.intercalate "." $ + Text.pack . show . snd <$> as +instance Html5ify Plain where + html5ify p = do + sp <- liftStateMarkup $ S.gets state_plainify + let (t,sp') = Plain.runPlain p sp + html5ify t + liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'} html5CommasDot :: [Html5] -> Html5 html5CommasDot [] = pure () @@ -608,32 +659,30 @@ html5SectionRef as = H.a ! HA.href ("#"<>attrify as) $$ html5ify as -instance Html5ify DTC.PosPath where - html5ify ancs = - case toList ancs of - [(_n,c)] -> do - html5ify $ show c - html5ify '.' - as -> - html5ify $ - Text.intercalate "." $ - Text.pack . show . snd <$> as -instance Html5ify Plain where - html5ify p = do - sp <- liftStateMarkup $ S.gets state_plainify - let (t,sp') = Plain.runPlain p sp - html5ify t - liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'} + +-- * 'Attrify' +instance Attrify DTC.Anchor where + attrify DTC.Anchor{..} = + attrify section + <> "." <> attrify count instance Attrify Plain where attrify p = let (t,_) = Plain.runPlain p def in attrify t - instance Attrify DTC.PosPath where attrify = attrify . plainify instance Attrify DTC.Pos where attrify = attrify . DTC.posAncestors +attrifyIref :: DTC.Words -> H.AttributeValue +attrifyIref term = + "iref" <> "." <> attrify (Anchor.plainifyWords term) +attrifyIrefCount :: DTC.Words -> DTC.Nat1 -> H.AttributeValue +attrifyIrefCount term count = + "iref" + <> "." <> attrify (Anchor.plainifyWords term) + <> "." <> attrify count + -- * Type 'L10n' instance Html5ify Plain.L10n where html5ify = html5ify . plainify diff --git a/Language/DTC/Write/Plain.hs b/Language/DTC/Write/Plain.hs index 0561da5..5f27d13 100644 --- a/Language/DTC/Write/Plain.hs +++ b/Language/DTC/Write/Plain.hs @@ -95,7 +95,7 @@ instance Plainify DTC.Lines where DTC.Code -> "`"<>plainify ls<>"`" DTC.Del -> "-"<>plainify ls<>"-" DTC.I -> "/"<>plainify ls<>"/" - DTC.Note -> "" + DTC.Note{..} -> "" DTC.Q -> let depth = DTC.Nat 0 in plainify (L10n_QuoteOpen{..}) <> diff --git a/Language/DTC/Write/XML.hs b/Language/DTC/Write/XML.hs index 0c43c1c..ae902c7 100644 --- a/Language/DTC/Write/XML.hs +++ b/Language/DTC/Write/XML.hs @@ -84,7 +84,7 @@ xmlBodyValue = \case xmlCommonAttrs attrs $ XML.figure ! XA.type_ (attrify type_) $ do - xmlTitle title + forM_ title xmlTitle xmlBlocks blocks DTC.References{..} -> xmlCommonAttrs attrs $ @@ -194,7 +194,7 @@ xmlLine = \case DTC.Code -> XML.code $ xmlPara ls DTC.Del -> XML.del $ xmlPara ls DTC.I -> XML.i $ xmlPara ls - DTC.Note -> XML.note $ xmlPara ls + DTC.Note{..} -> XML.note $ xmlPara ls DTC.Q -> XML.q $ xmlPara ls DTC.SC -> XML.sc $ xmlPara ls DTC.Sub -> XML.sub $ xmlPara ls -- 2.42.0 From 9239e2754383a004ce26c622f50b21ecaece8188 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Tue, 26 Dec 2017 14:47:19 +0100 Subject: [PATCH 07/16] Cosmetic changes. --- Language/TCT/Tree.hs | 12 +++++++----- Language/TCT/Write/XML.hs | 24 +++++++++--------------- 2 files changed, 16 insertions(+), 20 deletions(-) diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index e711470..0d97ad9 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -6,9 +6,9 @@ module Language.TCT.Tree , Trees ) where +import Control.Monad (Monad(..)) import Data.Eq (Eq(..)) import Data.Function (($)) -import Data.Functor ((<$>)) import Data.Maybe (Maybe(..)) import Data.Ord (Ordering(..), Ord(..)) import Data.Semigroup (Semigroup(..)) @@ -38,7 +38,7 @@ data Key = KeyColon !Name !White -- ^ @name: @ | KeyDash -- ^ @- @ | KeyDashDash -- ^ @-- @ | KeySection !LevelSection -- ^ @# @ - | KeyBrackets !Name -- ^ @[ name ]@ + | KeyBrackets !Name -- ^ @[name]@ | KeyDotSlash !PathFile -- ^ @./file @ deriving (Eq, Ord, Show) @@ -56,7 +56,7 @@ type Rows = [Tree (Cell Key) (Cell Text)] -- | @appendRow rows row@ appends @row@ to @rows@. -- --- [@rows@] parent 'Rows', from closest to farest (non-strictly descending) +-- [@rows@] parent 'Rows', from closest to farthest (non-strictly descending) -- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending) appendRow :: Rows -> Row -> Rows appendRow [] row = List.reverse row @@ -101,8 +101,10 @@ appendRow rows@(parent:parents) row@(cell:cells) = collapseSection :: Column -> Rows -> Maybe (Int,Rows) collapseSection col xxs@(x:xs) | columnPos (posTree x) == col = case x of - TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs) - _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs + TreeN (unCell -> KeySection lvl) _ -> Just (lvl, xxs) + _ -> do + (lvl, cs) <- collapseSection col xs + return (lvl, insertChild x cs) collapseSection _ _ = Nothing appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text) diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 9796843..93f4465 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -91,22 +91,15 @@ instance Xmlify TCTs where TreeN (Cell bp ep "ol") $ ol >>= xmlify inh{inh_tree0=List.repeat xmlPara} - t@(Tree0 toks) :< ts | isTokenElem toks -> - xmlify inh_orig t <> - go inh ts - t@(Tree0 toks) :< ts -> case inh_tree0 inh of - [] -> - xmlify inh_orig t <> - go inh{inh_tree0=[]} ts - x:xs -> - case Seq.viewl toks of - EmptyL -> go inh{inh_tree0=xs} ts - Cell bp _ep _ :< _ -> - (<| go inh{inh_tree0=xs} ts) $ - x bp $ - xmlify inh_orig t + [] -> xmlify inh_orig t <> go inh ts + _ | isTokenElem toks -> xmlify inh_orig t <> go inh ts + tree0:inh_tree0 -> + (case Seq.viewl toks of + EmptyL -> id + Cell bp _ep _ :< _ -> (tree0 bp (xmlify inh_orig t) <|)) $ + go inh{inh_tree0} ts t: xmlify inh_orig t <> @@ -214,7 +207,8 @@ instance Xmlify (Cell Token) where TokenPair (PairElem name attrs) ts -> Seq.singleton $ TreeN (cell $ xmlLocalName name) $ - xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> cell (xmlLocalName attr_name,attr_value)) <$> attrs) <> + xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> + cell (xmlLocalName attr_name,attr_value)) <$> attrs) <> xmlify inh ts TokenPair p ts -> let (o,c) = pairBorders p ts in -- 2.42.0 From 04525c9a739c9743663a54cfa961c7754d7de16a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 27 Dec 2017 12:11:17 +0100 Subject: [PATCH 08/16] Use Tree for Token. --- Language/DTC/Write/HTML5.hs | 6 +- Language/TCT/Read.hs | 6 +- Language/TCT/Read/Token.hs | 45 +++++------ Language/TCT/Read/Tree.hs | 2 +- Language/TCT/Token.hs | 145 +++++++++++++++++++----------------- Language/TCT/Write/HTML5.hs | 67 +++++++++-------- Language/TCT/Write/Plain.hs | 47 ++++++------ Language/TCT/Write/XML.hs | 108 +++++++++++++++------------ 8 files changed, 227 insertions(+), 199 deletions(-) diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs index b394d6f..eb49167 100644 --- a/Language/DTC/Write/HTML5.hs +++ b/Language/DTC/Write/HTML5.hs @@ -311,9 +311,9 @@ instance Html5ify BodyCursor H.a ! HA.href ("#"<>attrify pos) $$ do html5ify type_ html5ify $ DTC.posAncestors pos - forM_ title $ \ti -> do - html5ify $ Plain.L10n_Colon - H.td ! HA.class_ "figure-title" $$ + forM_ title $ \ti -> + H.td ! HA.class_ "figure-title" $$ do + html5ify $ Plain.L10n_Colon html5ify ti H.div ! HA.class_ "figure-content" $$ do html5ify blocks diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs index 989d388..e96eb31 100644 --- a/Language/TCT/Read.hs +++ b/Language/TCT/Read.hs @@ -52,9 +52,9 @@ readTCTs inp txt = do sequence $ (`TreeSeq.mapWithNode`tr) $ \key c@(Cell pos _posEnd t) -> case key of -- Verbatim Keys - Just (unCell -> KeyBar{}) -> Right $ tokens [TokenPlain <$> c] - Just (unCell -> KeyLower{}) -> Right $ tokens [TokenPlain <$> c] - Just (unCell -> KeyEqual{}) -> Right $ tokens [TokenPlain <$> c] + Just (unCell -> KeyBar{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c] + Just (unCell -> KeyLower{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c] + Just (unCell -> KeyEqual{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c] -- Token Keys _ -> snd $ P.runParser' diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index 201b636..ced91cc 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -18,15 +18,16 @@ import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..), (<|)) import Data.Text (Text) -import Data.Text.Buildable (Buildable(..)) +-- import Data.Text.Buildable (Buildable(..)) +import Data.TreeSeq.Strict (Tree(..)) import Data.Tuple (fst,snd) import Prelude (Num(..)) import Text.Show (Show(..)) import qualified Data.Char as Char import qualified Data.Sequence as Seq import qualified Data.Text as Text -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as Builder +-- import qualified Data.Text.Lazy as TL +-- import qualified Data.Text.Lazy.Builder as Builder import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P @@ -36,13 +37,15 @@ import Language.TCT.Elem import Language.TCT.Read.Elem import Language.TCT.Read.Cell +{- textOf :: Buildable a => a -> Text textOf = TL.toStrict . Builder.toLazyText . build +-} -- * Type 'Pairs' type Pairs = (Tokens,[(Cell Pair,Tokens)]) -appendToken :: Pairs -> Cell Token -> Pairs +appendToken :: Pairs -> Token -> Pairs appendToken ps = appendTokens ps . Seq.singleton appendTokens :: Pairs -> Tokens -> Pairs @@ -56,18 +59,16 @@ openPair (t,ms) p = (t,(p,mempty):ms) closePair :: Pairs -> Cell Pair -> Pairs closePair ps@(_,[]) (Cell bp ep p) = dbg "closePair" $ appendToken ps $ - Cell bp ep $ + Tree0 $ Cell bp ep $ TokenPlain $ snd $ pairBorders p tokensPlainEmpty closePair (t,(p1,t1):ts) p = dbg "closePair" $ case (p1,p) of (Cell bx _ex (PairElem x ax), Cell _by ey (PairElem y ay)) | x == y -> appendToken (t,ts) $ - Cell bx ey $ - TokenPair (PairElem x (ax<>ay)) t1 + TreeN (Cell bx ey $ PairElem x (ax<>ay)) t1 (Cell bx _ex x, Cell _by ey y) | x == y -> appendToken (t,ts) $ - Cell bx ey $ - TokenPair x t1 + TreeN (Cell bx ey x) t1 _ -> (`closePair` p) $ appendTokens @@ -79,19 +80,19 @@ closeUnpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens closeUnpaired acc (Cell bp ep p,toks) = dbg "closeUnpaired" $ case p of -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'. - PairHash | (Cell bt et (TokenPlain t)) :< ts <- Seq.viewl $ toks <> acc -> + PairHash | (Tree0 (Cell bt et (TokenPlain t))) :< ts <- Seq.viewl $ toks <> acc -> case Text.findIndex (not . isTagChar) t of -- Just 0 -> toksHash mempty <> toks <> acc Just i -> - Cell bp bt{columnPos = columnPos bt + i} (TokenTag tag) - <| Cell bt{columnPos = columnPos bt + i + 1} et (TokenPlain t') + Tree0 (Cell bp bt{columnPos = columnPos bt + i} (TokenTag tag)) + <| Tree0 (Cell bt{columnPos = columnPos bt + i + 1} et (TokenPlain t')) <| ts where (tag,t') = Text.splitAt i t Nothing | Text.null t -> toksHash mempty <> toks <> acc - Nothing -> Cell bp et (TokenTag t) <| ts + Nothing -> Tree0 (Cell bp et (TokenTag t)) <| ts _ -> toksHash tokensPlainEmpty <> toks <> acc where - toksHash = tokens1 . Cell bp ep . TokenPlain . fst . pairBorders p + toksHash = tokens1 . Tree0 . Cell bp ep . TokenPlain . fst . pairBorders p isTagChar c = Char.isAlphaNum c || c=='·' || @@ -111,17 +112,17 @@ appendLexeme lex acc = case lex of LexemePairOpen ps -> foldl' open acc ps where - open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Cell ep ep $ TokenPlain "") + open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Tree0 $ Cell ep ep $ TokenPlain "") open a p = openPair a p LexemePairClose ps -> foldl' closePair acc ps - LexemePairAny ps -> appendTokens acc $ tokens $ ((\p -> TokenPlain $ fst $ pairBorders p mempty) <$>) <$> ps - LexemePairBoth ps -> appendTokens acc $ tokens $ ((`TokenPair`mempty) <$>) <$> ps - LexemeEscape c -> appendToken acc $ TokenEscape <$> c - LexemeLink t -> appendToken acc $ TokenLink <$> t + LexemePairAny ps -> appendTokens acc $ tokens $ Tree0 . ((\p -> TokenPlain $ fst $ pairBorders p mempty) <$>) <$> ps + LexemePairBoth ps -> appendTokens acc $ tokens $ (`TreeN`mempty) <$> ps + LexemeEscape c -> appendToken acc $ Tree0 $ TokenEscape <$> c + LexemeLink t -> appendToken acc $ Tree0 $ TokenLink <$> t LexemeWhite (unCell -> "") -> acc - LexemeWhite cs -> appendToken acc $ TokenPlain <$> cs - LexemeAlphaNum cs -> appendToken acc $ TokenPlain . Text.pack <$> cs - LexemeAny cs -> appendToken acc $ TokenPlain . Text.pack <$> cs + LexemeWhite cs -> appendToken acc $ Tree0 $ TokenPlain <$> cs + LexemeAlphaNum cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs + LexemeAny cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs LexemeToken ts -> appendTokens acc ts -- * Type 'Lexeme' diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index dd65c73..30beb65 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -109,7 +109,7 @@ p_CellLower row = pdbg "CellLower" $ do Tree0 $ Cell pos p (o<>c) let indent = fromString $ List.replicate (columnPos pos - 1) ' ' tree <- - P.try (P.char '>' >> treeElem (tokens [cell0 $ TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|> + P.try (P.char '>' >> treeElem (tokens [Tree0 $ cell0 $ TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|> P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|> P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|> (P.eof $> treeHere (Cell posClose posClose "")) diff --git a/Language/TCT/Token.hs b/Language/TCT/Token.hs index 3a57191..7f0a5a3 100644 --- a/Language/TCT/Token.hs +++ b/Language/TCT/Token.hs @@ -6,7 +6,7 @@ module Language.TCT.Token where import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) -import Data.Function ((.)) +import Data.Function (($), (.)) import Data.Foldable (foldMap, foldr) import Data.Maybe (Maybe(..)) import Data.Semigroup (Semigroup(..)) @@ -15,6 +15,7 @@ import Data.Ord (Ord) import Data.Text (Text) import Data.Text.Buildable (Buildable(..)) import Data.Text.Lazy.Builder (Builder) +import Data.TreeSeq.Strict (Tree(..), Trees) import GHC.Exts (IsList(..)) import Text.Show (Show(..)) import qualified Data.Char as Char @@ -25,96 +26,68 @@ import Language.TCT.Cell import Language.TCT.Elem -- * Type 'Token' -data Token +type Token = Tree (Cell TokenKey) (Cell TokenValue) + +-- ** Type 'Tokens' +type Tokens = Seq Token + +-- ** Type 'TokenKey' +type TokenKey = Pair +data Pair + = PairHash -- ^ @#value#@ + | PairElem !Elem !Attrs -- ^ @value@ + | PairStar -- ^ @*value*@ + | PairSlash -- ^ @/value/@ + | PairUnderscore -- ^ @_value_@ + | PairDash -- ^ @-value-@ + | PairBackquote -- ^ @`value`@ + | PairSinglequote -- ^ @'value'@ + | PairDoublequote -- ^ @"value"@ + | PairFrenchquote -- ^ @«value»@ + | PairParen -- ^ @(value)@ + | PairBrace -- ^ @{value}@ + | PairBracket -- ^ @[value]@ + deriving (Eq,Ord,Show) + +-- ** Type 'TokenValue' +data TokenValue = TokenPlain !Text - | TokenPair !Pair !Tokens | TokenTag !Tag | TokenEscape !Char | TokenLink !Text - deriving (Eq, Ord, Show) - -instance Buildable Token where - build (TokenPlain t) = build t - build (TokenTag t) = "#"<>build t - build (TokenLink lnk) = build lnk - build (TokenEscape c) = "\\"<>build c - build (TokenPair p ts) = build c<>buildTokens ts<>build o - where (o,c) = pairBorders p ts + deriving (Eq,Ord,Show) -buildTokens :: Tokens -> Builder -buildTokens = foldr (\a -> (<> build (unCell a))) "" - --- * Type 'Tokens' -type Tokens = Seq (Cell Token) - -{- -instance Semigroup Tokens where - Tokens (Seq.viewr -> xs:>TokenPlain x) <> - Tokens (Seq.viewl -> TokenPlain y:(TokenPlain (x<>y)<|ys)) - Tokens x <> Tokens y = Tokens (x<>y) -instance Monoid Tokens where - mempty = Tokens mempty - mappend = (<>) -instance Buildable Tokens where - build (Tokens ts) = foldr (\a -> (<> build a)) "" ts -instance IsList Tokens where - type Item Tokens = Token - fromList = Tokens . fromList - toList (Tokens ts) = toList ts - -unTokens :: Tokens -> Seq Token -unTokens (Tokens ts) = ts --} +-- *** Type 'Tag' +type Tag = Text -- | Build 'Tokens' from many 'Token's. -tokens :: [Cell Token] -> Tokens +tokens :: [Token] -> Tokens tokens = Seq.fromList -- | Build 'Tokens' from one 'Token'. -tokens1 :: Cell Token -> Tokens +tokens1 :: Token -> Tokens tokens1 = Seq.singleton tokensPlainEmpty :: Tokens -tokensPlainEmpty = Seq.singleton (cell1 (TokenPlain "")) +tokensPlainEmpty = tokens1 $ Tree0 $ cell1 $ TokenPlain "" isTokenWhite :: Token -> Bool -isTokenWhite (TokenPlain t) = Text.all Char.isSpace t -isTokenWhite _ = False +isTokenWhite (Tree0 (unCell -> TokenPlain t)) = Text.all Char.isSpace t +isTokenWhite _ = False unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens)) -unTokenElem ts = - case toList (Seq.dropWhileR (isTokenWhite . unCell) ts) of - [Cell bp ep (TokenPair (PairElem e as) toks)] -> Just (Cell bp ep (e,as,toks)) +unTokenElem toks = + case toList $ Seq.dropWhileR isTokenWhite toks of + [TreeN (Cell bp ep (PairElem e as)) ts] -> Just (Cell bp ep (e,as,ts)) _ -> Nothing isTokenElem :: Tokens -> Bool -isTokenElem ts = - case toList (Seq.dropWhileR (isTokenWhite . unCell) ts) of - [unCell -> TokenPair PairElem{} _] -> True +isTokenElem toks = + case toList $ Seq.dropWhileR isTokenWhite toks of + [TreeN (unCell -> PairElem{}) _] -> True _ -> False --- ** Type 'Tag' -type Tag = Text - --- ** Type 'Pair' -data Pair - = PairHash -- ^ @#value#@ - | PairElem !Elem !Attrs -- ^ @value@ - | PairStar -- ^ @*value*@ - | PairSlash -- ^ @/value/@ - | PairUnderscore -- ^ @_value_@ - | PairDash -- ^ @-value-@ - | PairBackquote -- ^ @`value`@ - | PairSinglequote -- ^ @'value'@ - | PairDoublequote -- ^ @"value"@ - | PairFrenchquote -- ^ @«value»@ - | PairParen -- ^ @(value)@ - | PairBrace -- ^ @{value}@ - | PairBracket -- ^ @[value]@ - deriving (Eq, Ord, Show) - -pairBorders :: Pair -> Tokens -> (Text,Text) +pairBorders :: TokenKey -> Tokens -> (Text,Text) pairBorders p ts = case p of PairElem e attrs -> @@ -139,3 +112,37 @@ pairBorders p ts = PairParen -> ("(",")") PairBrace -> ("{","}") PairBracket -> ("[","]") + + +{- +instance Buildable Token where + build (TokenPlain t) = build t + build (TokenTag t) = "#"<>build t + build (TokenLink lnk) = build lnk + build (TokenEscape c) = "\\"<>build c + build (TokenPair p ts) = build c<>buildTokens ts<>build o + where (o,c) = pairBorders p ts + +buildTokens :: Tokens -> Builder +buildTokens = foldr (\a -> (<> build (unCell a))) "" + +instance Semigroup Tokens where + Tokens (Seq.viewr -> xs:>TokenPlain x) <> + Tokens (Seq.viewl -> TokenPlain y:(TokenPlain (x<>y)<|ys)) + Tokens x <> Tokens y = Tokens (x<>y) +instance Monoid Tokens where + mempty = Tokens mempty + mappend = (<>) +instance Buildable Tokens where + build (Tokens ts) = foldr (\a -> (<> build a)) "" ts +instance IsList Tokens where + type Item Tokens = Token + fromList = Tokens . fromList + toList (Tokens ts) = toList ts + +unTokens :: Tokens -> Seq Token +unTokens (Tokens ts) = ts +-} + + diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index 1b4e3b2..c0590af 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -81,7 +81,7 @@ instance Html5ify (Tree (Pos,Cell Key) (Pos,Tokens)) where html5ify (Tree0 (posEnd,toks)) = case Seq.viewl toks of EmptyL -> html5ify toks - t0:<_ -> html5ifyIndentCell (posEnd,posCell t0) <> html5ify toks + t0:<_ -> html5ifyIndentCell (posEnd,posTree t0) <> html5ify toks html5ify (TreeN (posEnd,cell@(Cell pos _ _)) cs) = html5ifyIndentCell (posEnd,pos) <> html5ify (cell, cs) @@ -122,37 +122,15 @@ instance Html5ify Tokens where html5ify toks = case Seq.viewl toks of EmptyL -> "" - Cell pos _ _ :< _ -> + t0 :< _ -> goTokens toks `S.evalState` linePos pos where + pos = posTree t0 indent = Text.replicate (columnPos pos - 1) " " - go :: Cell Token -> S.State Int Html - go tok = - case unCell tok of - TokenPlain txt -> do - lin <- S.get - let lines = Text.splitOn "\n" txt - let lnums = H.toMarkup : - [ \line -> do - H.toMarkup '\n' - H.a ! HA.id ("line-"<>attrify lnum) $ return () - H.toMarkup indent - H.toMarkup line - | lnum <- [lin+1..] - ] - S.put (lin - 1 + L.length lines) - return $ mconcat $ L.zipWith ($) lnums lines - TokenTag v -> - return $ - H.span ! HA.class_ "tag" $ do - H.span ! HA.class_ "tag-open" $ H.toMarkup '#' - H.toMarkup v - TokenEscape c -> return $ H.toMarkup ['\\',c] - TokenLink lnk -> - return $ - H.a ! HA.href (attrify lnk) $ - H.toMarkup lnk - TokenPair (PairElem name attrs) ts -> do + go :: Token -> S.State Int Html + go (TreeN (unCell -> p) ts) = + case p of + PairElem name attrs -> do h <- goTokens ts return $ do let cl = mconcat ["pair-PairElem", " pair-elem-", attrify name] @@ -171,14 +149,39 @@ instance Html5ify Tokens where else ( "<"<>html5name<>html5ify attrs<>">" , "html5name<>">" ) - TokenPair grp ts -> do + _ -> do h <- goTokens ts return $ do - let (o,c) = pairBorders grp ts - H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do + let (o,c) = pairBorders p ts + H.span ! HA.class_ (mconcat ["pair-", fromString $ show p]) $ do H.span ! HA.class_ "pair-open" $ H.toMarkup o H.span ! HA.class_ "pair-content" $ h H.span ! HA.class_ "pair-close" $ H.toMarkup c + go (Tree0 (unCell -> tok)) = + case tok of + TokenPlain txt -> do + lin <- S.get + let lines = Text.splitOn "\n" txt + let lnums = H.toMarkup : + [ \line -> do + H.toMarkup '\n' + H.a ! HA.id ("line-"<>attrify lnum) $ return () + H.toMarkup indent + H.toMarkup line + | lnum <- [lin+1..] + ] + S.put (lin - 1 + L.length lines) + return $ mconcat $ L.zipWith ($) lnums lines + TokenTag v -> + return $ + H.span ! HA.class_ "tag" $ do + H.span ! HA.class_ "tag-open" $ H.toMarkup '#' + H.toMarkup v + TokenEscape c -> return $ H.toMarkup ['\\',c] + TokenLink lnk -> + return $ + H.a ! HA.href (attrify lnk) $ + H.toMarkup lnk goTokens :: Tokens -> S.State Int Html goTokens ts = do ts' <- go`mapM`ts diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 8ac6536..3a470d9 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -90,7 +90,7 @@ instance Plainify (Tree (Pos,Cell Key) (Pos,Tokens)) where plainify (Tree0 (posEnd,toks)) = case Seq.viewl toks of EmptyL -> plainify toks - t0:<_ -> plainifyIndentCell (posEnd,posCell t0) <> plainify toks + t0:<_ -> plainifyIndentCell (posEnd,posTree t0) <> plainify toks plainify (TreeN (posEnd,cell@(Cell pos _ _)) cs) = plainifyIndentCell (posEnd,pos) <> plainify (cell, cs) @@ -122,14 +122,20 @@ instance Plainify Tokens where plainify toks = case Seq.viewl toks of EmptyL -> "" - Cell pos _ _ :< _ -> do + t0 :< _ -> do st <- R.ask return $ goTokens st toks `S.evalState` linePos pos where + pos = posTree t0 indent = TL.replicate (int64 $ columnPos pos - 1) " " - go :: State -> Cell Token -> S.State Int TL.Text - go st@State{..} tok = - case unCell tok of + go :: State -> Token -> S.State Int TL.Text + go st@State{..} = \case + TreeN (unCell -> p) ts -> do + ts' <- goTokens st ts + return $ textify o<>ts'<>textify c + where (o,c) = pairBorders p ts + Tree0 (unCell -> tok) -> + case tok of TokenPlain txt -> do lnum <- S.get let lines = Text.splitOn "\n" txt @@ -145,10 +151,6 @@ instance Plainify Tokens where then textify $ Text.pack ['\\',c] else TL.singleton c TokenLink lnk -> return $ textify lnk - TokenPair grp ts -> do - ts' <- goTokens st ts - return $ textify o<>ts'<>textify c - where (o,c) = pairBorders grp ts goTokens :: State -> Tokens -> S.State Int TL.Text goTokens st ts = do ts' <- go st`mapM`ts @@ -175,14 +177,17 @@ instance Textify (Text,Attr) where , attr_close ] instance Textify Token where - textify (TokenPlain txt) = textify txt - textify (TokenTag v) = "#"<>textify v - textify (TokenEscape c) = TL.singleton c -- textify $ Text.pack ['\\',c] - textify (TokenLink lnk) = textify lnk - textify (TokenPair grp t) = textify o<>textify t<>textify c - where (o,c) = pairBorders grp t + textify = \case + TreeN (unCell -> p) ts -> textify o<>textify ts<>textify c + where (o,c) = pairBorders p ts + Tree0 (unCell -> t) -> + case t of + TokenPlain txt -> textify txt + TokenTag v -> "#"<>textify v + TokenEscape c -> TL.singleton c -- textify $ Text.pack ['\\',c] + TokenLink lnk -> textify lnk instance Textify Tokens where - textify ts = foldMap (textify . unCell) ts + textify = foldMap textify -- * Utilities @@ -226,14 +231,14 @@ treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1) case Seq.viewr ts of EmptyR -> return $ Tree0 (lastPos,ts) - _ :> cell -> do - S.put $ posEndCell cell + _ :> r -> do + S.put $ posEndTree r return $ Tree0 (lastPos,ts) - go (TreeN cell ts) = do + go (TreeN p ts) = do lastPos <- S.get - S.put $ posEndCell cell + S.put $ posEndCell p ts' <- go`mapM`ts - return $ TreeN (lastPos,cell) ts' + return $ TreeN (lastPos,p) ts' -- ** 'Int64' int64 :: Integral i => i -> Int64 diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 93f4465..9de7c95 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -98,7 +98,7 @@ instance Xmlify TCTs where tree0:inh_tree0 -> (case Seq.viewl toks of EmptyL -> id - Cell bp _ep _ :< _ -> (tree0 bp (xmlify inh_orig t) <|)) $ + (posTree -> bp) :< _ -> (tree0 bp (xmlify inh_orig t) <|)) $ go inh{inh_tree0} ts t: @@ -151,12 +151,12 @@ instance Xmlify TCT where instance Xmlify Tokens where xmlify inh toks = case Seq.viewl toks of - Cell bp _ep (TokenPair PairParen paren) - :< (Seq.viewl -> Cell bb eb (TokenPair PairBracket bracket) + TreeN (Cell bp _ep PairParen) paren + :< (Seq.viewl -> TreeN (Cell bb eb PairBracket) bracket :< ts) -> (<| xmlify inh ts) $ case bracket of - (toList -> [Cell bl el (TokenLink lnk)]) -> + (toList -> [Tree0 (Cell bl el (TokenLink lnk))]) -> TreeN (Cell bp eb "eref") $ xmlAttrs [Cell bl el ("to",lnk)] <> xmlify inh paren @@ -166,51 +166,45 @@ instance Xmlify Tokens where xmlify inh paren t :< ts -> xmlify inh t `unionXml` xmlify inh ts Seq.EmptyL -> mempty -instance Xmlify (Cell Token) where - xmlify inh (Cell bp ep tk) = - case tk of - TokenPlain t -> Seq.singleton $ Tree0 $ cell $ XmlText t - TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)] - TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c - TokenLink lnk -> Seq.singleton $ - TreeN (cell "eref") $ - xmlAttrs [cell ("to",lnk)] - TokenPair PairBracket ts | to <- Plain.textify ts - , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> +instance Xmlify Token where + xmlify inh (TreeN (Cell bp ep p) ts) = + case p of + PairBracket | to <- Plain.textify ts + , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> Seq.singleton $ TreeN (cell "rref") $ xmlAttrs [cell ("to",TL.toStrict to)] - TokenPair PairStar ts -> Seq.singleton $ TreeN (cell "b") $ xmlify inh ts - TokenPair PairSlash ts -> Seq.singleton $ TreeN (cell "i") $ xmlify inh ts - TokenPair PairBackquote ts -> Seq.singleton $ TreeN (cell "code") $ xmlify inh ts - TokenPair PairFrenchquote toks@ts -> + PairStar -> Seq.singleton $ TreeN (cell "b") $ xmlify inh ts + PairSlash -> Seq.singleton $ TreeN (cell "i") $ xmlify inh ts + PairBackquote -> Seq.singleton $ TreeN (cell "code") $ xmlify inh ts + PairFrenchquote -> Seq.singleton $ TreeN (cell "q") $ case ts of - (Seq.viewl -> Cell bl el (TokenPlain l) :< ls) -> + (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) -> case Seq.viewr ls of - m :> Cell br er (TokenPlain r) -> + m :> Tree0 (Cell br er (TokenPlain r)) -> xmlify inh $ - Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)) - <|(m|>Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))) + Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l))) + <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r)))) _ -> xmlify inh $ - Cell bl el (TokenPlain (Text.dropAround Char.isSpace l)) <| ls - (Seq.viewr -> rs :> Cell br er (TokenPlain r)) -> + Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls + (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) -> xmlify inh $ - rs |> Cell br er (TokenPlain (Text.dropAround Char.isSpace r)) - _ -> xmlify inh toks - TokenPair PairHash to -> + rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r))) + _ -> xmlify inh ts + PairHash -> Seq.singleton $ TreeN (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Plain.textify to)] - TokenPair (PairElem name attrs) ts -> + xmlAttrs [cell ("to",TL.toStrict $ Plain.textify ts)] + PairElem name attrs -> Seq.singleton $ TreeN (cell $ xmlLocalName name) $ xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> cell (xmlLocalName attr_name,attr_value)) <$> attrs) <> xmlify inh ts - TokenPair p ts -> + _ -> let (o,c) = pairBorders p ts in Seq.singleton (Tree0 $ Cell bp bp $ XmlText o) `unionXml` xmlify inh ts `unionXml` @@ -218,6 +212,17 @@ instance Xmlify (Cell Token) where where cell :: a -> Cell a cell = Cell bp ep + xmlify _inh (Tree0 (Cell bp ep tok)) = + case tok of + TokenPlain t -> Seq.singleton $ Tree0 $ cell $ XmlText t + TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)] + TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c + TokenLink lnk -> Seq.singleton $ + TreeN (cell "eref") $ + xmlAttrs [cell ("to",lnk)] + where + cell :: a -> Cell a + cell = Cell bp ep mimetype :: Text -> Maybe Text mimetype "hs" = Just "text/x-haskell" @@ -241,7 +246,7 @@ xmlDocument trees = case Seq.viewl trees of TreeN (unCell -> KeySection{}) vs :< ts -> case spanlTokens vs of - (titles@(Seq.viewl -> (Seq.viewl -> Cell bp _ep _ :< _) :< _), vs') -> + (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') -> let vs'' = case Seq.findIndexL (\case @@ -266,7 +271,7 @@ xmlAbout inh key attrs body = Seq.singleton $ xmlKey inh key attrs $ case Seq.viewl (inh_titles inh) of - (Seq.viewl -> Cell bt _et _ :< _) :< _ -> + (Seq.viewl -> (posTree -> bt) :< _) :< _ -> ((<$> inh_titles inh) $ \title -> TreeN (Cell bt bt $ KeyColon "title" "") $ Seq.singleton $ Tree0 title) @@ -289,7 +294,10 @@ xmlKey inh (Cell bp ep key) attrs ts = Plain.text def $ TreeSeq.mapAlsoNode (cell1 . unCell) - (\_path -> fmap $ cell1 . unCell) <$> ts + (\_k -> fmap $ + TreeSeq.mapAlsoNode + (cell1 . unCell) + (\_k' -> cell1 . unCell)) <$> ts KeyLower n as -> TreeN (cell "artwork") $ xmlify inh ts KeyBrackets ident -> let inh' = inh{inh_figure = False} in @@ -348,7 +356,7 @@ spanlItems liKey ts = TreeN (unCell -> liKey -> True) _ -> True Tree0 toks -> (`any` toks) $ \case - (unCell -> TokenPair (PairElem "li" _) _) -> True + TreeN (unCell -> PairElem "li" _) _ -> True _ -> False {- case toList $ Seq.dropWhileR (isTokenWhite . unCell) toks of @@ -361,17 +369,16 @@ spanlItems liKey ts = TreeN (unCell -> liKey -> True) _ -> (oks|>t,kos) Tree0 toks -> let (ok,ko) = - (`Seq.spanl` toks) $ \tok -> - case unCell tok of - TokenPair (PairElem "li" _) _ -> True - TokenPlain txt -> Char.isSpace`Text.all`txt + (`Seq.spanl` toks) $ \case + TreeN (unCell -> PairElem "li" _) _ -> True + Tree0 (unCell -> TokenPlain txt) -> Char.isSpace`Text.all`txt _ -> False in ( if null ok then oks else oks|>Tree0 (rmTokenPlain ok) , if null ko then kos else Tree0 ko<|kos ) _ -> acc rmTokenPlain = Seq.filter $ \case - (unCell -> TokenPlain{}) -> False + (Tree0 (unCell -> TokenPlain{})) -> False _ -> True spanlKeyColon :: Name -> TCTs -> (TCTs, TCTs) @@ -420,15 +427,20 @@ partitionAttributesChildren ts = (attrs,cs) (as,cs) = (`Seq.partition` ts) $ \case TreeN (unCell -> KeyEqual{}) _cs -> True _ -> False - attrs = foldl' (\acc a -> acc |> attr a) Seq.empty as + attrs = attr <$> as attr = \case - TreeN (Cell bp ep (KeyEqual n _wh)) a -> - Cell bp ep (xmlLocalName n, v) - where - v = TL.toStrict $ - Plain.text def{Plain.state_escape = False} $ - TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> a - _ -> undefined + TreeN (Cell bp ep (KeyEqual n _wh)) a -> + Cell bp ep (xmlLocalName n, v) + where + v = TL.toStrict $ + Plain.text def{Plain.state_escape = False} $ + TreeSeq.mapAlsoNode + (cell1 . unCell) + (\_k -> fmap $ + TreeSeq.mapAlsoNode + (cell1 . unCell) + (\_k' -> cell1 . unCell)) <$> a + _ -> undefined elems :: Set Text elems = -- 2.42.0 From dbc1fb2d270d7a2a783b43fc1f5c781cdcd89721 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 4 Jan 2018 15:17:32 +0100 Subject: [PATCH 09/16] WIP add paragraph recognition, enabling footnote with note: instead of only . --- Language/TCT/Cell.hs | 14 +- Language/TCT/Read.hs | 75 +++++--- Language/TCT/Read/Token.hs | 268 +++++++++++++++++++++------ Language/TCT/Read/Tree.hs | 4 +- Language/TCT/Token.hs | 90 +-------- Language/TCT/Tree.hs | 139 +++++++++----- Language/TCT/Write/HTML5.hs | 351 ++++++++++++++++++++---------------- Language/TCT/Write/Plain.hs | 212 +++++++++++----------- Language/TCT/Write/XML.hs | 8 +- Text/Blaze/Utils.hs | 11 ++ exe/cli/Main.hs | 26 ++- 11 files changed, 697 insertions(+), 501 deletions(-) diff --git a/Language/TCT/Cell.hs b/Language/TCT/Cell.hs index 25f4e5f..3746748 100644 --- a/Language/TCT/Cell.hs +++ b/Language/TCT/Cell.hs @@ -6,7 +6,7 @@ import Data.Function (($), (.)) import Data.Functor (Functor) import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) -import Data.Semigroup (Semigroup(..)) +-- import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, ViewL(..), ViewR(..)) import Data.TreeSeq.Strict (Tree(..)) import Prelude (Int) @@ -83,16 +83,18 @@ posTrees trees = -- * Type 'Pos' data Pos - = Pos - { linePos :: {-# UNPACK #-} !Line - , columnPos :: {-# UNPACK #-} !Column - } deriving (Eq) + = Pos + { linePos :: {-# UNPACK #-} !Line + , columnPos :: {-# UNPACK #-} !Column + } deriving (Eq, Ord) instance Show Pos where - showsPrec _p pos = showsPrec 11 (linePos pos,columnPos pos) + showsPrec _p Pos{..} = showsPrec 11 (linePos,columnPos) +{- instance Ord Pos where Pos lx cx `compare` Pos ly cy = compare lx ly <> compare cx cy +-} posTree :: Tree (Cell k) (Cell a) -> Pos posTree (TreeN c _) = posCell c diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs index e96eb31..740ce23 100644 --- a/Language/TCT/Read.hs +++ b/Language/TCT/Read.hs @@ -8,12 +8,14 @@ module Language.TCT.Read , module Language.TCT.Read ) where +import Control.Monad (Monad(..), join) import Control.Applicative (Applicative(..)) import Data.Char (Char) import Data.Either (Either(..)) import Data.Eq (Eq(..)) -import Data.Function (($)) -import Data.Functor ((<$>)) +import Data.Function (($), (.)) +import Data.Functor (Functor(..), (<$>)) +import Data.Foldable (toList) import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) @@ -26,9 +28,11 @@ import Data.TreeSeq.Strict (Tree) import Data.Tuple (snd) import Data.Void (Void) import System.IO (FilePath) +import Text.Show (Show(..)) import qualified Data.Text as Text -import qualified Data.TreeSeq.Strict as TreeSeq import qualified Text.Megaparsec as P +import qualified Data.Sequence as Seq +import qualified Data.TreeSeq.Strict as Tree import Language.TCT.Tree import Language.TCT.Token @@ -37,6 +41,8 @@ import Language.TCT.Read.Cell import Language.TCT.Read.Tree import Language.TCT.Read.Token +import Debug.Trace (trace) + -- * Type 'TCT' type TCT = Tree (Cell Key) Tokens @@ -47,26 +53,49 @@ readTCTs :: FilePath -> Text -> Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCTs readTCTs inp txt = do - tct <- P.runParser (p_Trees <* P.eof) inp txt - (`traverse` tct) $ \tr -> - sequence $ (`TreeSeq.mapWithNode`tr) $ \key c@(Cell pos _posEnd t) -> - case key of - -- Verbatim Keys - Just (unCell -> KeyBar{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c] - Just (unCell -> KeyLower{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c] - Just (unCell -> KeyEqual{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c] - -- Token Keys - _ -> - snd $ P.runParser' - (p_Tokens <* P.eof) - P.State - { P.stateInput = StreamCell t - , P.statePos = pure $ P.SourcePos inp - (P.mkPos $ linePos pos) - (P.mkPos $ columnPos pos) - , P.stateTabWidth = P.mkPos $ columnPos pos - , P.stateTokensProcessed = 0 - } + trs <- P.runParser (p_Trees <* P.eof) inp txt + traverse (go Nothing) $ trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs + where + go :: + Maybe Key -> + Tree (Cell Key) (Cell Value) -> + Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCT + go k (Tree0 v) = + case k of + Just KeyBar{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v] + Just KeyLower{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v] + Just KeyEqual{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v] + _ -> Tree0 . parseTokens <$> parseLexemes v + go _ (TreeN c@(unCell -> key) ts) = + case key of + KeyBar{} -> TreeN c <$> traverse (go (Just key)) ts + KeyLower{} -> TreeN c <$> traverse (go (Just key)) ts + KeyEqual{} -> TreeN c <$> traverse (go (Just key)) ts + KeyPara -> do + ls <- + (`traverse` Seq.reverse ts) $ \case + Tree0 v -> parseLexemes v + TreeN ck@(unCell -> k) vs -> + (pure . LexemeTree . TreeN ck <$>) $ + traverse (go (Just k)) vs + let toks = parseTokens $ join $ toList ls + return $ Tree0 toks + _ -> TreeN c <$> traverse (go (Just key)) ts + parseLexemes :: + Cell Value -> + Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) [Lexeme] + parseLexemes (Cell bp _ep v) = + snd $ + P.runParser' + (p_Lexemes <* P.eof) + P.State + { P.stateInput = v + , P.statePos = pure $ P.SourcePos inp + (P.mkPos $ linePos bp) + (P.mkPos $ columnPos bp) + , P.stateTabWidth = P.pos1 + , P.stateTokensProcessed = 0 + } -- * Type 'StreamCell' -- | Wrap 'Text' to have a 'P.Stream' instance diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index ced91cc..8b4014d 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -5,12 +5,18 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Read.Token where +-- import Data.Text.Buildable (Buildable(..)) +-- import qualified Data.Text.Lazy as TL +-- import qualified Data.Text.Lazy.Builder as Builder import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) +import Data.Int (Int) import Data.Eq (Eq(..)) +import Data.Ord (Ord(..)) import Data.Foldable (Foldable(..)) +import Data.Sequence (Seq) import Data.Function (($), (.)) import Data.Functor ((<$>), ($>), (<$)) import Data.Maybe (Maybe(..)) @@ -18,7 +24,6 @@ import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..), (<|)) import Data.Text (Text) --- import Data.Text.Buildable (Buildable(..)) import Data.TreeSeq.Strict (Tree(..)) import Data.Tuple (fst,snd) import Prelude (Num(..)) @@ -26,24 +31,94 @@ import Text.Show (Show(..)) import qualified Data.Char as Char import qualified Data.Sequence as Seq import qualified Data.Text as Text --- import qualified Data.Text.Lazy as TL --- import qualified Data.Text.Lazy.Builder as Builder import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P +import qualified System.FilePath as FP -import Language.TCT.Token import Language.TCT.Cell import Language.TCT.Elem import Language.TCT.Read.Elem import Language.TCT.Read.Cell -{- -textOf :: Buildable a => a -> Text -textOf = TL.toStrict . Builder.toLazyText . build --} +-- * Type 'Row' +-- | In normal order: a list of 'Key's, maybe ended by 'Value', all read on the same line. +type Row = [Tree (Cell Key) (Cell Value)] + +-- * Type 'Key' +data Key + = KeyColon !Name !White -- ^ @name: @ + | KeyEqual !Name !White -- ^ @name=@ + | KeyBar !Name !White -- ^ @name|@ + | KeyGreat !Name !White -- ^ @name>@ + | KeyLower !Name !Attrs -- ^ @value@ + | PairStar -- ^ @*value*@ + | PairSlash -- ^ @/value/@ + | PairUnderscore -- ^ @_value_@ + | PairDash -- ^ @-value-@ + | PairBackquote -- ^ @`value`@ + | PairSinglequote -- ^ @'value'@ + | PairDoublequote -- ^ @"value"@ + | PairFrenchquote -- ^ @«value»@ + | PairParen -- ^ @(value)@ + | PairBrace -- ^ @{value}@ + | PairBracket -- ^ @[value]@ + deriving (Eq,Ord,Show) + +-- ** Type 'TokenValue' +data TokenValue + = TokenPlain !Text + | TokenTag !Tag + | TokenEscape !Char + | TokenLink !Text + | TokenTree (Tree (Cell Key) (Cell Value)) + deriving (Eq,Ord,Show) + +-- ** Type 'Tag' +type Tag = Text -- * Type 'Pairs' -type Pairs = (Tokens,[(Cell Pair,Tokens)]) +-- | Right-only Dyck language +type Pairs = (Tokens,[Opening]) + +-- ** Type 'Opening' +type Opening = (Cell Pair,Tokens) appendToken :: Pairs -> Token -> Pairs appendToken ps = appendTokens ps . Seq.singleton @@ -73,23 +148,22 @@ closePair (t,(p1,t1):ts) p = dbg "closePair" $ (`closePair` p) $ appendTokens (t,ts) - (closeUnpaired mempty (p1,t1)) + (closeImpaired mempty (p1,t1)) --- | Close a 'Pair' when there is not a matching 'LexemePairClose'. -closeUnpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens -closeUnpaired acc (Cell bp ep p,toks) = dbg "closeUnpaired" $ +-- | Close a 'Pair' when there is no matching 'LexemePairClose'. +closeImpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens +closeImpaired acc (Cell bp ep p,toks) = dbg "closeImpaired" $ case p of -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'. PairHash | (Tree0 (Cell bt et (TokenPlain t))) :< ts <- Seq.viewl $ toks <> acc -> - case Text.findIndex (not . isTagChar) t of - -- Just 0 -> toksHash mempty <> toks <> acc - Just i -> - Tree0 (Cell bp bt{columnPos = columnPos bt + i} (TokenTag tag)) - <| Tree0 (Cell bt{columnPos = columnPos bt + i + 1} et (TokenPlain t')) - <| ts - where (tag,t') = Text.splitAt i t - Nothing | Text.null t -> toksHash mempty <> toks <> acc - Nothing -> Tree0 (Cell bp et (TokenTag t)) <| ts + case Text.span isTagChar t of + ("",_) | Text.null t -> toksHash mempty <> toks <> acc + | otherwise -> Tree0 (Cell bp et (TokenTag t)) <| ts + (tag,t') -> + let len = Text.length tag in + Tree0 (Cell bp bt{columnPos = columnPos bt + len} (TokenTag tag)) <| + Tree0 (Cell bt{columnPos = columnPos bt + len + 1} et (TokenPlain t')) <| + ts _ -> toksHash tokensPlainEmpty <> toks <> acc where toksHash = tokens1 . Tree0 . Cell bp ep . TokenPlain . fst . pairBorders p @@ -104,7 +178,7 @@ closeUnpaired acc (Cell bp ep p,toks) = dbg "closeUnpaired" $ -- | Close remaining 'Pair's at end of parsing. closePairs :: Pairs -> Tokens closePairs (t0,ps) = dbg "closePairs" $ - t0 <> foldl' closeUnpaired mempty ps + t0 <> foldl' closeImpaired mempty ps appendLexeme :: Lexeme -> Pairs -> Pairs appendLexeme lex acc = @@ -119,11 +193,15 @@ appendLexeme lex acc = LexemePairBoth ps -> appendTokens acc $ tokens $ (`TreeN`mempty) <$> ps LexemeEscape c -> appendToken acc $ Tree0 $ TokenEscape <$> c LexemeLink t -> appendToken acc $ Tree0 $ TokenLink <$> t - LexemeWhite (unCell -> "") -> acc + {-LexemeWhite (unCell -> "") -> acc-} + LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc LexemeWhite cs -> appendToken acc $ Tree0 $ TokenPlain <$> cs LexemeAlphaNum cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs LexemeAny cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs - LexemeToken ts -> appendTokens acc ts + -- LexemeToken ts -> appendTokens acc ts + +appendLexemes :: Pairs -> [Lexeme] -> Pairs +appendLexemes = foldr appendLexeme -- * Type 'Lexeme' data Lexeme @@ -136,33 +214,42 @@ data Lexeme | LexemeWhite !(Cell White) | LexemeAlphaNum !(Cell [Char]) | LexemeAny !(Cell [Char]) - | LexemeToken !Tokens - deriving (Eq, Show) - -p_Tokens :: Parser e s Tokens -p_Tokens = pdbg "Tokens" $ - closePairs . - foldr appendLexeme mempty . - dbg "Lexemes" . - mangleLexemes . - (LexemeWhite (cell0 "") :) <$> - go [LexemeWhite (cell0 "")] + | LexemeTree !(Tree (Cell Key) Tokens) + deriving (Eq, Ord, Show) + +-- ** Type 'Lexemes' +type Lexemes = Seq Lexeme + +parseTokens :: [Lexeme] -> Tokens +parseTokens ps = + closePairs $ + appendLexemes mempty $ + dbg "Lexemes" $ + orientLexemePairAny $ LexemeWhite (cell0 "") : + ps + +-- | Parse 'Lexeme's, returning them in reverse order to apply 'orientLexemePairAny'. +p_Lexemes :: Parser e s [Lexeme] +p_Lexemes = pdbg "Lexemes" $ go [] where go :: [Lexeme] -> Parser e s [Lexeme] go acc = (P.eof $> acc) <|> - (p_Lexeme >>= \next -> go $ mangleLexemes $ next:acc) - - mangleLexemes = \case + (p_Lexeme >>= \next -> go $ orientLexemePairAny $ next:acc) + +orientLexemePairAny :: [Lexeme] -> [Lexeme] +orientLexemePairAny = \case 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 + LexemePairAny p:[] -> LexemePairOpen p:[] --    ,,," LexemePairAny p:a@LexemeAny{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc + LexemePairAny p:a@LexemeAny{}:[] -> LexemePairOpen p:a:[] -- ",,,    w@LexemeWhite{}:a@LexemeAny{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc @@ -183,6 +270,27 @@ p_Tokens = pdbg "Tokens" $ acc -> acc +p_Lexeme :: Parser e s Lexeme +p_Lexeme = pdbg "Lexeme" $ + P.choice + [ P.try $ LexemeWhite <$> p_Cell p_Spaces + , P.try $ LexemePairAny <$> P.some (p_Cell $ p_satisfyMaybe pairAny) + , P.try $ LexemePairBoth <$> P.some (P.try $ p_Cell p_ElemSingle) + , P.try $ LexemePairOpen <$> P.some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen) + , P.try $ LexemePairClose <$> P.some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose) + , P.try $ LexemeEscape <$> p_Cell p_Escape + , P.try $ LexemeLink <$> p_Cell p_Link + , P.try $ LexemeAlphaNum <$> p_Cell (P.some p_AlphaNum) + , LexemeAny <$> p_Cell (pure <$> P.anyChar) + ] + +p_Cell :: Parser e s a -> Parser e s (Cell a) +p_Cell pa = do + bp <- p_Position + a <- pa + ep <- p_Position + return $ Cell bp ep a + pairAny :: Char -> Maybe Pair pairAny = \case '-' -> Just PairDash @@ -211,27 +319,6 @@ pairClose = \case '»' -> Just PairFrenchquote _ -> Nothing -p_Cell :: Parser e s a -> Parser e s (Cell a) -p_Cell pa = do - bp <- p_Position - a <- pa - ep <- p_Position - return $ Cell bp ep a - -p_Lexeme :: Parser e s Lexeme -p_Lexeme = pdbg "Lexeme" $ - P.choice - [ P.try $ LexemeWhite <$> p_Cell p_Spaces - , P.try $ LexemePairAny <$> P.some (p_Cell $ p_satisfyMaybe pairAny) - , P.try $ LexemePairBoth <$> P.some (P.try $ p_Cell p_ElemSingle) - , P.try $ LexemePairOpen <$> P.some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen) - , P.try $ LexemePairClose <$> P.some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose) - , P.try $ LexemeEscape <$> p_Cell p_Escape - , P.try $ LexemeLink <$> p_Cell p_Link - , P.try $ LexemeAlphaNum <$> p_Cell (P.some p_AlphaNum) - , LexemeAny <$> p_Cell (pure <$> P.anyChar) - ] - p_AlphaNum :: Parser e s Char p_AlphaNum = P.satisfy Char.isAlphaNum @@ -301,3 +388,64 @@ p_ElemOpenOrSingle = P.char '>' $> LexemePairOpen p <|> P.string "/>" $> LexemePairAny p -} + + + + + + + + + +-- | Build 'Tokens' from many 'Token's. +tokens :: [Token] -> Tokens +tokens = Seq.fromList + +-- | Build 'Tokens' from one 'Token'. +tokens1 :: Token -> Tokens +tokens1 = Seq.singleton + +tokensPlainEmpty :: Tokens +tokensPlainEmpty = tokens1 $ Tree0 $ cell1 $ TokenPlain "" + +isTokenWhite :: Token -> Bool +isTokenWhite (Tree0 (unCell -> TokenPlain t)) = Text.all Char.isSpace t +isTokenWhite _ = False + +unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens)) +unTokenElem toks = + case toList $ Seq.dropWhileR isTokenWhite toks of + [TreeN (Cell bp ep (PairElem e as)) ts] -> Just (Cell bp ep (e,as,ts)) + _ -> Nothing + +isTokenElem :: Tokens -> Bool +isTokenElem toks = + case toList $ Seq.dropWhileR isTokenWhite toks of + [TreeN (unCell -> PairElem{}) _] -> True + _ -> False + +pairBorders :: TokenKey -> Tokens -> (Text,Text) +pairBorders p ts = + case p of + PairElem e attrs -> + if Seq.null ts + then ("<"<>e<>foldMap f attrs<>"/>","") + else ("<"<>e<>foldMap f attrs<>">","e<>">") + where f (attr_white,Attr{..}) = + attr_white <> + attr_name <> + attr_open <> + attr_value <> + attr_close + PairHash -> ("#","#") + PairStar -> ("*","*") + PairSlash -> ("/","/") + PairUnderscore -> ("_","_") + PairDash -> ("-","-") + PairBackquote -> ("`","`") + PairSinglequote -> ("'","'") + PairDoublequote -> ("\"","\"") + PairFrenchquote -> ("«","»") + PairParen -> ("(",")") + PairBrace -> ("{","}") + PairBracket -> ("[","]") diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index 30beb65..d2d536c 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -27,10 +27,10 @@ import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import Language.TCT.Cell -import Language.TCT.Token import Language.TCT.Tree import Language.TCT.Read.Cell import Language.TCT.Read.Elem +import Language.TCT.Read.Token p_CellKey :: Row -> Parser e s Row p_CellKey row = pdbg "CellKey" $ do @@ -184,7 +184,7 @@ p_Rows rows = (P.eof $> rows') <|> (P.newline >> p_Rows rows') -p_Trees :: Parser e s (Trees (Cell Key) (Cell Text)) +p_Trees :: Parser e s (Trees (Cell Key) (Cell Value)) p_Trees = unRoot . collapseRows <$> p_Rows [root] where root = TreeN (cell0 KeyDashDash) mempty diff --git a/Language/TCT/Token.hs b/Language/TCT/Token.hs index 7f0a5a3..315b8a5 100644 --- a/Language/TCT/Token.hs +++ b/Language/TCT/Token.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Token where +{- import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) @@ -25,96 +26,7 @@ import qualified Data.Text as Text import Language.TCT.Cell import Language.TCT.Elem --- * Type 'Token' -type Token = Tree (Cell TokenKey) (Cell TokenValue) - --- ** Type 'Tokens' -type Tokens = Seq Token - --- ** Type 'TokenKey' -type TokenKey = Pair -data Pair - = PairHash -- ^ @#value#@ - | PairElem !Elem !Attrs -- ^ @value@ - | PairStar -- ^ @*value*@ - | PairSlash -- ^ @/value/@ - | PairUnderscore -- ^ @_value_@ - | PairDash -- ^ @-value-@ - | PairBackquote -- ^ @`value`@ - | PairSinglequote -- ^ @'value'@ - | PairDoublequote -- ^ @"value"@ - | PairFrenchquote -- ^ @«value»@ - | PairParen -- ^ @(value)@ - | PairBrace -- ^ @{value}@ - | PairBracket -- ^ @[value]@ - deriving (Eq,Ord,Show) - --- ** Type 'TokenValue' -data TokenValue - = TokenPlain !Text - | TokenTag !Tag - | TokenEscape !Char - | TokenLink !Text - deriving (Eq,Ord,Show) - --- *** Type 'Tag' -type Tag = Text - --- | Build 'Tokens' from many 'Token's. -tokens :: [Token] -> Tokens -tokens = Seq.fromList - --- | Build 'Tokens' from one 'Token'. -tokens1 :: Token -> Tokens -tokens1 = Seq.singleton -tokensPlainEmpty :: Tokens -tokensPlainEmpty = tokens1 $ Tree0 $ cell1 $ TokenPlain "" - -isTokenWhite :: Token -> Bool -isTokenWhite (Tree0 (unCell -> TokenPlain t)) = Text.all Char.isSpace t -isTokenWhite _ = False - -unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens)) -unTokenElem toks = - case toList $ Seq.dropWhileR isTokenWhite toks of - [TreeN (Cell bp ep (PairElem e as)) ts] -> Just (Cell bp ep (e,as,ts)) - _ -> Nothing - -isTokenElem :: Tokens -> Bool -isTokenElem toks = - case toList $ Seq.dropWhileR isTokenWhite toks of - [TreeN (unCell -> PairElem{}) _] -> True - _ -> False - -pairBorders :: TokenKey -> Tokens -> (Text,Text) -pairBorders p ts = - case p of - PairElem e attrs -> - if Seq.null ts - then ("<"<>e<>foldMap f attrs<>"/>","") - else ("<"<>e<>foldMap f attrs<>">","e<>">") - where f (attr_white,Attr{..}) = - attr_white <> - attr_name <> - attr_open <> - attr_value <> - attr_close - PairHash -> ("#","#") - PairStar -> ("*","*") - PairSlash -> ("/","/") - PairUnderscore -> ("_","_") - PairDash -> ("-","-") - PairBackquote -> ("`","`") - PairSinglequote -> ("'","'") - PairDoublequote -> ("\"","\"") - PairFrenchquote -> ("«","»") - PairParen -> ("(",")") - PairBrace -> ("{","}") - PairBracket -> ("[","]") - - -{- instance Buildable Token where build (TokenPlain t) = build t build (TokenTag t) = "#"<>build t diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index 0d97ad9..1678a4b 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ViewPatterns #-} module Language.TCT.Tree ( module Language.TCT.Tree @@ -20,39 +21,13 @@ import Text.Show (Show(..)) import qualified Data.List as List import qualified Data.Text as Text import qualified System.FilePath as FP +import qualified Data.Sequence as Seq import Language.TCT.Cell import Language.TCT.Elem +import Language.TCT.Read.Token +-- import Language.TCT.Token --- * Type 'Row' --- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'. -type Row = [Tree (Cell Key) (Cell Text)] - --- * Type 'Key' -data Key = KeyColon !Name !White -- ^ @name: @ - | KeyEqual !Name !White -- ^ @name=@ - | KeyBar !Name !White -- ^ @name|@ - | KeyGreat !Name !White -- ^ @name>@ - | KeyLower !Name !Attrs -- ^ @ case (dbg "parent" parent,dbg "cell" cell) of (Tree0{}, TreeN{}) -> eq - (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful? - (Tree0 p, Tree0 r) -> appendTree0 p r + -- (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful? + -- (TreeN (unCell -> KeyPara) p, Tree0 r) -> appendTree0 p r + -- (Tree0 p, Tree0 r) -> appendTree0 p r + _ | Just x <- appendPara -> x _ -> lt EQ -> case (dbg "parent" parent,dbg "cell" cell) of - (Tree0 p, Tree0 r) -> appendTree0 p r + _ | Just x <- appendPara -> x (_, TreeN (unCell -> KeySection sectionRow) _) | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows -> - case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of + case dbg "sectionParent" sectionParent `compare` + dbg "sectionRow" sectionRow of LT -> appendRow (cell:secPar:secPars) cells EQ -> appendRow (cell:insertChild secPar secPars) cells GT -> gt @@ -90,10 +69,31 @@ appendRow rows@(parent:parents) row@(cell:cells) = (TreeN{}, Tree0{}) -> eq GT -> gt where + appendPara :: Maybe Rows + appendPara = + case (parent, cell) of + ( TreeN (Cell posPar posEndPar KeyPara) pars + , Tree0 (Cell posRow posEndRow _c) ) -> + Just $ + if linePos posRow - linePos posEndPar <= 1 + then appendRow (merged : parents) cells + else appendRow (cell : insertChild parent parents) cells + where merged = TreeN (Cell posPar posEndRow KeyPara) $ pars |> cell + ( Tree0 (Cell posPar posEndPar _p) + , Tree0 (Cell posRow posEndRow _c) ) -> + Just $ + if linePos posRow - linePos posEndPar <= 1 + then appendRow (merged : parents) cells + else appendRow (cell : insertChild parent parents) cells + where merged = TreeN (Cell posPar posEndRow KeyPara) [parent, cell] + _ -> Nothing + + {- appendTree0 p r = - case appendCellText p r of + case appendCellValue p r of Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells - Just c -> appendRow (Tree0 c : parents) cells + Just t -> appendRow (t : parents) cells + -} lt = appendRow [] row <> rows eq = appendRow (cell : insertChild parent parents) cells gt = appendRow (insertChild parent parents) row @@ -107,38 +107,77 @@ appendRow rows@(parent:parents) row@(cell:cells) = return (lvl, insertChild x cs) collapseSection _ _ = Nothing -appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text) -appendCellText (Cell posPar posEndPar p) - (Cell posRow posEndRow r) = - trac ("appendCellText: p="<>show p) $ - trac ("appendCellText: r="<>show r) $ - dbg "appendCellText" $ +{- +appendCellValue :: Cell Value -> Cell Value -> Tree (Cell Key) (Cell Value) +appendCellValue par@(Cell posPar posEndPar p) row@(Cell posRow posEndRow r) = + trac ("appendCellValue: p="<>show p) $ + trac ("appendCellValue: r="<>show r) $ + dbg "appendCellValue" $ case linePos posRow - linePos posEndPar of - 0 -> Just $ Cell posPar posEndRow $ p <> pad <> r - where pad = padding (columnPos posEndPar) (columnPos posRow) - 1 -> Just $ Cell posPar posEndRow $ p <> pad <> r - where pad = "\n" <> padding (columnPos posPar) (columnPos posRow) - _ -> Nothing + 0 -> + TreeN (Cell posPar posEndRow KeyPara) + [ Tree0 par + , Tree0 row + ] + 1 -> + TreeN (Cell posPar posEndRow KeyPara) + [ Tree0 par + , Tree0 row + ] + _ -> [] where padding x y = Text.replicate (y - x) " " + {- + where + pad = + -- return $ LexemeWhite $ Cell posEndPar posRow $ + -- padding (columnPos posEndPar) (columnPos posRow) + -} + {- + -- return $ Cell posPar posEndRow $ p <> pad <> r + -- return $ Cell posPar posEndRow $ p <> pad <> r + where + pad = + -- return $ LexemeWhite $ Cell posEndPar posRow $ + -- "\n" <> + padding (columnPos posPar) (columnPos posRow) + -} +-} -insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows +insertChild :: Tree (Cell Key) (Cell Value) -> Rows -> Rows insertChild child ps@[] = trac ("insertChild: child="<>show child) $ trac ("insertChild: ps="<>show ps) $ dbg "insertChild" $ [child] -insertChild _child (Tree0{}:_) = undefined +insertChild c@(Tree0 (Cell _bp ep _)) + (p@(Tree0 (Cell bp _ep _)):parents) = + TreeN (Cell bp ep KeyPara) [p, c] : parents +insertChild (TreeN (Cell _bp ep _) cs) + (p@(Tree0 (Cell bp _ep _)):parents) = + TreeN (Cell bp ep KeyPara) (p Seq.<| cs) : parents + {- + undefined + -- FIXME: this case may be removed. + case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of + LT -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents + EQ -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents + GT -> undefined + -} insertChild child ps@(TreeN parent treesParent:parents) = trac ("insertChild: child="<>show child) $ trac ("insertChild: ps="<>show ps) $ dbg "insertChild" $ + -- FIXME: this case may be removed. case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of LT -> TreeN parent (treesParent |> child) : parents EQ -> TreeN parent (treesParent |> child) : parents GT -> undefined -collapseRows :: Rows -> Tree (Cell Key) (Cell Text) +collapseRows :: Rows -> Tree (Cell Key) (Cell Value) collapseRows [] = undefined collapseRows [child] = dbg "collapseRows" $ child collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents + + + diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index c0590af..cb05e90 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -1,93 +1,119 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} --- | Render TCT as HTML5. module Language.TCT.Write.HTML5 where -import Control.Monad (Monad(..), forM_, mapM_, mapM, when) +import Control.Monad (Monad(..), forM_, mapM_, when) import Data.Bool +import Data.Char (Char) +import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Function (($)) -import Data.Int (Int) +import Data.Function (($), (.), id) +import Data.Functor ((<$>)) +import Data.Functor.Compose (Compose(..)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..)) -import Data.String (IsString(..)) +import Data.String (String, IsString(..)) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..),Trees) -import Prelude (Num(..), undefined) +import Prelude (Num(..), undefined, error) import Text.Blaze ((!)) import Text.Blaze.Html (Html) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S -import qualified Data.List as L +import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA +-- import Debug.Trace (trace) import Text.Blaze.Utils import Language.TCT import qualified Language.TCT.Write.Plain as Plain +-- * Type 'Html5' +type Html5 = StateMarkup State () + +-- ** Type 'State' +data State + = State + { state_pos :: Pos + } +instance Default State where + def = State + { state_pos = pos1 + } + -- * Class 'Html5ify' class Html5ify a where - html5ify :: a -> Html + html5ify :: a -> Html5 +instance Html5ify H.Markup where + html5ify = Compose . return +instance Html5ify Html5 where + html5ify = id +instance Html5ify () where + html5ify = mempty +instance Html5ify Char where + html5ify = html5ify . H.toMarkup instance Html5ify Text where - html5ify = H.toMarkup -instance Html5ify TCTs where - html5ify tct = do - H.docType - H.html $ do - H.head $ do - H.meta ! HA.httpEquiv "Content-Type" - ! HA.content "text/html; charset=UTF-8" - whenJust (tokensTitle tct) $ \ts -> - H.title $ H.toMarkup $ L.head $ - TL.lines (Plain.textify ts) <> [""] - -- link ! rel "Chapter" ! title "SomeTitle"> - H.link ! HA.rel "stylesheet" - ! HA.type_ "text/css" - ! HA.href "style/tct-html5.css" - H.body $ do - H.a ! HA.id ("line-1") $ return () - html5ify (Plain.treePosLastCell tct) -instance Html5ify (Trees (Pos,Cell Key) (Pos,Tokens)) where + html5ify = html5ify . H.toMarkup +instance Html5ify TL.Text where + html5ify = html5ify . H.toMarkup +instance Html5ify String where + html5ify = html5ify . H.toMarkup +html5Document :: TCTs -> Html +html5Document body = do + H.docType + H.html $ do + H.head $ do + H.meta ! HA.httpEquiv "Content-Type" + ! HA.content "text/html; charset=UTF-8" + whenJust (tokensTitle body) $ \ts -> + H.title $ + H.toMarkup $ Plain.text def $ List.head $ toList ts + -- link ! rel "Chapter" ! title "SomeTitle"> + H.link ! HA.rel "stylesheet" + ! HA.type_ "text/css" + ! HA.href "style/tct-html5.css" + let (html5Body, State{}) = + runStateMarkup def $ + html5ify body + H.body $ do + H.a ! HA.id ("line-1") $ return () + html5Body +instance Html5ify (Trees (Cell Key) Tokens) where html5ify = mapM_ html5ify -instance Html5ify (Tree (Pos,Cell Key) (Pos,Tokens)) where - html5ify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do - html5ifyIndentCell (posEnd,pos) - H.section $ do - H.span ! HA.class_ "section-title" $ do - H.span $ html5ify $ Text.replicate lvl "#" <> " " - case Seq.viewl ts of - Tree0 (_,title) :< _ -> h lvl $ html5ify title - _ -> return () - html5ify $ - case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts} - where - h 1 = H.h1 - h 2 = H.h2 - h 3 = H.h3 - h 4 = H.h4 - h 5 = H.h5 - h 6 = H.h6 - h n | n > 0 = H.span ! HA.class_ ("h h"<>attrify n) - h _ = undefined - html5ify (Tree0 (posEnd,toks)) = - case Seq.viewl toks of - EmptyL -> html5ify toks - t0:<_ -> html5ifyIndentCell (posEnd,posTree t0) <> html5ify toks - html5ify (TreeN (posEnd,cell@(Cell pos _ _)) cs) = - html5ifyIndentCell (posEnd,pos) <> - html5ify (cell, cs) -instance Html5ify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where - html5ify (Cell _pos _posEnd key, ts) = do +instance Html5ify (Tree (Cell Key) Tokens) where + html5ify = \case + TreeN (Cell bp ep k) ts -> html5ify (Cell bp ep (k,ts)) + Tree0 ts -> html5ify ts +instance Html5ify a => Html5ify (Cell a) where + html5ify (Cell next@(Pos line col) ep a) = do + prev@(Pos lineLast colLast) <- liftStateMarkup $ S.gets state_pos + case () of + _ | lineLast < line -> do + forM_ [lineLast+1..line] $ \lnum -> do + html5ify '\n' + H.a ! HA.id ("line-"<>attrify lnum) $$ return () + html5ify $ Text.replicate (col - 1) " " + _ | lineLast == line && colLast <= col -> do + html5ify $ Text.replicate (col - colLast) " " + _ -> error $ "html5ify: non-ascending positions: " + <> "\n prev: " <> show prev + <> "\n next: " <> show next + -- liftStateMarkup $ S.modify $ \s -> s{state_pos=bp} + liftStateMarkup $ S.modify $ \s -> s{state_pos=ep} + html5ify a +instance Html5ify (Key, Trees (Cell Key) Tokens) where + html5ify (key, ts) = case key of + KeyPara -> html5ify ts KeyColon n wh -> html5Key "" "" n wh ":" "" "colon" KeyGreat n wh -> html5Key "" "" n wh ">" "" "great" KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal" @@ -97,129 +123,140 @@ instance Html5ify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash" KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash" KeyLower name attrs -> do - H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $ do - H.span ! HA.class_ "key-mark" $ H.toMarkup '<' - H.span ! HA.class_ "key-name" $ H.toMarkup name + H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $$ do + H.span ! HA.class_ "key-mark" $$ html5ify '<' + H.span ! HA.class_ "key-name" $$ html5ify name html5ify attrs html5ify ts + KeySection lvl -> do + H.section $$ do + H.span ! HA.class_ "section-title" $$ do + H.span ! HA.class_ "section-mark" $$ do + html5ify $ Text.replicate lvl "#" + case Seq.viewl ts of + Tree0 title :< _ -> h lvl $$ html5ify title + _ -> return () + html5ify $ + case Seq.viewl ts of + Tree0{} :< ts' -> ts' + _ -> ts + where + h 1 = H.h1 + h 2 = H.h2 + h 3 = H.h3 + h 4 = H.h4 + h 5 = H.h5 + h 6 = H.h6 + h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n) + h _ = undefined where - html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html + html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html5 html5Key markBegin whmb name whn markEnd whme cl = do - -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1) - H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $ do + H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $$ do when (markBegin/="") $ - H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin - H.toMarkup whmb + H.span ! HA.class_ "key-mark" $$ html5ify markBegin + html5ify whmb when (name/="") $ - H.span ! HA.class_ "key-name" $ H.toMarkup name - H.toMarkup whn + H.span ! HA.class_ "key-name" $$ html5ify name + html5ify whn when (markEnd/="") $ - H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd - H.toMarkup whme - H.span ! HA.class_ "key-value" $ + H.span ! HA.class_ "key-mark" $$ html5ify markEnd + html5ify whme + H.span ! HA.class_ "key-value" $$ html5ify ts instance Html5ify Tokens where - html5ify toks = - case Seq.viewl toks of - EmptyL -> "" - t0 :< _ -> - goTokens toks `S.evalState` linePos pos + html5ify = mapM_ html5ify +instance Html5ify Token where + html5ify (TreeN (Cell bp ep p) ts) = do + case p of + PairElem name attrs -> do + H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do + html5ify $ Cell bp bp{columnPos = columnPos bp + lenO} () + when (lenO > 0) $ + H.span ! HA.class_ "pair-open" $$ o + when (not $ Seq.null ts) $ + H.span ! HA.class_ "pair-content" $$ html5ify ts + html5ify $ Cell ep{columnPos = columnPos ep - lenC} ep () + when (lenC > 0) $ + H.span ! HA.class_ "pair-close" $$ c where - pos = posTree t0 - indent = Text.replicate (columnPos pos - 1) " " - go :: Token -> S.State Int Html - go (TreeN (unCell -> p) ts) = - case p of - PairElem name attrs -> do - h <- goTokens ts - return $ do - let cl = mconcat ["pair-PairElem", " pair-elem-", attrify name] - H.span ! HA.class_ cl $ do - whenMarkup o $ H.span ! HA.class_ "pair-open" $ o - whenMarkup h $ H.span ! HA.class_ "pair-content" $ h - whenMarkup c $ H.span ! HA.class_ "pair-close" $ c - where - html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name - o,c :: Html - (o,c) = - if Seq.null ts - then - ( "<"<>html5name<>html5ify attrs<>"/>" - , mempty ) - else - ( "<"<>html5name<>html5ify attrs<>">" - , "html5name<>">" ) - _ -> do - h <- goTokens ts - return $ do - let (o,c) = pairBorders p ts - H.span ! HA.class_ (mconcat ["pair-", fromString $ show p]) $ do - H.span ! HA.class_ "pair-open" $ H.toMarkup o - H.span ! HA.class_ "pair-content" $ h - H.span ! HA.class_ "pair-close" $ H.toMarkup c - go (Tree0 (unCell -> tok)) = - case tok of - TokenPlain txt -> do - lin <- S.get - let lines = Text.splitOn "\n" txt - let lnums = H.toMarkup : - [ \line -> do - H.toMarkup '\n' - H.a ! HA.id ("line-"<>attrify lnum) $ return () - H.toMarkup indent - H.toMarkup line - | lnum <- [lin+1..] - ] - S.put (lin - 1 + L.length lines) - return $ mconcat $ L.zipWith ($) lnums lines - TokenTag v -> - return $ - H.span ! HA.class_ "tag" $ do - H.span ! HA.class_ "tag-open" $ H.toMarkup '#' - H.toMarkup v - TokenEscape c -> return $ H.toMarkup ['\\',c] - TokenLink lnk -> - return $ - H.a ! HA.href (attrify lnk) $ - H.toMarkup lnk - goTokens :: Tokens -> S.State Int Html - goTokens ts = do - ts' <- go`mapM`ts - return $ foldr (<>) mempty ts' + html5Name = + H.span ! HA.class_ "elem-name" $$ + html5ify name + lenName = Text.length name + lenAttrs = sum $ (<$> attrs) $ \(attr_white,Attr{..}) -> + Text.length attr_white + + Text.length attr_name + + Text.length attr_open + + Text.length attr_value + + Text.length attr_close + (lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0) + | otherwise = (1+lenName+lenAttrs+1,2+lenName+1) + o,c :: Html5 + (o,c) | Seq.null ts = + ( "<"<>html5Name<>html5ify attrs<>"/>" + , mempty ) + | otherwise = + ( "<"<>html5Name<>html5ify attrs<>">" + , "html5Name<>">" ) + _ -> do + let (o,c) = pairBorders p ts + H.span ! HA.class_ ("pair-"<>fromString (show p)) $$ do + html5ify $ Cell bp bp{columnPos = columnPos bp + Text.length o} () + H.span ! HA.class_ "pair-open" $$ html5ify o + H.span ! HA.class_ "pair-content" $$ html5ify ts + html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep () + H.span ! HA.class_ "pair-close" $$ html5ify c + html5ify (Tree0 (Cell bp ep t)) = do + html5ify $ Cell bp ep () + case t of + TokenPlain txt -> html5ify txt + {-do + lin <- S.get + let lines = Text.splitOn "\n" txt + let lnums = html5ify : + [ \line -> do + html5ify '\n' + H.a ! HA.id ("line-"<>attrify lnum) $$ return () + html5ify indent + html5ify line + | lnum <- [lin+1..] + ] + S.put (lin - 1 + List.length lines) + return $ mconcat $ List.zipWith ($) lnums lines + -} + TokenTag v -> + H.span ! HA.class_ "tag" $$ do + H.span ! HA.class_ "tag-open" $$ + html5ify '#' + html5ify v + TokenEscape c -> html5ify ['\\',c] + TokenLink lnk -> + H.a ! HA.href (attrify lnk) $$ + html5ify lnk instance Html5ify Attrs where html5ify = mapM_ html5ify -instance Html5ify (Text,Attr) where +instance Html5ify (White,Attr) where html5ify (attr_white,Attr{..}) = do - H.toMarkup attr_white - H.span ! HA.class_ "attr-name" $ - H.toMarkup attr_name - H.toMarkup attr_open - H.span ! HA.class_ "attr-value" $ - H.toMarkup attr_value - H.toMarkup attr_close + html5ify attr_white + H.span ! HA.class_ "attr-name" $$ + html5ify attr_name + html5ify attr_open + H.span ! HA.class_ "attr-value" $$ + html5ify attr_value + html5ify attr_close -- * Utilities tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens tokensTitle tct = - L.find (\case + List.find (\case TreeN (unCell -> KeySection{}) _ts -> True _ -> False) tct >>= \case TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title _ -> Nothing -html5Spaces :: Int -> Html +html5Spaces :: Column -> Html5 html5Spaces 0 = return () -html5Spaces sp = H.span $ html5ify $ Text.replicate sp " " - -html5ifyIndentCell :: (Pos,Pos) -> Html -html5ifyIndentCell (Pos lineLast colLast,Pos line col) - | lineLast < line = do - forM_ [lineLast+1..line] $ \lnum -> do - H.toMarkup '\n' - H.a ! HA.id ("line-"<>attrify lnum) $ return () - H.toMarkup $ Text.replicate (col - 1) " " - | lineLast == line - && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " " - | otherwise = undefined +html5Spaces sp = H.span $$ html5ify $ Text.replicate sp " " diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 3a470d9..2ab35c1 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -2,42 +2,45 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Render a TCT file in plain Text. module Language.TCT.Write.Plain where import Control.Applicative (liftA2) -import Control.Monad (Monad(..), mapM) +import Control.Monad (Monad(..)) import Data.Bool +import Data.Char (Char) import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Function (($), (.), id) +import Data.Function (($), (.)) import Data.Functor ((<$>)) -import Data.Int (Int,Int64) +import Data.Int (Int64) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..), ViewR(..)) -import Data.String (String) +import Data.Sequence (ViewL(..)) +import Data.String (String, IsString(..)) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..),Trees) -import GHC.Exts (IsString(..)) +import Data.Tuple (fst) import Prelude (Num(..), undefined, Integral(..)) import Text.Show (Show(..)) -import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State as S -import qualified Data.List as L import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB -import Language.TCT.Tree +-- import Language.TCT.Tree +-- import Language.TCT.Token import Language.TCT.Cell -import Language.TCT.Token import Language.TCT.Elem +import Language.TCT.Read.Token -- * Type 'Plain' -type Plain = R.Reader State TL.Text +type Plain = S.State State TLB.Builder + -- NOTE: To get maximum performance when building lazy Text values using a builder, + -- associate mappend calls to the right. + -- NOTE: (Semigroup.<>) associates to the right. instance IsString Plain where fromString = return . fromString instance Semigroup Plain where @@ -47,55 +50,55 @@ instance Monoid Plain where mappend = (<>) runPlain :: Plain -> State -> TL.Text -runPlain p s = {-TLB.toLazyText .-} R.runReader p s +runPlain p s = TLB.toLazyText $ fst $ S.runState p s text :: Plainify a => State -> a -> TL.Text text st a = runPlain (plainify a) st --- * Type 'State' +-- ** Type 'State' data State = State - { state_escape :: Bool + { state_escape :: Bool -- FIXME: useful? + , state_pos :: Pos } deriving (Eq, Show) instance Default State where def = State { state_escape = True + , state_pos = pos1 } -- * Class 'Plainify' class Plainify a where plainify :: a -> Plain +instance Plainify Char where + plainify = return . TLB.singleton instance Plainify String where plainify = return . fromString instance Plainify Text where - plainify = return . TL.fromStrict + plainify = plainify . TL.fromStrict instance Plainify TL.Text where - plainify = return + plainify = return . TLB.fromLazyText +instance Plainify a => Plainify (Cell a) where + plainify (Cell _bp@(Pos line col) ep a) = do + Pos lineLast colLast <- S.gets state_pos + case () of + _ | lineLast < line -> do + plainify $ Text.replicate (line - lineLast - 1) "\n" + plainify $ Text.replicate (col - 1) " " + _ | lineLast == line && colLast <= col -> do + plainify $ Text.replicate (col - colLast) " " + _ -> undefined + -- S.modify $ \s -> s{state_pos=bp} + S.modify $ \s -> s{state_pos=ep} + plainify a instance Plainify (Trees (Cell Key) Tokens) where - plainify = plainify . treePosLastCell -instance Plainify (Trees (Pos,Cell Key) (Pos,Tokens)) where plainify = foldMap plainify -instance Plainify (Tree (Pos,Cell Key) (Pos,Tokens)) where - plainify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = - plainifyIndentCell (posEnd,pos) <> - plainify (TL.replicate (int64 lvl) "#") <> " " <> - (case Seq.viewl ts of - Tree0 (_,title) :< _ -> - plainify title - _ -> "") <> - plainify - (case Seq.viewl ts of - Tree0{} :< ts' -> ts' - _ -> ts) - plainify (Tree0 (posEnd,toks)) = - case Seq.viewl toks of - EmptyL -> plainify toks - t0:<_ -> plainifyIndentCell (posEnd,posTree t0) <> plainify toks - plainify (TreeN (posEnd,cell@(Cell pos _ _)) cs) = - plainifyIndentCell (posEnd,pos) <> - plainify (cell, cs) -instance Plainify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where - plainify (Cell _pos _posEnd key, cells) = do +instance Plainify (Tree (Cell Key) Tokens) where + plainify = \case + TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts)) + Tree0 ts -> plainify ts +instance Plainify (Key, Trees (Cell Key) Tokens) where + plainify (key, ts) = case key of KeyColon n wh -> textKey n wh ":" KeyGreat n wh -> textKey n wh ">" @@ -107,90 +110,90 @@ instance Plainify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where "<" <> plainify name <> plainify attrs <> - plainify cells - KeySection{} -> undefined + plainify ts + KeySection lvl -> + plainify (TL.replicate (int64 lvl) "#") <> " " <> + case Seq.viewl ts of + Tree0 title :< ts' -> + plainify title <> + plainify ts' + _ -> plainify ts KeyDotSlash p -> plainify ("./"::TL.Text) <> plainify p <> - plainify cells + plainify ts where textKey :: Text -> White -> TL.Text -> Plain textKey name wh mark = - plainify (textify name <> textify wh <> mark) <> - plainify cells + plainify name <> + plainify wh <> + plainify mark <> + plainify ts instance Plainify Tokens where - plainify toks = - case Seq.viewl toks of - EmptyL -> "" - t0 :< _ -> do - st <- R.ask - return $ goTokens st toks `S.evalState` linePos pos - where - pos = posTree t0 - indent = TL.replicate (int64 $ columnPos pos - 1) " " - go :: State -> Token -> S.State Int TL.Text - go st@State{..} = \case - TreeN (unCell -> p) ts -> do - ts' <- goTokens st ts - return $ textify o<>ts'<>textify c - where (o,c) = pairBorders p ts - Tree0 (unCell -> tok) -> - case tok of - TokenPlain txt -> do - lnum <- S.get - let lines = Text.splitOn "\n" txt - S.put (lnum - 1 + L.length lines) - return $ - case lines of - [] -> undefined - (l0:ls) -> textify l0 <> mconcat ((\l -> "\n"<>indent<>textify l)<$>ls) - TokenTag v -> return $ "#"<>textify v - TokenEscape c -> do - return $ - if state_escape - then textify $ Text.pack ['\\',c] - else TL.singleton c - TokenLink lnk -> return $ textify lnk - goTokens :: State -> Tokens -> S.State Int TL.Text - goTokens st ts = do - ts' <- go st`mapM`ts - return $ foldr (<>) mempty ts' + plainify = foldMap plainify +instance Plainify Token where + plainify = \case + TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts)) + Tree0 ts -> plainify ts +instance Plainify (TokenKey, Tokens) where + plainify (k,ts) = + plainify o <> plainify ts <> plainify c + where (o,c) = pairBorders k ts +instance Plainify TokenValue where + plainify = \case + TokenPlain txt -> plainify txt + {- TODO: remove + lnum <- S.get + let lines = Text.splitOn "\n" txt + S.put (lnum - 1 + List.length lines) + return $ + case lines of + [] -> undefined + (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls) + -} + TokenTag v -> plainify '#'<>plainify v + TokenEscape c -> do + esc <- S.gets state_escape + if esc + then plainify ['\\',c] + else plainify c + TokenLink lnk -> plainify lnk instance Plainify Attrs where - plainify = plainify . textify - --- * Class 'Textify' -class Textify a where - textify :: a -> TL.Text -instance Textify Text where - textify = TL.fromStrict -instance Textify TL.Text where - textify = id -instance Textify Attrs where - textify = foldMap textify -instance Textify (Text,Attr) where - textify (attr_white,Attr{..}) = - mconcat $ textify <$> + plainify = foldMap plainify +instance Plainify (Text,Attr) where + plainify (attr_white,Attr{..}) = + mconcat $ plainify <$> [ attr_white , attr_name , attr_open , attr_value , attr_close ] + +{- +-- * Class 'Textify' +class Textify a where + plainify :: a -> TL.Text +instance Textify Text where + plainify = TL.fromStrict +instance Textify TL.Text where + plainify = id +instance Textify Tokens where + plainify = foldMap plainify instance Textify Token where - textify = \case - TreeN (unCell -> p) ts -> textify o<>textify ts<>textify c + plainify = \case + TreeN (unCell -> p) ts -> plainify o<>plainify ts<>plainify c where (o,c) = pairBorders p ts Tree0 (unCell -> t) -> case t of - TokenPlain txt -> textify txt - TokenTag v -> "#"<>textify v - TokenEscape c -> TL.singleton c -- textify $ Text.pack ['\\',c] - TokenLink lnk -> textify lnk -instance Textify Tokens where - textify = foldMap textify + TokenPlain txt -> plainify txt + TokenTag v -> "#"<>plainify v + TokenEscape c -> TL.singleton c -- plainify $ Text.pack ['\\',c] + TokenLink lnk -> plainify lnk +-} +{- -- * Utilities - plainifyIndentCell :: (Pos,Pos) -> Plain plainifyIndentCell (Pos lineLast colLast,Pos line col) | lineLast < line = @@ -239,6 +242,7 @@ treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1) S.put $ posEndCell p ts' <- go`mapM`ts return $ TreeN (lastPos,p) ts' +-} -- ** 'Int64' int64 :: Integral i => i -> Int64 diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 9de7c95..1c5c078 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -162,14 +162,14 @@ instance Xmlify Tokens where xmlify inh paren _ -> TreeN (Cell bp eb "rref") $ - xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.textify bracket)] <> + xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.text def bracket)] <> xmlify inh paren t :< ts -> xmlify inh t `unionXml` xmlify inh ts Seq.EmptyL -> mempty instance Xmlify Token where xmlify inh (TreeN (Cell bp ep p) ts) = case p of - PairBracket | to <- Plain.textify ts + PairBracket | to <- Plain.text def ts , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> Seq.singleton $ TreeN (cell "rref") $ @@ -197,7 +197,7 @@ instance Xmlify Token where PairHash -> Seq.singleton $ TreeN (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Plain.textify ts)] + xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)] PairElem name attrs -> Seq.singleton $ TreeN (cell $ xmlLocalName name) $ @@ -406,7 +406,7 @@ spanlTokens = getAttrId :: TCTs -> Text getAttrId ts = case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of - Just (Tree0 toks) -> TL.toStrict $ Plain.textify toks + Just (Tree0 toks) -> TL.toStrict $ Plain.text def toks _ -> "" setXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text)) diff --git a/Text/Blaze/Utils.hs b/Text/Blaze/Utils.hs index 51549a9..b801e09 100644 --- a/Text/Blaze/Utils.hs +++ b/Text/Blaze/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Text.Blaze.Utils where @@ -19,6 +20,7 @@ import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import Data.Text (Text) +import GHC.Exts (IsList(..)) import Prelude (Num(..), undefined) import System.IO (IO) import Text.Blaze as B @@ -59,6 +61,10 @@ whenText t f = f t instance Semigroup H.AttributeValue where (<>) = mappend +instance IsList H.AttributeValue where + type Item AttributeValue = AttributeValue + fromList = mconcat . List.intersperse " " + toList = pure -- * Class 'Attrify' class Attrify a where @@ -93,6 +99,11 @@ instance MayAttr AttributeValue where -- * Type 'StateMarkup' -- | Composing state and markups. type StateMarkup st = Compose (S.State st) B.MarkupM +instance Semigroup (StateMarkup st a) where + x<>y = x>>y +instance Monoid (StateMarkup st ()) where + mempty = pure () + mappend = (<>) instance Monad (StateMarkup st) where return = pure Compose sma >>= a2csmb = diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index ea6037e..4dc1b36 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -35,16 +35,18 @@ import qualified Text.Blaze.Utils as Blaze import Data.Locale import qualified Data.TreeSeq.Strict as Tree +{- import qualified Language.DTC.Read.TCT as DTC.Read.TCT import qualified Language.DTC.Sym as DTC import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5 import qualified Language.DTC.Write.XML as DTC.Write.XML +import qualified Text.Blaze.DTC as Blaze.DTC +import qualified Text.Blaze.HTML5 as Blaze.HTML5 +-} import qualified Language.RNC.Write as RNC import qualified Language.TCT as TCT import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 import qualified Language.TCT.Write.XML as TCT.Write.XML -import qualified Text.Blaze.DTC as Blaze.DTC -import qualified Text.Blaze.HTML5 as Blaze.HTML5 import qualified Text.Megaparsec as P import Read @@ -77,11 +79,18 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = case TCT.readTCTs input txt of Left err -> error $ P.parseErrorPretty err Right tct -> do - hPrint stderr $ Tree.Pretty tct + when (trace_TCT trace) $ do + hPutStrLn stderr "### TCT ###" + hPrint stderr $ Tree.Pretty tct + when (trace_XML trace) $ do + hPutStrLn stderr "### XML ###" + let xml = TCT.Write.XML.xmlDocument tct + hPrint stderr $ Tree.Pretty xml case format of TctFormatHTML5 -> Blaze.renderMarkupToByteStringIO BS.putStr $ - TCT.Write.HTML5.html5ify tct + TCT.Write.HTML5.html5Document tct +{- mainWithCommand (CommandDTC ArgsDTC{..}) = readFile input $ \_fp txt -> case TCT.readTCTs input txt of @@ -110,6 +119,7 @@ mainWithCommand (CommandDTC ArgsDTC{..}) = mainWithCommand (CommandRNC ArgsRNC{}) = forM_ DTC.dtcRNC $ \w -> Text.hPutStrLn stdout $ RNC.renderWriter w +-} -- * Options utils @@ -130,8 +140,10 @@ readMap m = -- * Type 'Command' data Command = CommandTCT ArgsTCT + {- | CommandDTC ArgsDTC | CommandRNC ArgsRNC + -} pCommand :: Lang -> Parser Command pCommand lang = @@ -140,7 +152,7 @@ pCommand lang = , command "tct" $ info (CommandTCT <$> pArgsTCT) $ progDesc "TCT (Texte Convivial Technique) rendition." - ] <|> + ] {-<|> hsubparser [ metavar "dtc" , command "dtc" $ @@ -152,7 +164,7 @@ pCommand lang = , command "rnc" $ info (CommandRNC <$> pArgsRNC) $ progDesc "RNC (RelaxNG Compact) schema." - ] + ]-} -- * Type 'Trace' data Trace @@ -200,6 +212,7 @@ data ArgsTCT = ArgsTCT { input :: FilePath , format :: TctFormat + , trace :: Trace } pArgsTCT :: Parser ArgsTCT @@ -207,6 +220,7 @@ pArgsTCT = ArgsTCT <$> argument str (metavar "FILE") <*> pTctFormat + <*> pTrace -- *** Type 'TctFormat' data TctFormat -- 2.42.0 From 5990c791268a95f2fbabc2790f63f774a9d89005 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 24 Jan 2018 09:37:56 +0100 Subject: [PATCH 10/16] Add NodePara and NodeGroup. --- Data/TreeSeq/Strict.hs | 117 +++++---- Language/TCT/Cell.hs | 261 +++++++++++++++---- Language/TCT/Elem.hs | 99 +++++-- Language/TCT/Read.hs | 144 ++++------- Language/TCT/Read/Cell.hs | 89 ++++++- Language/TCT/Read/Elem.hs | 163 ++++++++---- Language/TCT/Read/Token.hs | 504 ++++++++++++++++++------------------ Language/TCT/Read/Tree.hs | 207 ++++++++------- Language/TCT/Token.hs | 126 +++++++-- Language/TCT/Tree.hs | 328 ++++++++++++----------- Language/TCT/Write/HTML5.hs | 92 ++++--- Language/TCT/Write/Plain.hs | 139 ++++++---- Language/TCT/Write/XML.hs | 159 ++++++++---- Language/XML.hs | 17 +- exe/cli/Main.hs | 11 +- 15 files changed, 1490 insertions(+), 966 deletions(-) diff --git a/Data/TreeSeq/Strict.hs b/Data/TreeSeq/Strict.hs index 3c967bb..38a21ed 100644 --- a/Data/TreeSeq/Strict.hs +++ b/Data/TreeSeq/Strict.hs @@ -1,128 +1,127 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Data.TreeSeq.Strict where import Control.Applicative (Applicative(..)) -import Control.Monad (Monad(..), ap) +import Control.Monad (Monad(..)) import Data.Bool import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Foldable (foldr) import Data.Function (($), (.)) -import Data.Functor (Functor, (<$>)) -import Data.Maybe (Maybe(..)) +import Data.Functor (Functor(..), (<$>)) +import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, ViewL(..)) -import Data.Text (Text) import Data.Traversable (Traversable(..)) import Text.Show (Show(..)) import qualified Data.List as List import qualified Data.Sequence as Seq -import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL -- * Type 'Tree' -data Tree k a - = TreeN !k !(Trees k a) - | Tree0 !a - deriving (Eq, Ord, Show, Functor) - -instance Traversable (Tree k) where - traverse f (Tree0 a) = Tree0 <$> f a - traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts - sequenceA (Tree0 a) = Tree0 <$> a - sequenceA (TreeN k ts) = TreeN k <$> traverse sequenceA ts -instance Foldable (Tree k) where - foldMap f (TreeN _k ts) = foldMap (foldMap f) ts - foldMap f (Tree0 a) = f a -instance Applicative (Tree k) where - pure = Tree0 - (<*>) = ap -instance Monad (Tree k) where - return = Tree0 - Tree0 v >>= f = f v - TreeN k ts >>= f = - TreeN k $ (>>= f) <$> ts - -isTree0 :: Tree k a -> Bool -isTree0 Tree0{} = True -isTree0 _ = False - -isTreeN :: Tree k a -> Bool -isTreeN TreeN{} = True -isTreeN _ = False - -unTree :: Tree a a -> a -unTree (TreeN k _) = k -unTree (Tree0 a) = a - +data Tree a + = Tree { unTree :: !a + , subTrees :: !(Trees a) + } + deriving (Eq, Ord, Show) +instance Functor Tree where + fmap f (Tree a ts) = Tree (f a) (fmap (fmap f) ts) +instance Applicative Tree where + pure a = Tree a mempty + Tree f tfs <*> ta@(Tree a tas) = + Tree (f a) (fmap (f <$>) tas <> fmap (<*> ta) tfs) +instance Monad Tree where + return = pure + Tree a ts >>= f = + Tree a' (ts' <> fmap (>>= f) ts) + where Tree a' ts' = f a +instance Foldable Tree where + foldMap f (Tree a ts) = f a `mappend` foldMap (foldMap f) ts +instance Traversable Tree where + traverse f (Tree a ts) = Tree <$> f a <*> traverse (traverse f) ts + sequenceA (Tree a ts) = Tree <$> a <*> traverse sequenceA ts + +tree0 :: a -> Tree a +tree0 a = Tree a mempty + +isTree0 :: Tree a -> Bool +isTree0 (Tree _ ts) = null ts + +isTreeN :: Tree a -> Bool +isTreeN (Tree _ ts) = not (null ts) + +{- mapWithNode :: (Maybe k -> a -> b) -> Tree k a -> Tree k b mapWithNode = go Nothing where - go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts) + go _k f (Tree k ts) = Tree k (go (Just k) f <$> ts) go k f (Tree0 a) = Tree0 (f k a) mapAlsoNode :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b mapAlsoNode fk fv = go Nothing where - go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts + go _k (Tree k ts) = Tree (fk k) $ go (Just k) <$> ts go k (Tree0 a) = Tree0 (fv k a) traverseWithNode :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b) traverseWithNode = go Nothing where - go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts + go _p f (Tree k ts) = Tree k <$> traverse (go (Just k) f) ts go p f (Tree0 a) = Tree0 <$> f p a foldlWithTree :: (b -> Tree k a -> b) -> b -> Tree k a -> b foldlWithTree f b t = case t of - TreeN _k ts -> foldl' (foldlWithTree f) (f b t) ts + Tree _k ts -> foldl' (foldlWithTree f) (f b t) ts Tree0{} -> f b t bindTree :: Tree k a -> (Tree k a -> Tree l b) -> Tree l b bindTree t f = case t of Tree0{} -> f t - TreeN _k ks -> + Tree _k ks -> case f t of u@Tree0{} -> u - TreeN l ls -> TreeN l $ ls <> ((`bindTree` f) <$> ks) + Tree l ls -> Tree l $ ls <> ((`bindTree` f) <$> ks) bindTrees :: Tree k a -> (Tree k a -> Trees l b) -> Trees l b bindTrees t f = case t of Tree0{} -> f t - TreeN _k ks -> + Tree _k ks -> f t >>= \fs -> case fs of Tree0 b -> Seq.singleton $ Tree0 b - TreeN l ls -> pure $ TreeN l $ ls <> (ks >>= (`bindTrees` f)) + Tree l ls -> pure $ Tree l $ ls <> (ks >>= (`bindTrees` f)) joinTrees :: Trees k (Trees k a) -> Trees k a joinTrees ts = ts >>= \case Tree0 s -> s - TreeN k ks -> Seq.singleton $ TreeN k $ joinTrees ks + Tree k ks -> Seq.singleton $ Tree k $ joinTrees ks +-} -- * Type 'Trees' -type Trees k a = Seq (Tree k a) +type Trees a = Seq (Tree a) -- * Type 'Pretty' -newtype Pretty k a = Pretty (Trees k a) -instance (Show k, Show a) => Show (Pretty k a) where - show (Pretty t) = Text.unpack $ prettyTrees t +newtype Pretty a = Pretty a +instance Show a => Show (Pretty (Trees a)) where + show (Pretty t) = TL.unpack $ prettyTrees t +instance Show a => Show (Pretty (Tree a)) where + show (Pretty t) = TL.unpack $ prettyTree t -prettyTree :: (Show k, Show a) => Tree k a -> Text -prettyTree = Text.unlines . pretty +prettyTree :: Show a => Tree a -> TL.Text +prettyTree = TL.unlines . pretty -prettyTrees :: (Show k, Show a) => Trees k a -> Text +prettyTrees :: Show a => Trees a -> TL.Text prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) "" -pretty :: (Show k, Show a) => Tree k a -> [Text] -pretty (Tree0 a) = [Text.pack (show a)] -pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0 +pretty :: Show a => Tree a -> [TL.Text] +pretty (Tree a ts0) = TL.pack (show a) : prettySubTrees ts0 where prettySubTrees s = case Seq.viewl s of diff --git a/Language/TCT/Cell.hs b/Language/TCT/Cell.hs index 3746748..0c96836 100644 --- a/Language/TCT/Cell.hs +++ b/Language/TCT/Cell.hs @@ -1,55 +1,196 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Language.TCT.Cell where import Data.Eq (Eq(..)) 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(..)) -import Data.TreeSeq.Strict (Tree(..)) -import Prelude (Int) +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import Prelude (Int, Num(..), fromIntegral) import Text.Show (Show(..), showParen, showString, showChar) -import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL + +-- * Type 'Pos' +-- | Relative position +data Pos + = Pos + { pos_line :: {-# UNPACK #-} !LineNum + , pos_column :: {-# UNPACK #-} !ColNum + } deriving (Eq) +instance Semigroup Pos where + Pos lx cx <> Pos ly cy = + Pos (lx+ly) (cx+cy) +instance Monoid Pos where + mempty = Pos 0 0 + mappend = (<>) +instance Show Pos where + showsPrec _p Pos{..} = + showsPrec 11 pos_line . + showChar ':' . + showsPrec 11 pos_column + +-- ** Type 'LineNum' +type LineNum = Int + +-- ** Type 'ColNum' +type ColNum = Int -- * Type 'Cell' --- | NOTE: every 'Cell' as a 'Pos', --- which is useful to indicate matches/errors/warnings/whatever, --- or outputing in a format somehow preserving --- the original input style. data Cell a = Cell - { posCell :: {-# UNPACK #-} !Pos - , posEndCell :: {-# UNPACK #-} !Pos - , unCell :: a - } deriving (Eq, Ord, Functor) + { cell_begin :: {-# UNPACK #-} !Pos + , cell_end :: {-# UNPACK #-} !Pos + , unCell :: !a + } deriving (Eq, Functor) instance Show a => Show (Cell a) where showsPrec p Cell{..} = showParen (p >= 10) $ showString "Cell" . - showChar ' ' . showsPrec 10 posCell . - showChar ' ' . showsPrec 10 posEndCell . + showChar ' ' . showsPrec 10 cell_begin . + showChar ' ' . showsPrec 10 cell_end . showChar ' ' . showsPrec 11 unCell +instance (FromPad a, Semigroup a) => Semigroup (Cell a) where + Cell bx (Pos lx _cx) x <> Cell (Pos ly cy) ey y = + Cell bx ey $ x <> fromPad (Pos (ly - lx) cy) <> y +instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where + mempty = cell0 mempty + mappend = (<>) +cell0 :: a -> Cell a +cell0 = Cell mempty mempty + +-- * Class 'FromPad' +class FromPad a where + fromPad :: Pos -> a +instance FromPad Text where + fromPad Pos{..} = + Text.replicate pos_line "\n" <> + Text.replicate pos_column " " +instance FromPad TL.Text where + fromPad Pos{..} = + TL.replicate (fromIntegral pos_line) "\n" <> + TL.replicate (fromIntegral pos_column) " " + {- -instance Semigroup a => Semigroup (Cell a) where +instance (FromPad a, Semigroup a) => Semigroup (Cell a) where Cell bx ex x <> Cell by ey y = - Cell (bx`min`by) (ex`max`ey) (x<>y) -instance (Monoid a, Semigroup a) => Monoid (Cell a) where - mempty = Cell pos1 pos1 mempty - mappend = (<>) + Cell bx ey $ x <> fromPad by <> y +instance Applicative Cell where + pure = Cell mempty mempty + Cell of_ sf f <*> Cell bx ex x = + Cell of_ (sf<>bx<>ex) (f x) + +cell0 :: a -> Cell a +cell0 = pure + +-- * Class 'Cellified' +class Cellified a where + reachOf :: a -> Pos + reachOf a = offsetOf a <> sizeOf a + offsetOf :: a -> Pos + sizeOf :: a -> Pos +instance Cellified (Cell a) where + offsetOf = cell_begin + sizeOf = cell_end +instance Cellified a => Cellified [a] where + reachOf = foldMap reachOf + offsetOf = \case + [] -> mempty + s0 : ss -> + if sizeOf s0 == mempty + then offsetOf s0 <> offsetOf ss + else offsetOf s0 + sizeOf = foldMap sizeOf +instance Cellified a => Cellified (Seq a) where + reachOf = foldMap reachOf + offsetOf s = case Seq.viewl s of + EmptyL -> mempty + s0 :< ss -> + if sizeOf s0 == mempty + then offsetOf s0 <> offsetOf ss + else offsetOf s0 + sizeOf = foldMap sizeOf +instance (Cellified k, Cellified a) => Cellified (Tree k a) where + reachOf = \case + TreeN k _ts -> reachOf k + Tree0 a -> reachOf a + offsetOf = \case + TreeN k _ts -> offsetOf k + Tree0 a -> offsetOf a + sizeOf = \case + TreeN k _ts -> sizeOf k + Tree0 a -> sizeOf a +-} + +{- +-- * Class 'Cellify' +class Cellify a where + cellify :: a -> Cell a +instance Cellify Text where + cellify t = Cell mempty s t + where + s = + Text.foldl' (\acc -> \case + '\n' -> acc{pos_line = pos_line acc + 1} + _ -> acc{pos_column = pos_column acc + 1}) + mempty t + +-- * Type 'Pad' +type Pad = Pos + +-- * Type 'Padded' +data Padded a + = Padded + { pad :: !Pad + , unPad :: !a + } deriving (Eq,Show) + + +-- * Type 'Pos' +-- | Absolute position +data Pos + = Pos + { pos_line :: {-# UNPACK #-} !LineNum + , pos_column :: {-# UNPACK #-} !ColNum + } deriving (Eq, Ord) +instance Show Pos where + showsPrec _p Pos{..} = showsPrec 11 (pos_line,pos_column) + +pos1 :: Pos +pos1 = Pos 1 1 + -} -lineCell :: Cell a -> Line -lineCell = linePos . posCell -columnCell :: Cell a -> Column -columnCell = columnPos . posCell -cell0 :: a -> Cell a -cell0 = Cell pos0 pos0 + + + + +{- +instance Applicative (Cell a) where + pure = cell0 + cf@(Cell bf ef f) <*> ca@(Cell ba ea a) = + | isCell0 cf || isCell0 ca = cell0 (f a) + Cell bf ea (f a) +isCell0 :: Cell a -> Bool +isCell0 (Cell bp ep _) = isPos0 bp && isPos0 ep +-} + +{- +lineCell :: Cell a -> LineNum +lineCell = pos_line . cell_begin +columnCell :: Cell a -> ColNum +columnCell = pos_column . cell_begin + cell1 :: a -> Cell a cell1 = Cell pos1 pos1 +-} +{- posSeq :: Seq (Cell a) -> Maybe (Pos,Pos) posSeq toks = case Seq.viewl toks of @@ -59,8 +200,6 @@ posSeq toks = EmptyR -> Nothing _ :> Cell _bp ep _ -> Just (bp, ep) - -{- posTrees :: Seq (Trees (Cell k) a) -> Maybe (Pos,Pos) posTrees trees = case Seq.viewl trees of @@ -81,38 +220,50 @@ posTrees trees = Just (Cell bp ep ()) -} --- * Type 'Pos' -data Pos - = Pos - { linePos :: {-# UNPACK #-} !Line - , columnPos :: {-# UNPACK #-} !Column - } deriving (Eq, Ord) -instance Show Pos where - showsPrec _p Pos{..} = showsPrec 11 (linePos,columnPos) {- -instance Ord Pos where - Pos lx cx `compare` Pos ly cy = - compare lx ly <> - compare cx cy --} - posTree :: Tree (Cell k) (Cell a) -> Pos -posTree (TreeN c _) = posCell c -posTree (Tree0 c) = posCell c +posTree (TreeN c _) = cell_begin c +posTree (Tree0 c) = cell_begin c posEndTree :: Tree (Cell k) (Cell a) -> Pos -posEndTree (TreeN c _) = posEndCell c -posEndTree (Tree0 c) = posEndCell c +posEndTree (TreeN c _) = cell_end c +posEndTree (Tree0 c) = cell_end c pos0 :: Pos pos0 = Pos 0 0 -pos1 :: Pos -pos1 = Pos 1 1 +-} +{- +instance Ord Pos where + Pos lx cx `compare` Pos ly cy = + compare lx ly <> + compare cx cy --- ** Type 'Line' --- | Line in the source file, counting from 1. -type Line = Int +isPos0 :: Pos -> Bool +isPos0 (Pos 0 0 ) = True +isPos0 _ = False +-} --- ** Type 'Column' --- | Column in the source file, counting from 1. -type Column = Int +{- +-- ** Class 'CellOf' +class CellOf a where + firstCellOf :: a -> Maybe (Cell ()) +instance CellOf (Cell a) where + firstCellOf = Just . (() <$) +instance CellOf a => CellOf (Seq a) where + firstCellOf s = + case Seq.viewl s of + EmptyL -> Nothing + s0 :< ss -> + firstCellOf s0 <|> + firstCellOf ss +instance CellOf a => CellOf [a] where + firstCellOf = \case + [] -> Nothing + s0 : ss -> + firstCellOf s0 <|> + firstCellOf ss +instance (CellOf k, CellOf a) => CellOf (Tree k a) where + firstCellOf = \case + Tree0 a -> firstCellOf a + TreeN k a -> firstCellOf k <|> firstCellOf a +-} diff --git a/Language/TCT/Elem.hs b/Language/TCT/Elem.hs index ef1b342..ed1f293 100644 --- a/Language/TCT/Elem.hs +++ b/Language/TCT/Elem.hs @@ -1,36 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} module Language.TCT.Elem where +import Data.Bool +import Control.Monad (Monad(..), mapM) import Data.Eq (Eq) +import Data.Function (($), (.)) +import Data.Foldable (toList, null) +import Data.Int (Int) import Data.Ord (Ord) +import Data.Maybe (Maybe(..)) +import Prelude ((+)) import Data.Semigroup (Semigroup(..)) import Data.String (String) -import Data.Text (Text) +import Data.Sequence (Seq) import Text.Show (Show(..)) +import Data.TreeSeq.Strict (Tree(..)) +import qualified Control.Monad.Trans.Reader as R +import qualified Data.List as List +import qualified Data.Text.Lazy as TL + +import Debug.Trace (trace) --- import Debug.Trace (trace) trac :: String -> a -> a -trac _m x = x --- trac m x = trace m x +-- trac _m x = x +trac = trace {-# INLINE trac #-} -dbg :: Show a => String -> a -> a -dbg m x = trac (m <> ": " <> show x) x + +debug :: Pretty a => String -> String -> a -> b -> b +debug f n a = trac (f <> ": " <> n <> " = " <> R.runReader (pretty a) 2) + +dbg :: Pretty a => String -> a -> a +dbg m x = trac (m <> ": " <> R.runReader (pretty x) 2) x {-# INLINE dbg #-} --- * Type 'Elem' -type Elem = Text +-- * Class 'Pretty' +class Pretty a where + pretty :: a -> R.Reader Int String +instance Pretty Int where + pretty = return . show +instance Pretty TL.Text where + pretty = return . show +instance (Pretty a, Pretty b) => Pretty (a,b) where + pretty (a,b) = do + i <- R.ask + a' <- R.local (+2) $ pretty a + b' <- R.local (+2) $ pretty b + return $ + "\n" <> List.replicate i ' ' <> "( " <> a' <> + "\n" <> List.replicate i ' ' <> ", " <> b' <> + "\n" <> List.replicate i ' ' <> ") " +instance Pretty a => Pretty [a] where + pretty [] = return "[]" + pretty as = do + i <- R.ask + s <- R.local (+2) $ mapM pretty as + return $ + "\n" <> List.replicate i ' ' <> "[ " <> + List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> + "\n" <> List.replicate i ' ' <> "] " +instance Pretty a => Pretty (Seq a) where + pretty ss + | null ss = return "[]" + | otherwise = do + let as = toList ss + i <- R.ask + s <- R.local (+2) $ mapM pretty as + return $ + "\n" <> List.replicate i ' ' <> "[ " <> + List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> + "\n" <> List.replicate i ' ' <> "] " +instance Pretty a => Pretty (Maybe a) where + pretty Nothing = return "Nothing" + pretty (Just m) = do + s <- pretty m + return $ "Just "<>s +instance Show a => Pretty (Tree a) where + pretty (Tree n ts) = do + s <- R.local (+2) (pretty ts) + return $ "Tree "<>showsPrec 11 n ""<>" "<>s + +-- * Type 'ElemName' +type ElemName = TL.Text --- ** Type 'Attr' -data Attr - = Attr - { attr_name :: !Text - , attr_open :: !Text - , attr_value :: !Text - , attr_close :: !Text +-- ** Type 'ElemAttr' +data ElemAttr + = ElemAttr + { elemAttr_name :: !TL.Text + , elemAttr_open :: !TL.Text + , elemAttr_value :: !TL.Text + , elemAttr_close :: !TL.Text } deriving (Eq,Ord,Show) -- ** Type 'White' -type White = Text +type White = TL.Text --- ** Type 'Attrs' -type Attrs = [(White,Attr)] +-- ** Type 'ElemAttrs' +type ElemAttrs = [(White,ElemAttr)] diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs index 740ce23..1250acc 100644 --- a/Language/TCT/Read.hs +++ b/Language/TCT/Read.hs @@ -8,34 +8,30 @@ module Language.TCT.Read , module Language.TCT.Read ) where -import Control.Monad (Monad(..), join) import Control.Applicative (Applicative(..)) +import Control.Monad (Monad(..), join) import Data.Char (Char) import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.)) -import Data.Functor (Functor(..), (<$>)) -import Data.Foldable (toList) +import Data.Functor ((<$>), (<$)) +import Data.Foldable (Foldable(..)) import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq) import Data.String (IsString) -import Data.Text (Text) import Data.Traversable (Traversable(..)) -import Data.TreeSeq.Strict (Tree) -import Data.Tuple (snd) +import Data.TreeSeq.Strict (Tree(..), Trees) import Data.Void (Void) import System.IO (FilePath) import Text.Show (Show(..)) -import qualified Data.Text as Text -import qualified Text.Megaparsec as P -import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL import qualified Data.TreeSeq.Strict as Tree +import qualified Text.Megaparsec as P +-- import qualified Data.List as List import Language.TCT.Tree -import Language.TCT.Token import Language.TCT.Cell import Language.TCT.Read.Cell import Language.TCT.Read.Tree @@ -43,86 +39,52 @@ import Language.TCT.Read.Token import Debug.Trace (trace) --- * Type 'TCT' -type TCT = Tree (Cell Key) Tokens - --- * Type 'TCTs' -type TCTs = Seq TCT - -readTCTs :: - FilePath -> Text -> - Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCTs -readTCTs inp txt = do +readTrees :: + FilePath -> TL.Text -> + Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node)) +readTrees inp txt = do trs <- P.runParser (p_Trees <* P.eof) inp txt - traverse (go Nothing) $ trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs + {-(join <$>) $ -} + traverse (go Nothing) $ + trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs where go :: - Maybe Key -> - Tree (Cell Key) (Cell Value) -> - Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCT - go k (Tree0 v) = - case k of - Just KeyBar{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v] - Just KeyLower{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v] - Just KeyEqual{} -> Right $ Tree0 $ tokens [Tree0 $ TokenPlain <$> v] - _ -> Tree0 . parseTokens <$> parseLexemes v - go _ (TreeN c@(unCell -> key) ts) = - case key of - KeyBar{} -> TreeN c <$> traverse (go (Just key)) ts - KeyLower{} -> TreeN c <$> traverse (go (Just key)) ts - KeyEqual{} -> TreeN c <$> traverse (go (Just key)) ts - KeyPara -> do - ls <- - (`traverse` Seq.reverse ts) $ \case - Tree0 v -> parseLexemes v - TreeN ck@(unCell -> k) vs -> - (pure . LexemeTree . TreeN ck <$>) $ - traverse (go (Just k)) vs - let toks = parseTokens $ join $ toList ls - return $ Tree0 toks - _ -> TreeN c <$> traverse (go (Just key)) ts - parseLexemes :: - Cell Value -> - Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) [Lexeme] - parseLexemes (Cell bp _ep v) = - snd $ - P.runParser' - (p_Lexemes <* P.eof) - P.State - { P.stateInput = v - , P.statePos = pure $ P.SourcePos inp - (P.mkPos $ linePos bp) - (P.mkPos $ columnPos bp) - , P.stateTabWidth = P.pos1 - , P.stateTokensProcessed = 0 - } - --- * Type 'StreamCell' --- | Wrap 'Text' to have a 'P.Stream' instance --- whose 'P.advance1' method abuses the tab width state --- to instead pass the line indent. --- This in order to report correct 'P.SourcePos' --- when parsing a 'Cell' containing newlines. -newtype StreamCell = StreamCell { unStreamCell :: Text } - deriving (IsString,Eq,Ord) -instance P.Stream StreamCell where - type Token StreamCell = Char - type Tokens StreamCell = StreamCell - take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t - takeN_ n (StreamCell t) = - (\(ts,s) -> (StreamCell ts, StreamCell s)) <$> - P.takeN_ n t - takeWhile_ f (StreamCell t) = - (\(ts,s) -> (StreamCell ts, StreamCell s)) $ - P.takeWhile_ f t - tokensToChunk _s ts = StreamCell (P.tokensToChunk (Proxy::Proxy Text) ts) - chunkToTokens _s (StreamCell ch) = P.chunkToTokens (Proxy::Proxy Text) ch - chunkLength _s (StreamCell ch) = P.chunkLength (Proxy::Proxy Text) ch - advance1 _s = advance1 - advanceN _s indent pos (StreamCell t) = Text.foldl' (advance1 indent) pos t - -advance1 :: P.Pos -> P.SourcePos -> Char -> P.SourcePos -advance1 indent (P.SourcePos n line col) c = - case c of - '\n' -> P.SourcePos n (line <> P.pos1) indent - _ -> P.SourcePos n line (col <> P.pos1) + Maybe Node -> + Tree (Cell Node) -> + Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) + (Tree (Cell Node)) + go p t@(Tree c@(Cell bn en nod) ts) = + case nod of + NodeGroup{} -> Tree c <$> traverse (go (Just nod)) ts + NodeHeader{} -> Tree c <$> traverse (go (Just nod)) ts + NodeToken{} -> Tree c <$> traverse (go (Just nod)) ts + NodePair{} -> Tree c <$> traverse (go (Just nod)) ts + NodePara{} -> Tree c <$> traverse (go (Just nod)) ts + NodeLower{} -> Right t + -- NodeText n | TL.null n -> Right t + NodeText n -> + case p of + Just (NodeHeader HeaderBar{}) -> Right t + Just (NodeHeader HeaderEqual{}) -> Right t + _ -> do + toks <- parseTokens <$> parseLexemes inp (n <$ c) + return $ + case toList toks of + [tok] -> tok + _ -> Tree (Cell bn en NodeGroup) toks + {- + NodeHeader _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts + NodeToken _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts + NodePair _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts + NodeLower{} -> Right $ pure t + NodeText n | TL.null n -> Right $ pure t + NodeText n -> + case p of + Just (NodeHeader HeaderBar{}) -> Right $ pure t + Just (NodeHeader HeaderEqual{}) -> Right $ pure t + _ -> do + acc <- parseLexemes inp (n <$ c) + sn <- traverse (go (Just nod)) ts + return $ parseTokens $ + foldr (\s a -> orientLexemePairAny $ LexemeTree s:a) acc (join sn) + -} diff --git a/Language/TCT/Read/Cell.hs b/Language/TCT/Read/Cell.hs index d5f7d77..c6f69d3 100644 --- a/Language/TCT/Read/Cell.hs +++ b/Language/TCT/Read/Cell.hs @@ -1,34 +1,47 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} module Language.TCT.Read.Cell where +import Control.Applicative (Applicative(..)) import Data.Char (Char) import Data.Either (Either(..)) +import Data.Eq (Eq) import Data.Function (($), (.)) import Data.Functor ((<$>)) -import Data.Int (Int) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Ord (Ord) +import Data.Proxy (Proxy(..)) +import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString) -import Prelude (Num(..), toInteger) +import Data.Tuple (snd) +import System.FilePath (FilePath) import Text.Show (Show) import qualified Data.Set as Set +import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import Language.TCT.Cell -- * Type 'Parser' -- | Convenient alias. -type Parser e s a = +type Parser e s a = + Parsable e s a => + P.Parsec e s a + +-- ** Type 'Parsable' +type Parsable e s a = ( P.Stream s , P.Token s ~ Char , Ord e , IsString (P.Tokens s) , P.ShowErrorComponent e - ) => P.Parsec e s a + ) +-- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'. p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a p_satisfyMaybe f = check `P.token` Nothing where @@ -40,19 +53,67 @@ p_satisfyMaybe f = check `P.token` Nothing p_Position :: Parser e s Pos p_Position = (<$> P.getPosition) $ \p -> Pos - (intOfPos $ P.sourceLine p) - (intOfPos $ P.sourceColumn p) -intOfPos :: P.Pos -> Int -intOfPos = fromInteger . toInteger . P.unPos + { pos_line = P.unPos $ P.sourceLine p + , pos_column = P.unPos $ P.sourceColumn p + } + +p_Cell :: Parser e s a -> Parser e s (Cell a) +p_Cell pa = + (\b a e -> Cell b e a) + <$> p_Position + <*> pa + <*> p_Position + +p_LineNum :: Parser e s LineNum +p_LineNum = P.unPos . P.sourceLine <$> P.getPosition + +p_ColNum :: Parser e s ColNum +p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition + +-- | Wrapper around |P.runParser'| +-- to use given 'Cell' as starting position. +runParserOnCell :: + Parsable e StreamCell a => + FilePath -> + Parser e StreamCell a -> + Cell TL.Text -> + Either (P.ParseError (P.Token StreamCell) e) a +runParserOnCell inp p (Cell bp _ep s) = + snd $ P.runParser' (p <* P.eof) + P.State + { P.stateInput = StreamCell s + , P.statePos = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent + , P.stateTabWidth = indent + , P.stateTokensProcessed = 0 + } + where indent = P.mkPos $ pos_column bp -p_LineNum :: Parser e s Line -p_LineNum = intOfPos . P.sourceLine <$> P.getPosition +-- * Type 'StreamCell' +-- | Wrap 'TL.Text' to have a 'P.Stream' instance +-- whose 'P.advance1' method abuses the tab width state +-- to instead pass the line indent. +-- This in order to report correct 'P.SourcePos' +-- when parsing a 'Cell' containing newlines. +newtype StreamCell = StreamCell { unStreamCell :: TL.Text } + deriving (IsString,Eq,Ord) +instance P.Stream StreamCell where + type Token StreamCell = Char + type Tokens StreamCell = TL.Text + take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t + takeN_ n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t + takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t + tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text) + chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text) + chunkLength _s = P.chunkLength (Proxy::Proxy TL.Text) + advance1 _s indent (P.SourcePos n line col) c = + case c of + '\n' -> P.SourcePos n (line <> P.pos1) indent + _ -> P.SourcePos n line (col <> P.pos1) + advanceN s indent = TL.foldl' (P.advance1 s indent) -p_ColNum :: Parser e s Column -p_ColNum = intOfPos . P.sourceColumn <$> P.getPosition -- * Debug pdbg :: Show a => String -> Parser e s a -> Parser e s a --- pdbg m p = P.dbg m p -pdbg _m p = p +pdbg = P.dbg +-- pdbg _m p = p {-# INLINE pdbg #-} diff --git a/Language/TCT/Read/Elem.hs b/Language/TCT/Read/Elem.hs index 3e08dc3..e5f1878 100644 --- a/Language/TCT/Read/Elem.hs +++ b/Language/TCT/Read/Elem.hs @@ -5,69 +5,130 @@ module Language.TCT.Read.Elem where import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad ((>>)) +import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) import Data.Function (($)) -import Data.Functor ((<$>)) +import Data.Functor ((<$>), (<$)) +import Data.Maybe (Maybe(..)) import Data.Semigroup (Semigroup(..)) -import Data.Text (Text) import qualified Data.Char as Char -import qualified Data.Text as Text import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P +import qualified Data.Text.Lazy as TL import Language.TCT.Elem +import Language.TCT.Tree import Language.TCT.Read.Cell -p_Attrs :: Parser e s [(Text,Attr)] -p_Attrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_Attr -p_Attr :: Parser e s Attr -p_Attr = P.try p_Attr_Eq <|> p_Attr_Word -p_Spaces :: Parser e s Text -p_Spaces = Text.pack <$> P.some (P.satisfy Char.isSpace) -p_Attr_Eq :: Parser e s Attr -p_Attr_Eq = - (\n (o,v,c) -> Attr n ("="<>o) v c) - <$> p_Word +-- * Word +p_Spaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_Spaces = P.takeWhileP (Just "Space") Char.isSpace +p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_Spaces1 = P.takeWhile1P (Just "Space") Char.isSpace +p_HSpaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_HSpaces = P.takeWhileP (Just "HSpace") (==' ') +p_Digits :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_Digits = P.takeWhile1P (Just "Digit") Char.isDigit +p_AlphaNums :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_AlphaNums = P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum +{- +-- NOTE: could be done with TL.Text, which has a less greedy (<>). +p_Word :: Parser e Text Text +p_Word = pdbg "Word" $ P.try p_take <|> p_copy + where + p_take = do + P.notFollowedBy $ P.satisfy $ not . Char.isAlphaNum + w <- P.takeWhile1P (Just "Word") $ \c -> + Char.isAlphaNum c || + c == '_' || + c == '-' + guard $ Char.isAlphaNum $ Text.last w + return w + p_copy = + (<>) + <$> p_AlphaNums + <*> P.option "" (P.try $ + (<>) + <$> ((Text.pack <$>) $ P.some $ P.char '_' <|> P.char '-') + <*> p_copy) +-} + +-- * Elem +p_ElemSingle :: P.Tokens s ~ TL.Text => Parser e s Pair +p_ElemSingle = pdbg "ElemSingle" $ + PairElem + <$ P.char '<' + <*> p_ElemName + <*> p_ElemAttrs + <* P.string "/>" + +p_ElemOpen :: P.Tokens s ~ TL.Text => Parser e s Pair +p_ElemOpen = pdbg "ElemOpen" $ + PairElem + <$ P.char '<' + <*> p_ElemName + <*> p_ElemAttrs + <* P.char '>' + +p_ElemName :: P.Tokens s ~ TL.Text => Parser e s ElemName +p_ElemName = p_AlphaNums + -- TODO: namespace + +p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair +p_ElemClose = pdbg "ElemClose" $ + (`PairElem` []) + <$ P.string " p_ElemName + <* P.char '>' + +{- +p_ElemOpenOrSingle :: Parser e Text Pair +p_ElemOpenOrSingle = + p_ElemOpen >>= \p -> + P.char '>' $> LexemePairOpen p <|> + P.string "/>" $> LexemePairAny p +-} + +-- * 'ElemAttr' +p_ElemAttrs :: P.Tokens s ~ TL.Text => Parser e s [(White,ElemAttr)] +p_ElemAttrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_ElemAttr +p_ElemAttr :: P.Tokens s ~ TL.Text => Parser e s ElemAttr +p_ElemAttr = P.try p_ElemAttrEq <|> p_ElemAttrName + +p_ElemAttrEq :: P.Tokens s ~ TL.Text => Parser e s ElemAttr +p_ElemAttrEq = + (\n (o,v,c) -> ElemAttr n ("="<>o) v c) + <$> p_ElemName <* P.char '=' - <*> p_Attr_Value -p_Attr_Word :: Parser e s Attr -p_Attr_Word = - (\(o,v,c) -> Attr "" o v c) - <$> p_Attr_Value_Word -p_Attr_Value :: Parser e s (Text,Text,Text) -p_Attr_Value = - p_Attr_Value_Quote '\'' <|> - p_Attr_Value_Quote '"' <|> - p_Attr_Value_Word -p_Attr_Value_Quote :: Char -> Parser e s (Text,Text,Text) -p_Attr_Value_Quote q = - (\o v c -> (Text.singleton o, Text.pack v, Text.singleton c)) + <*> p_ElemAttrValue +p_ElemAttrName :: P.Tokens s ~ TL.Text => Parser e s ElemAttr +p_ElemAttrName = + (\n -> ElemAttr n "" "" "") + <$> p_ElemName + +p_ElemAttrValue :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text) +p_ElemAttrValue = + p_ElemAttrValueQuote '\'' <|> + p_ElemAttrValueQuote '"' <|> + p_ElemAttrValueWord + +p_ElemAttrValueQuote :: Char -> P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text) +p_ElemAttrValueQuote q = + (\o v c -> (TL.singleton o, v, TL.singleton c)) <$> P.char q - <*> P.many ( - P.notFollowedBy (P.string "/>") >> - P.satisfy (\c -> Char.isPrint c && c /= '>' && c/=q)) + <*> P.takeWhile1P (Just "ElemAttrValueQuoted") (/=q) <*> P.char q -p_Attr_Value_Word :: Parser e s (Text,Text,Text) -p_Attr_Value_Word = - (\v -> ("", Text.pack v, "")) - <$> P.many (P.satisfy Char.isAlphaNum) - -p_Word :: Parser e s Text -p_Word = pdbg "Word" $ - (<>) - <$> p_plain - <*> P.option "" (p_plain <|> p_link) - where - p_link = P.try $ - (<>) - <$> (Text.pack <$> P.some (P.satisfy (\c -> c=='_' || c=='-'))) - <*> p_plain - p_plain = - Text.pack - <$> P.some (P.satisfy $ \c -> - Char.isLetter c || - Char.isNumber c - ) +p_ElemAttrValueWord :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text) +p_ElemAttrValueWord = do + w <- P.takeWhile1P (Just "ElemAttrValueWord") $ \c -> + Char.isPrint c && + not (Char.isSpace c) && + c /= '\'' && + c /= '"' && + c /= '=' && + c /= '/' && + c /= '<' && + c /= '>' + return ("",w,"") diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index 8b4014d..1401828 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -1,149 +1,121 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Language.TCT.Read.Token where --- import Data.Text.Buildable (Buildable(..)) --- import qualified Data.Text.Lazy as TL --- import qualified Data.Text.Lazy.Builder as Builder import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) -import Data.Int (Int) import Data.Eq (Eq(..)) -import Data.Ord (Ord(..)) +import Data.Either (Either(..)) import Data.Foldable (Foldable(..)) -import Data.Sequence (Seq) import Data.Function (($), (.)) -import Data.Functor ((<$>), ($>), (<$)) +import Data.Functor ((<$>), ($>)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..), (<|)) -import Data.Text (Text) -import Data.TreeSeq.Strict (Tree(..)) +import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>)) +import Data.String (String) +import Data.TreeSeq.Strict (Tree(..), Trees) import Data.Tuple (fst,snd) +import Data.Void (Void) import Prelude (Num(..)) import Text.Show (Show(..)) import qualified Data.Char as Char +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence as Seq import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P -import qualified System.FilePath as FP import Language.TCT.Cell import Language.TCT.Elem +-- import Language.TCT.Token +import Language.TCT.Tree import Language.TCT.Read.Elem import Language.TCT.Read.Cell --- * Type 'Row' --- | In normal order: a list of 'Key's, maybe ended by 'Value', all read on the same line. -type Row = [Tree (Cell Key) (Cell Value)] - --- * Type 'Key' -data Key - = KeyColon !Name !White -- ^ @name: @ - | KeyEqual !Name !White -- ^ @name=@ - | KeyBar !Name !White -- ^ @name|@ - | KeyGreat !Name !White -- ^ @name>@ - | KeyLower !Name !Attrs -- ^ @value@ - | PairStar -- ^ @*value*@ - | PairSlash -- ^ @/value/@ - | PairUnderscore -- ^ @_value_@ - | PairDash -- ^ @-value-@ - | PairBackquote -- ^ @`value`@ - | PairSinglequote -- ^ @'value'@ - | PairDoublequote -- ^ @"value"@ - | PairFrenchquote -- ^ @«value»@ - | PairParen -- ^ @(value)@ - | PairBrace -- ^ @{value}@ - | PairBracket -- ^ @[value]@ - deriving (Eq,Ord,Show) - --- ** Type 'TokenValue' -data TokenValue - = TokenPlain !Text - | TokenTag !Tag - | TokenEscape !Char - | TokenLink !Text - | TokenTree (Tree (Cell Key) (Cell Value)) - deriving (Eq,Ord,Show) - --- ** Type 'Tag' -type Tag = Text +instance Pretty Pair where + pretty = return . show +instance Pretty a => Pretty (Cell a) where + pretty (Cell bp ep m) = do + s <- pretty m + return $ "Cell "<>show bp<>":"<>show ep<>" "<>s +instance Pretty Lexeme where + pretty = return . show -- * Type 'Pairs' -- | Right-only Dyck language type Pairs = (Tokens,[Opening]) +type Tokens = Trees (Cell Node) -- ** Type 'Opening' type Opening = (Cell Pair,Tokens) -appendToken :: Pairs -> Token -> Pairs -appendToken ps = appendTokens ps . Seq.singleton +appendToken :: Pairs -> Tree (Cell Node) -> Pairs +appendToken (ts,[]) tok = (ts|>tok,[]) +appendToken (ts,(p0,t0):ps) tok = (ts,(p0,t0|>tok):ps) appendTokens :: Pairs -> Tokens -> Pairs -appendTokens (t,[]) toks = (t<>toks,[]) -appendTokens (t,(p0,t0):ps) toks = (t,(p0,t0<>toks):ps) +appendTokens (ts,[]) toks = (ts<>toks,[]) +appendTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0<>toks):ps) + +appendText :: Pairs -> Cell TL.Text -> Pairs +appendText ps tok = + case ps of + (ts,[]) -> (appendTokenText ts tok,[]) + (ts,(p0,ts0):pss) -> (ts,(p0,appendTokenText ts0 tok):pss) + +appendTokenText :: Tokens -> Cell TL.Text -> Tokens +appendTokenText ts (Cell bn en n) + {- + | TL.null n = ts + | otherwise-} = + case Seq.viewr ts of + EmptyR -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n + is :> Tree (Cell bo _eo nod) st -> + case nod of + NodeToken (TokenText o) -> is |> i + where i = Tree (Cell bo en (NodeToken $ TokenText (o <> n))) st + _ -> ts |> Tree0 (Cell bn en $ NodeToken $ TokenText n) + +prependTokenText :: Tokens -> Cell TL.Text -> Tokens +prependTokenText ts (Cell bn en n) + {- + | TL.null n = ts + | otherwise-} = + case Seq.viewl ts of + EmptyL -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n + Tree (Cell _bo eo nod) st :< is -> + case nod of + NodeToken (TokenText o) -> i <| is + where i = Tree (Cell bn eo (NodeToken $ TokenText (n <> o))) st + _ -> Tree0 (Cell bn en $ NodeToken $ TokenText n) <| ts openPair :: Pairs -> Cell Pair -> Pairs -openPair (t,ms) p = (t,(p,mempty):ms) +openPair (t,ps) p = (t,(p,mempty):ps) -- | Close a 'Pair' when there is a matching 'LexemePairClose'. closePair :: Pairs -> Cell Pair -> Pairs -closePair ps@(_,[]) (Cell bp ep p) = dbg "closePair" $ - appendToken ps $ - Tree0 $ Cell bp ep $ - TokenPlain $ snd $ pairBorders p tokensPlainEmpty -closePair (t,(p1,t1):ts) p = dbg "closePair" $ +closePair ps@(_,[]) (Cell bp ep p) = -- dbg "closePair" $ + appendText ps $ Cell bp ep $ snd $ pairBorders p +closePair (t,(p1,t1):ts) p = -- dbg "closePair" $ case (p1,p) of - (Cell bx _ex (PairElem x ax), Cell _by ey (PairElem y ay)) | x == y -> + (Cell bx _ex (PairElem nx ax), Cell _by ey (PairElem ny ay)) | nx == ny -> appendToken (t,ts) $ - TreeN (Cell bx ey $ PairElem x (ax<>ay)) t1 + Tree (Cell bx ey $ NodePair $ PairElem nx as) t1 + where as | null ay = ax + | otherwise = ax<>ay (Cell bx _ex x, Cell _by ey y) | x == y -> appendToken (t,ts) $ - TreeN (Cell bx ey x) t1 + Tree (Cell bx ey $ NodePair x) t1 _ -> (`closePair` p) $ appendTokens @@ -155,67 +127,128 @@ closeImpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens closeImpaired acc (Cell bp ep p,toks) = dbg "closeImpaired" $ case p of -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'. + PairHash | Just (Cell bt et t, ts) <- tagFrom $ toks <> acc -> + Tree0 (Cell bt et $ NodeToken $ TokenTag t) <| ts + {- PairHash | (Tree0 (Cell bt et (TokenPlain t))) :< ts <- Seq.viewl $ toks <> acc -> case Text.span isTagChar t of ("",_) | Text.null t -> toksHash mempty <> toks <> acc - | otherwise -> Tree0 (Cell bp et (TokenTag t)) <| ts + | otherwise -> Tree0 (Cell bp et (TokenTag t)) <| ts (tag,t') -> let len = Text.length tag in Tree0 (Cell bp bt{columnPos = columnPos bt + len} (TokenTag tag)) <| Tree0 (Cell bt{columnPos = columnPos bt + len + 1} et (TokenPlain t')) <| ts - _ -> toksHash tokensPlainEmpty <> toks <> acc + -} + _ -> prependTokenText (toks <> acc) toksHash where - toksHash = tokens1 . Tree0 . Cell bp ep . TokenPlain . fst . pairBorders p - isTagChar c = - Char.isAlphaNum c || - c=='·' || - case Char.generalCategory c of - Char.DashPunctuation -> True - Char.ConnectorPunctuation -> True - _ -> False + toksHash :: Cell TL.Text + toksHash = Cell bp ep $ fst $ pairBorders p + +isTagChar :: Char -> Bool +isTagChar c = + Char.isAlphaNum c || + c=='·' || + case Char.generalCategory c of + Char.DashPunctuation -> True + Char.ConnectorPunctuation -> True + _ -> False + +-- * Class 'TagFrom' +class TagFrom a where + tagFrom :: a -> Maybe (Cell Tag, a) +instance TagFrom Tokens where + tagFrom ts = + case Seq.viewl ts of + EmptyL -> Nothing + Tree0 (Cell b0 e0 n) :< ns -> + case n of + NodeToken (TokenText t) -> + case tagFrom $ Cell b0 e0 t of + Nothing -> Nothing + Just (t0,r0) -> + if TL.null (unCell r0) + then + case tagFrom ns of + Just (t1@(Cell b1 _e1 _), r1) | e0 == b1 -> + Just (t0<>t1, r1) + _ -> Just (t0, n0 <| ns) + else Just (t0, n0 <| ns) + where n0 = (Tree0 $ NodeToken . TokenText <$> r0) + _ -> Nothing + _ -> Nothing +instance TagFrom (Cell TL.Text) where + tagFrom (Cell bp ep t) + | (w,r) <- TL.span isTagChar t + , not $ TL.null w + , ew <- pos_column bp + sum (Text.length <$> (TL.toChunks w)) = + Just + ( Cell bp bp{pos_column=ew} w + , Cell bp{pos_column=ew} ep r ) + tagFrom _ = Nothing -- | Close remaining 'Pair's at end of parsing. closePairs :: Pairs -> Tokens -closePairs (t0,ps) = dbg "closePairs" $ +closePairs (t0,ps) = -- dbg "closePairs" $ t0 <> foldl' closeImpaired mempty ps appendLexeme :: Lexeme -> Pairs -> Pairs appendLexeme lex acc = - dbg "appendLexeme" $ + -- dbg "appendLexeme" $ case lex of - LexemePairOpen ps -> foldl' open acc ps + LexemePairOpen ps -> foldl' openPair acc ps + {- where - open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Tree0 $ Cell ep ep $ TokenPlain "") + open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Tree0 $ Cell ep ep $ TokenPhrase $ PhraseWhite "") open a p = openPair a p + -} LexemePairClose ps -> foldl' closePair acc ps - LexemePairAny ps -> appendTokens acc $ tokens $ Tree0 . ((\p -> TokenPlain $ fst $ pairBorders p mempty) <$>) <$> ps - LexemePairBoth ps -> appendTokens acc $ tokens $ (`TreeN`mempty) <$> ps - LexemeEscape c -> appendToken acc $ Tree0 $ TokenEscape <$> c - LexemeLink t -> appendToken acc $ Tree0 $ TokenLink <$> t + LexemePairAny ps -> + appendText acc $ sconcat $ + ((fst . pairBordersWithoutContent) <$>) <$> ps + LexemePairBoth ps -> appendTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps + LexemeEscape c -> appendToken acc $ Tree0 $ NodeToken . TokenEscape <$> c + LexemeLink t -> appendToken acc $ Tree0 $ NodeToken . TokenLink <$> t {-LexemeWhite (unCell -> "") -> acc-} - LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc - LexemeWhite cs -> appendToken acc $ Tree0 $ TokenPlain <$> cs - LexemeAlphaNum cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs - LexemeAny cs -> appendToken acc $ Tree0 $ TokenPlain . Text.pack <$> cs - -- LexemeToken ts -> appendTokens acc ts + -- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc + LexemeWhite t -> appendText acc t + LexemeAlphaNum t -> appendText acc t + LexemeOther t -> appendText acc t + LexemeTree t -> appendToken acc t + LexemeEnd -> acc + +{- TODEL +appendTokenChild :: Pairs -> Tree (Cell Node) -> Pairs +appendTokenChild pairs tree = + debug "appendTokenChild" "pairs" pairs $ + debug "appendTokenChild" "tree" tree $ + dbg "appendTokenChild" $ + go pairs tree + where + go (ts@(toList -> [unTree -> Cell bo _eo NodeText{}]),[]) + tok@(Tree (Cell _bn en _n) _ns) = + (pure $ Tree (Cell bo en NodePara) (ts |> tok),[]) + go (ts,[]) tok = (ts |> tok,[]) + go (ts,(p0,t0):ps) tok = (ts,(p0,t0|>tok):ps) +-} appendLexemes :: Pairs -> [Lexeme] -> Pairs appendLexemes = foldr appendLexeme -- * Type 'Lexeme' data Lexeme - = LexemePairOpen ![Cell Pair] - | LexemePairClose ![Cell Pair] - | LexemePairAny ![Cell Pair] - | LexemePairBoth ![Cell Pair] + = LexemePairOpen !(NonEmpty (Cell Pair)) + | LexemePairClose !(NonEmpty (Cell Pair)) + | LexemePairAny !(NonEmpty (Cell Pair)) + | LexemePairBoth !(NonEmpty (Cell Pair)) | LexemeEscape !(Cell Char) - | LexemeLink !(Cell Text) - | LexemeWhite !(Cell White) - | LexemeAlphaNum !(Cell [Char]) - | LexemeAny !(Cell [Char]) - | LexemeTree !(Tree (Cell Key) Tokens) - deriving (Eq, Ord, Show) + | LexemeLink !(Cell TL.Text) + | LexemeWhite !(Cell TL.Text) + | LexemeAlphaNum !(Cell TL.Text) + | LexemeOther !(Cell TL.Text) + | LexemeTree !(Tree (Cell Node)) + | LexemeEnd + deriving (Eq, Show) -- ** Type 'Lexemes' type Lexemes = Seq Lexeme @@ -224,39 +257,49 @@ parseTokens :: [Lexeme] -> Tokens parseTokens ps = closePairs $ appendLexemes mempty $ - dbg "Lexemes" $ - orientLexemePairAny $ LexemeWhite (cell0 "") : + -- dbg "Lexemes (post orient)" $ + orientLexemePairAny $ LexemeEnd : ps +parseLexemes :: + String -> + Cell TL.Text -> + Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) [Lexeme] +parseLexemes inp = runParserOnCell inp (p_Lexemes <* P.eof) + -- | Parse 'Lexeme's, returning them in reverse order to apply 'orientLexemePairAny'. -p_Lexemes :: Parser e s [Lexeme] +p_Lexemes :: P.Tokens s ~ TL.Text => Parser e s [Lexeme] p_Lexemes = pdbg "Lexemes" $ go [] where - go :: [Lexeme] -> Parser e s [Lexeme] + go :: P.Tokens s ~ TL.Text => [Lexeme] -> Parser e s [Lexeme] go acc = (P.eof $> acc) <|> (p_Lexeme >>= \next -> go $ orientLexemePairAny $ next:acc) orientLexemePairAny :: [Lexeme] -> [Lexeme] orientLexemePairAny = \case - LexemeAny (Cell _bx ex x):LexemeAny (Cell by _ey y):acc -> LexemeAny (Cell by ex (x<>y)):acc + -- LexemeOther (Cell _bx ex x):LexemeOther (Cell by _ey y):acc -> LexemeOther (Cell by ex (x<>y)):acc -- "    + t@LexemeTree{}:LexemePairAny p:acc -> t:LexemePairClose p:acc w@LexemeWhite{}:LexemePairAny p:acc -> w:LexemePairClose p:acc + LexemeEnd:LexemePairAny p:acc -> LexemePairClose p:acc --    " + LexemePairAny p:t@LexemeTree{}:acc -> LexemePairOpen p:t:acc LexemePairAny p:w@LexemeWhite{}:acc -> LexemePairOpen p:w:acc LexemePairAny p:[] -> LexemePairOpen p:[] --    ,,," - LexemePairAny p:a@LexemeAny{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc - LexemePairAny p:a@LexemeAny{}:[] -> LexemePairOpen p:a:[] + LexemePairAny p:a@LexemeOther{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc + LexemePairAny p:a@LexemeOther{}:[] -> LexemePairOpen p:a:[] -- ",,,    - w@LexemeWhite{}:a@LexemeAny{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc + w@LexemeWhite{}:a@LexemeOther{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc + LexemeEnd:a@LexemeOther{}:LexemePairAny p:acc -> a:LexemePairClose p:acc -- ",,,AAA - an@LexemeAlphaNum{}:a@LexemeAny{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc + an@LexemeAlphaNum{}:a@LexemeOther{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc -- ,,,"AAA - an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeAny{}:acc -> an:LexemePairOpen p:a:acc + an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeOther{}:acc -> an:LexemePairOpen p:a:acc -- ") c@LexemePairClose{}:LexemePairAny p:acc -> c:LexemePairClose p:acc @@ -270,27 +313,23 @@ orientLexemePairAny = \case acc -> acc -p_Lexeme :: Parser e s Lexeme +p_some :: Parser e s a -> Parser e s (NonEmpty a) +p_some p = NonEmpty.fromList <$> P.some p + +p_Lexeme :: P.Tokens s ~ TL.Text => Parser e s Lexeme p_Lexeme = pdbg "Lexeme" $ P.choice - [ P.try $ LexemeWhite <$> p_Cell p_Spaces - , P.try $ LexemePairAny <$> P.some (p_Cell $ p_satisfyMaybe pairAny) - , P.try $ LexemePairBoth <$> P.some (P.try $ p_Cell p_ElemSingle) - , P.try $ LexemePairOpen <$> P.some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen) - , P.try $ LexemePairClose <$> P.some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose) + [ P.try $ LexemeWhite <$> p_Cell p_Spaces1 + , P.try $ LexemePairAny <$> p_some (p_Cell $ p_satisfyMaybe pairAny) + , P.try $ LexemePairBoth <$> p_some (P.try $ p_Cell p_ElemSingle) + , P.try $ LexemePairOpen <$> p_some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen) + , P.try $ LexemePairClose <$> p_some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose) , P.try $ LexemeEscape <$> p_Cell p_Escape , P.try $ LexemeLink <$> p_Cell p_Link - , P.try $ LexemeAlphaNum <$> p_Cell (P.some p_AlphaNum) - , LexemeAny <$> p_Cell (pure <$> P.anyChar) + , P.try $ LexemeAlphaNum <$> p_Cell (P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum) + , LexemeOther <$> p_Cell (TL.singleton <$> P.anyChar) ] -p_Cell :: Parser e s a -> Parser e s (Cell a) -p_Cell pa = do - bp <- p_Position - a <- pa - ep <- p_Position - return $ Cell bp ep a - pairAny :: Char -> Maybe Pair pairAny = \case '-' -> Just PairDash @@ -319,133 +358,94 @@ pairClose = \case '»' -> Just PairFrenchquote _ -> Nothing -p_AlphaNum :: Parser e s Char -p_AlphaNum = P.satisfy Char.isAlphaNum - p_Escape :: Parser e s Char p_Escape = P.char '\\' *> P.satisfy Char.isPrint -p_Link :: Parser e s Text +p_Link :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_Link = P.try (P.char '<' *> p <* P.char '>') <|> p where + p :: P.Tokens s ~ TL.Text => Parser e s TL.Text p = - (\scheme addr -> Text.pack $ scheme <> "//" <> addr) + (\scheme addr -> scheme <> "//" <> addr) <$> P.option "" (P.try p_scheme) <* P.string "//" <*> p_addr + p_scheme :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_scheme = (<> ":") - <$> P.some (P.satisfy $ \c -> + <$> (P.takeWhile1P (Just "scheme") $ \c -> Char.isAlphaNum c || c=='_' || c=='-' || c=='+') <* P.char ':' + p_addr :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_addr = - P.many $ - P.satisfy $ \c -> - Char.isAlphaNum c - || c=='%' - || c=='/' - || c=='(' - || c==')' - || c=='-' - || c=='_' - || c=='.' - || c=='#' - || c=='?' - || c=='=' - -p_ElemSingle :: Parser e s Pair -p_ElemSingle = pdbg "ElemSingle" $ - PairElem - <$ P.char '<' - <*> p_Word - <*> p_Attrs - <* P.string "/>" - -p_ElemOpen :: Parser e s Pair -p_ElemOpen = pdbg "ElemOpen" $ - PairElem - <$ P.char '<' - <*> p_Word - <*> p_Attrs - <* P.char '>' - -p_ElemClose :: Parser e s Pair -p_ElemClose = pdbg "ElemClose" $ - (`PairElem` []) - <$ P.string " p_Word - <* P.char '>' - -{- -p_ElemOpenOrSingle :: Parser e s Pair -p_ElemOpenOrSingle = - p_ElemOpen >>= \p -> - P.char '>' $> LexemePairOpen p <|> - P.string "/>" $> LexemePairAny p --} - - - - - - - - + P.takeWhileP (Just "addr") $ \c -> + Char.isAlphaNum c + || c=='%' + || c=='/' + || c=='(' + || c==')' + || c=='-' + || c=='_' + || c=='.' + || c=='#' + || c=='?' + || c=='=' -- | Build 'Tokens' from many 'Token's. -tokens :: [Token] -> Tokens -tokens = Seq.fromList +tokens :: [Cell Token] -> Tokens +tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts -- | Build 'Tokens' from one 'Token'. -tokens1 :: Token -> Tokens +tokens1 :: Tree (Cell Node) -> Tokens tokens1 = Seq.singleton -tokensPlainEmpty :: Tokens -tokensPlainEmpty = tokens1 $ Tree0 $ cell1 $ TokenPlain "" - -isTokenWhite :: Token -> Bool -isTokenWhite (Tree0 (unCell -> TokenPlain t)) = Text.all Char.isSpace t -isTokenWhite _ = False - -unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens)) +unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens)) unTokenElem toks = - case toList $ Seq.dropWhileR isTokenWhite toks of - [TreeN (Cell bp ep (PairElem e as)) ts] -> Just (Cell bp ep (e,as,ts)) + case toList $ {-Seq.dropWhileR isTokenWhite-} toks of + [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts)) _ -> Nothing isTokenElem :: Tokens -> Bool isTokenElem toks = - case toList $ Seq.dropWhileR isTokenWhite toks of - [TreeN (unCell -> PairElem{}) _] -> True + case toList $ {-Seq.dropWhileR isTokenWhite-} toks of + [Tree (unCell -> NodePair PairElem{}) _] -> True _ -> False -pairBorders :: TokenKey -> Tokens -> (Text,Text) -pairBorders p ts = - case p of - PairElem e attrs -> - if Seq.null ts - then ("<"<>e<>foldMap f attrs<>"/>","") - else ("<"<>e<>foldMap f attrs<>">","e<>">") - where f (attr_white,Attr{..}) = - attr_white <> - attr_name <> - attr_open <> - attr_value <> - attr_close - PairHash -> ("#","#") - PairStar -> ("*","*") - PairSlash -> ("/","/") - PairUnderscore -> ("_","_") - PairDash -> ("-","-") - PairBackquote -> ("`","`") - PairSinglequote -> ("'","'") - PairDoublequote -> ("\"","\"") - PairFrenchquote -> ("«","»") - PairParen -> ("(",")") - PairBrace -> ("{","}") - PairBracket -> ("[","]") +pairBordersWithoutContent :: Pair -> (TL.Text,TL.Text) +pairBordersWithoutContent = \case + PairElem n as -> + ("<"<>n<>foldMap f as<>"/>","") + where f (elemAttr_white,ElemAttr{..}) = + elemAttr_white <> + elemAttr_name <> + elemAttr_open <> + elemAttr_value <> + elemAttr_close + p -> pairBorders p + +pairBorders :: Pair -> (TL.Text,TL.Text) +pairBorders = \case + PairElem n as -> ("<"<>n<>foldMap f as<>">","n<>">") + where f (elemAttr_white,ElemAttr{..}) = + elemAttr_white <> + elemAttr_name <> + elemAttr_open <> + elemAttr_value <> + elemAttr_close + PairHash -> ("#","#") + PairStar -> ("*","*") + PairSlash -> ("/","/") + PairUnderscore -> ("_","_") + PairDash -> ("-","-") + PairBackquote -> ("`","`") + PairSinglequote -> ("'","'") + PairDoublequote -> ("\"","\"") + PairFrenchquote -> ("«","»") + PairParen -> ("(",")") + PairBrace -> ("{","}") + PairBracket -> ("[","]") diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index d2d536c..9763e2b 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -7,186 +7,183 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Read.Tree where +-- import Data.String (IsString(..)) +-- import qualified Data.TreeSeq.Strict as TreeSeq import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..), void) import Data.Bool import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>), ($>), (<$)) +import Data.Foldable (toList) +import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(..)) -import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..), Trees) -import Prelude (undefined, Num(..)) -import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Sequence as Seq -import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import Language.TCT.Cell +-- import Language.TCT.Token import Language.TCT.Tree import Language.TCT.Read.Cell import Language.TCT.Read.Elem import Language.TCT.Read.Token -p_CellKey :: Row -> Parser e s Row -p_CellKey row = pdbg "CellKey" $ do +p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row +p_CellHeader row = pdbg "CellHeader" $ do P.skipMany $ P.char ' ' pos <- p_Position - key <- pdbg "Key" $ + header <- pdbg "Header" $ P.choice $ [ P.try $ P.char '-' >> - P.char ' ' $> KeyDash <|> - P.string "- " $> KeyDashDash - , P.try $ KeyDot . Text.pack - <$> P.some (P.satisfy Char.isDigit) + P.char ' ' $> HeaderDash <|> + P.string "- " $> HeaderDashDash + , P.try $ HeaderDot + <$> p_Digits <* P.char '.' <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' ')) , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs -> - return $ KeySection $ List.length hs + return $ HeaderSection $ List.length hs , P.try $ - KeyBrackets + HeaderBrackets <$> P.between (P.string "[") (P.string "]") p_Name <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n'))) , P.try $ - (\f -> KeyDotSlash $ "./"<>f) + (\f -> HeaderDotSlash $ "./"<>f) <$ P.string "./" <*> P.many (P.satisfy (/='\n')) , do name <- p_Name - wh <- Text.pack <$> P.many (P.char ' ') + wh <- p_HSpaces P.choice - [ P.try $ KeyColon name wh + [ P.try $ HeaderColon name wh <$ P.char ':' <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' ')) - , P.char '>' $> KeyGreat name wh - , P.char '=' $> KeyEqual name wh - , P.char '|' $> KeyBar name wh + , P.char '>' $> HeaderGreat name wh + , P.char '=' $> HeaderEqual name wh + , P.char '|' $> HeaderBar name wh ] ] posEnd <- p_Position - let row' = TreeN (Cell pos posEnd key) mempty : row - case key of - KeySection{} -> p_CellEnd row' - KeyDash{} -> p_Row row' - KeyDashDash{} -> p_CellText row' - KeyDot{} -> p_Row row' - KeyColon{} -> p_Row row' - KeyBrackets{} -> p_Row row' - KeyGreat{} -> p_Row row' - KeyEqual{} -> p_CellEnd row' - KeyBar{} -> p_CellEnd row' - KeyDotSlash{} -> p_CellEnd row' - KeyLower{} -> undefined -- NOTE: handled in 'p_CellLower' + let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row + case header of + HeaderSection{} -> p_CellEnd row' + HeaderDash{} -> p_Row row' + HeaderDashDash{} -> p_CellText row' + HeaderDot{} -> p_Row row' + HeaderColon{} -> p_Row row' + HeaderBrackets{} -> p_Row row' + HeaderGreat{} -> p_Row row' + HeaderEqual{} -> p_CellEnd row' + HeaderBar{} -> p_CellEnd row' + HeaderDotSlash{} -> p_CellEnd row' + -- HeaderLower{} -> undefined -- NOTE: handled in 'p_CellLower' + -- TODO: move to a NodeLower + -- HeaderPara -> undefined -- NOTE: only introduced later in 'appendRow' -p_Name :: Parser e s Name -p_Name = +p_Name :: P.Tokens s ~ TL.Text => Parser e s Name +p_Name = p_AlphaNums + {- (\h t -> Text.pack (h:t)) - <$> (P.satisfy $ \c -> - Char.isAlphaNum c || c=='_') - <*> many (P.satisfy $ \c -> - Char.isAlphaNum c || c=='-' || c=='_') + <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_') + <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_') + -} -p_Line :: Parser e s Text -p_Line = Text.pack <$> P.many (P.satisfy (/='\n')) +p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_Line = P.takeWhileP (Just "Line") (/='\n') -p_CellLower :: forall e s. Row -> Parser e s Row +p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_Line1 = P.takeWhile1P (Just "Line") (/='\n') + +p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellLower row = pdbg "CellLower" $ do - P.skipMany $ P.char ' ' - pos <- p_Position - void $ P.char '<' - name <- p_Name - attrs <- p_attrs + indent <- p_HSpaces + pos <- p_Position + void $ P.char '<' + name <- p_Name + attrs <- p_ElemAttrs posClose <- p_Position let treeHere = - TreeN (Cell pos posClose $ KeyLower name attrs) . - Seq.singleton . Tree0 - let treeElem toks (Cell _ p c) = - let (o,_) = pairBorders (PairElem name attrs) toks in - Tree0 $ Cell pos p (o<>c) - let indent = fromString $ List.replicate (columnPos pos - 1) ' ' + Tree (Cell pos posClose $ NodeLower name attrs) . + Seq.singleton . Tree0 . (NodeText <$>) + let treeElem hasContent nod (Cell _ p t) = + let (o,_) = bs $ PairElem name attrs in + Tree0 $ Cell pos p $ nod $ o<>t + where + bs | hasContent = pairBorders + | otherwise = pairBordersWithoutContent tree <- - P.try (P.char '>' >> treeElem (tokens [Tree0 $ cell0 $ TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|> - P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|> - P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|> + P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|> + P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|> + P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|> (P.eof $> treeHere (Cell posClose posClose "")) - return (tree:row) + return $ tree : row where - p_attrs = P.many $ P.try $ - (,) - <$> (Text.pack <$> P.some (P.char ' ')) - <*> p_Attr - p_CellLine :: Parser e s (Cell Text) - p_CellLine = do - pos <- p_Position - content <- p_Line - posEnd <- p_Position - return $ Cell pos posEnd content - p_CellLines :: P.Tokens s -> Parser e s (Cell Text) - p_CellLines indent = do - pos <- p_Position - content <- - Text.intercalate "\n" - <$> P.sepBy (P.try p_Line) (P.try $ P.char '\n' >> P.string indent) - posEnd <- p_Position - return $ Cell pos posEnd content - p_CellLinesUntilElemEnd :: P.Tokens s -> Text -> Parser e s (Cell Text) - p_CellLinesUntilElemEnd indent name = do - pos <- p_Position - content <- Text.intercalate "\n" . List.reverse <$> go [] - posEnd <- p_Position - return $ Cell pos posEnd content + p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text) + p_CellLine = p_Cell p_Line + p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text) + p_CellLines indent = + -- TODO: optimize special case indent == "" ? + p_Cell $ + TL.intercalate "\n" + <$> P.sepBy (P.try p_Line) + (P.try $ P.char '\n' >> P.tokens (==) indent) + p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text) + p_CellLinesUntilElemEnd indent name = + p_Cell $ TL.intercalate "\n" . List.reverse <$> go [] + -- TODO: optimize merging, and maybe case indent == "" where - go :: [Text] -> Parser e s [Text] + go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text] go ls = - P.try ((\w l -> Text.pack w <> " name <> l : ls) - <$> P.many (P.char ' ') - <* P.string (fromString $ "Text.unpack name) + let end = " name in + P.try ((\w l -> w <> end <> l : ls) + <$> p_HSpaces + <* P.tokens (==) end <*> p_Line) <|> (p_Line >>= \l -> P.try $ - P.char '\n' >> - P.string indent >> - go (l:ls)) + P.char '\n' + >> P.tokens (==) indent + >> go (l:ls)) -p_CellText :: Row -> Parser e s Row +p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellText row = pdbg "CellText" $ do P.skipMany $ P.char ' ' - pos <- p_Position - line <- Text.pack <$> P.some (P.satisfy (/='\n')) - posEnd <- p_Position - return $ Tree0 (Cell pos posEnd line) : row + n <- p_Cell $ NodeText <$> p_Line1 + return $ Tree0 n : row p_CellSpaces :: Row -> Parser e s Row p_CellSpaces row = pdbg "CellSpaces" $ do P.skipSome $ P.char ' ' pos <- p_Position - return $ Tree0 (Cell pos pos "") : row + return $ Tree0 (Cell pos pos $ NodeText "") : row -p_CellEnd :: Row -> Parser e s Row -p_CellEnd row = pdbg "Row" $ +p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row +p_CellEnd row = pdbg "CellEnd" $ P.try (p_CellLower row) <|> P.try (p_CellText row) <|> p_CellSpaces row <|> return row -p_Row :: Row -> Parser e s Row +p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_Row row = pdbg "Row" $ - P.try (p_CellKey row) <|> + P.try (p_CellHeader row) <|> p_CellEnd row -p_Rows :: Rows -> Parser e s Rows +p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows p_Rows rows = p_Row [] >>= \row -> let rows' = appendRow rows (List.reverse row) in (P.eof $> rows') <|> - (P.newline >> p_Rows rows') + (P.newline >> P.eof $> rows' <|> p_Rows rows') -p_Trees :: Parser e s (Trees (Cell Key) (Cell Value)) -p_Trees = unRoot . collapseRows <$> p_Rows [root] +p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node)) +p_Trees = unNodePara . subTrees . collapseRows <$> p_Rows [root] where - root = TreeN (cell0 KeyDashDash) mempty - unRoot (TreeN (unCell -> KeyDashDash) roots) = roots - unRoot _ = undefined + root = Tree (cell0 $ NodeHeader HeaderDashDash) mempty + unNodePara :: Trees (Cell Node) -> Trees (Cell Node) + unNodePara (toList -> [(Tree (unCell -> NodePara) ts)]) = ts + unNodePara ts = ts diff --git a/Language/TCT/Token.hs b/Language/TCT/Token.hs index 315b8a5..a5ba2df 100644 --- a/Language/TCT/Token.hs +++ b/Language/TCT/Token.hs @@ -3,30 +3,126 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Token where -{- -import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) -import Data.Function (($), (.)) -import Data.Foldable (foldMap, foldr) -import Data.Maybe (Maybe(..)) -import Data.Semigroup (Semigroup(..)) +import Data.Int (Int) +import Data.Ord (Ord(..)) import Data.Sequence (Seq) -import Data.Ord (Ord) import Data.Text (Text) -import Data.Text.Buildable (Buildable(..)) -import Data.Text.Lazy.Builder (Builder) -import Data.TreeSeq.Strict (Tree(..), Trees) -import GHC.Exts (IsList(..)) +-- import Data.TreeSeq.Strict (Tree(..)) import Text.Show (Show(..)) -import qualified Data.Char as Char -import qualified Data.Sequence as Seq -import qualified Data.Text as Text +import System.FilePath (FilePath) +import qualified Data.Text.Lazy as TL import Language.TCT.Cell import Language.TCT.Elem + + + + +{- +-- * Type 'TCT' +type TCT = Tree (Padded Key) Tokens + +-- * Type 'Key' +data Key + = KeyColon !Name !White -- ^ @name: @ + | KeyEqual !Name !White -- ^ @name=@ + | KeyBar !Name !White -- ^ @name|@ + | KeyGreat !Name !White -- ^ @name>@ + | KeyLower !Name !ElemAttrs -- ^ @value@ + | PairHash -- ^ @#value#@ + | PairStar -- ^ @*value*@ + | PairSlash -- ^ @/value/@ + | PairUnderscore -- ^ @_value_@ + | PairDash -- ^ @-value-@ + | PairBackquote -- ^ @`value`@ + | PairSinglequote -- ^ @'value'@ + | PairDoublequote -- ^ @"value"@ + | PairFrenchquote -- ^ @«value»@ + | PairParen -- ^ @(value)@ + | PairBrace -- ^ @{value}@ + | PairBracket -- ^ @[value]@ + deriving (Eq,Ord,Show) + +-- ** Type 'TokenValue' +data TokenValue + = TokenPhrases !Phrases + | TokenEscape !Char + | TokenTag !Tag + | TokenLink !Link + | TokenTree !TCT + | TokenRaw !TL.Text + deriving (Eq,Show) + +-- * Type 'Phrases' +type Phrases = Seq (Padded Phrase) + +-- ** Type 'Phrase' +data Phrase + = PhraseWord !Text + | PhraseWhite !Text + | PhraseOther !Text + deriving (Eq,Ord,Show) + +-- * Type 'Tag' +type Tag = TL.Text +-- newtype Tag = Tag Text + +type family Sourced a :: * +type instance Sourced (Padded a) = Padded (Sourced a) +type instance Sourced [a] = [Sourced a] +type instance Sourced (Seq a) = Seq (Sourced a) +type instance Sourced (Tree k a) = Tree (Sourced k) (Sourced a) +type instance Sourced Key = Cell Key +type instance Sourced Value = Cell Value +type instance Sourced TokenKey = Cell TokenKey +type instance Sourced TokenValue = TokenValue +type instance Sourced Phrase = Cell Phrase + +-- * Type Pos +class Sourcify a where + sourcify :: a -> Sourced a +instance Sourced a => Sourced [a] where + type Sourced = [At a] + sourcify = (sourcify <$>) +-} + +{- instance Buildable Token where build (TokenPlain t) = build t build (TokenTag t) = "#"<>build t @@ -56,5 +152,3 @@ instance IsList Tokens where unTokens :: Tokens -> Seq Token unTokens (Tokens ts) = ts -} - - diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index 1678a4b..f2eb4ec 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -1,33 +1,111 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE NoOverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -module Language.TCT.Tree - ( module Language.TCT.Tree - , Tree(..) - , Trees - ) where +module Language.TCT.Tree where import Control.Monad (Monad(..)) +import Data.Bool +import Data.Char (Char) import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) import Data.Function (($)) +import Data.Int (Int) import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) import Data.Ord (Ordering(..), Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence ((|>)) -import Data.Text (Text) +import Data.Sequence ((|>), (<|), ViewR(..)) import Data.TreeSeq.Strict (Tree(..), Trees) -import Prelude (undefined, Int, Num(..)) +import Prelude (undefined, Num(..)) +import System.FilePath (FilePath) import Text.Show (Show(..)) import qualified Data.List as List -import qualified Data.Text as Text -import qualified System.FilePath as FP import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL import Language.TCT.Cell import Language.TCT.Elem -import Language.TCT.Read.Token -- import Language.TCT.Token +-- ** Type 'TCT' +type Root = Tree Node +type Roots = Trees Node + +pattern Tree0 :: a -> Tree a +pattern Tree0 a <- Tree a (null -> True) + where Tree0 a = Tree a mempty + +-- ** Type 'Node' +data Node + = NodeHeader !Header + | NodePair !Pair + | NodeToken !Token + | NodeText !TL.Text + | NodeLower !Name !ElemAttrs -- ^ @@ + | HeaderDot !Name -- ^ @1. @ + | HeaderDash -- ^ @- @ + | HeaderDashDash -- ^ @-- @ + | HeaderSection !LevelSection -- ^ @# @ + | HeaderBrackets !Name -- ^ @[name]@ + | HeaderDotSlash !FilePath -- ^ @./file @ + deriving (Eq, Ord, Show) + +-- *** Type 'Name' +type Name = TL.Text + +-- *** Type 'LevelSection' +type LevelSection = Int + +-- ** Type 'Pair' +data Pair + = PairElem !ElemName !ElemAttrs -- ^ @value@ + | PairHash -- ^ @#value#@ + | PairStar -- ^ @*value*@ + | PairSlash -- ^ @/value/@ + | PairUnderscore -- ^ @_value_@ + | PairDash -- ^ @-value-@ + | PairBackquote -- ^ @`value`@ + | PairSinglequote -- ^ @'value'@ + | PairDoublequote -- ^ @"value"@ + | PairFrenchquote -- ^ @«value»@ + | PairParen -- ^ @(value)@ + | PairBrace -- ^ @{value}@ + | PairBracket -- ^ @[value]@ + deriving (Eq,Ord,Show) + +-- ** Type 'Token' +data Token + = TokenText !TL.Text + | TokenEscape !Char + | TokenLink !Link + | TokenTag !Tag + deriving (Eq,Show) + +-- *** Type 'Tag' +type Tag = TL.Text + +-- *** Type 'Link' +type Link = TL.Text + +-- * Type 'Row' +-- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line. +type Row = [Tree (Cell Node)] + +-- ** Type 'Rows' +-- | In reverse order: a list of nodes in scope +-- (hence to which the next line can append to). +type Rows = [Tree (Cell Node)] -- | @appendRow rows row@ appends @row@ to @rows@. -- @@ -35,149 +113,109 @@ import Language.TCT.Read.Token -- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending) appendRow :: Rows -> Row -> Rows appendRow [] row = List.reverse row -appendRow parents [] = parents -appendRow rows@(parent:parents) row@(cell:cells) = - trac ("appendRow: rows=" <> show rows) $ - trac ("appendRow: row=" <> show row) $ +appendRow rows [] = rows +appendRow rows@(old@(Tree (Cell bo eo o) os):olds) + row@(new@(Tree (Cell bn en n) ns):news) = + debug "appendRow" "row" row $ + debug "appendRow" "rows" rows $ dbg "appendRow" $ - let colParent = columnPos $ posTree parent in - let colRow = columnPos $ posTree cell in - case dbg "colParent" colParent `compare` - dbg "colRow" colRow of - LT -> - case (dbg "parent" parent,dbg "cell" cell) of - (Tree0{}, TreeN{}) -> eq - -- (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful? - -- (TreeN (unCell -> KeyPara) p, Tree0 r) -> appendTree0 p r - -- (Tree0 p, Tree0 r) -> appendTree0 p r - _ | Just x <- appendPara -> x - _ -> lt + case dbg "colOld" (pos_column bo) `compare` + dbg "colNew" (pos_column bn) of + LT -> mergeNodeText lt EQ -> - case (dbg "parent" parent,dbg "cell" cell) of - _ | Just x <- appendPara -> x - (_, TreeN (unCell -> KeySection sectionRow) _) - | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows -> - case dbg "sectionParent" sectionParent `compare` - dbg "sectionRow" sectionRow of - LT -> appendRow (cell:secPar:secPars) cells - EQ -> appendRow (cell:insertChild secPar secPars) cells + mergeNodeText $ + case (o,n) of + (_, NodeHeader (HeaderSection secNew)) + | Just (secOld, s0:ss) <- collapseSection (pos_column bn) rows -> + case dbg "secOld" secOld `compare` + dbg "secNew" secNew of + LT -> appendRow (new:s0:ss) news + EQ -> appendRow (new:appendChild ss s0) news GT -> gt - (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt - (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt - (Tree0{}, TreeN{}) -> eq - (TreeN{}, TreeN{}) -> eq - (TreeN{}, Tree0{}) -> eq + (NodeHeader HeaderSection{}, _) -> lt + (_, NodeText tn) | TL.null tn -> gt + (NodePara, _) | not newPara -> lt + _ | newPara -> gt + _ -> eq GT -> gt where - appendPara :: Maybe Rows - appendPara = - case (parent, cell) of - ( TreeN (Cell posPar posEndPar KeyPara) pars - , Tree0 (Cell posRow posEndRow _c) ) -> - Just $ - if linePos posRow - linePos posEndPar <= 1 - then appendRow (merged : parents) cells - else appendRow (cell : insertChild parent parents) cells - where merged = TreeN (Cell posPar posEndRow KeyPara) $ pars |> cell - ( Tree0 (Cell posPar posEndPar _p) - , Tree0 (Cell posRow posEndRow _c) ) -> - Just $ - if linePos posRow - linePos posEndPar <= 1 - then appendRow (merged : parents) cells - else appendRow (cell : insertChild parent parents) cells - where merged = TreeN (Cell posPar posEndRow KeyPara) [parent, cell] - _ -> Nothing + newPara = pos_line bn - pos_line eo > 1 + lt = debug "appendRow" "action" ("lt"::TL.Text) $ List.reverse row <> rows + eq = debug "appendRow" "action" ("eq"::TL.Text) $ appendRow (new : appendChild olds old) news + gt = debug "appendRow" "action" ("gt"::TL.Text) $ appendRow ( appendChild olds old) row - {- - appendTree0 p r = - case appendCellValue p r of - Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells - Just t -> appendRow (t : parents) cells - -} - lt = appendRow [] row <> rows - eq = appendRow (cell : insertChild parent parents) cells - gt = appendRow (insertChild parent parents) row -- | Find the first section (if any), returning its level, and the path collapsed upto it. - collapseSection :: Column -> Rows -> Maybe (Int,Rows) - collapseSection col xxs@(x:xs) | columnPos (posTree x) == col = + collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows) + collapseSection col xxs@(x:xs) | pos_column (cell_begin (unTree x)) == col = case x of - TreeN (unCell -> KeySection lvl) _ -> Just (lvl, xxs) + Tree (unCell -> NodeHeader (HeaderSection lvl)) _ -> Just (lvl, xxs) _ -> do (lvl, cs) <- collapseSection col xs - return (lvl, insertChild x cs) + return (lvl, appendChild cs x) collapseSection _ _ = Nothing + + mergeNodeText :: Rows -> Rows + mergeNodeText rs + | newPara = rs + | otherwise = + case (o,n) of + (NodeText to, NodeText tn) + | null os + , not (TL.null to) + , not (TL.null tn) -> + -- debug "appendRow" "action" ("mergeNodeText"::TL.Text) $ + dbg "mergeNodeText" $ + appendRow (merged : olds) news + where + merged = Tree (Cell bo en $ NodeText $ to<>tp<>tn) ns + tp = fromPad Pos + { pos_line = pos_line bn - pos_line eo + , pos_column = pos_column bn - pos_column bo + } + _ -> rs -{- -appendCellValue :: Cell Value -> Cell Value -> Tree (Cell Key) (Cell Value) -appendCellValue par@(Cell posPar posEndPar p) row@(Cell posRow posEndRow r) = - trac ("appendCellValue: p="<>show p) $ - trac ("appendCellValue: r="<>show r) $ - dbg "appendCellValue" $ - case linePos posRow - linePos posEndPar of - 0 -> - TreeN (Cell posPar posEndRow KeyPara) - [ Tree0 par - , Tree0 row - ] - 1 -> - TreeN (Cell posPar posEndRow KeyPara) - [ Tree0 par - , Tree0 row - ] - _ -> [] - where - padding x y = Text.replicate (y - x) " " - {- - where - pad = - -- return $ LexemeWhite $ Cell posEndPar posRow $ - -- padding (columnPos posEndPar) (columnPos posRow) - -} - {- - -- return $ Cell posPar posEndRow $ p <> pad <> r - -- return $ Cell posPar posEndRow $ p <> pad <> r - where - pad = - -- return $ LexemeWhite $ Cell posEndPar posRow $ - -- "\n" <> - padding (columnPos posPar) (columnPos posRow) - -} --} - -insertChild :: Tree (Cell Key) (Cell Value) -> Rows -> Rows -insertChild child ps@[] = - trac ("insertChild: child="<>show child) $ - trac ("insertChild: ps="<>show ps) $ - dbg "insertChild" $ - [child] -insertChild c@(Tree0 (Cell _bp ep _)) - (p@(Tree0 (Cell bp _ep _)):parents) = - TreeN (Cell bp ep KeyPara) [p, c] : parents -insertChild (TreeN (Cell _bp ep _) cs) - (p@(Tree0 (Cell bp _ep _)):parents) = - TreeN (Cell bp ep KeyPara) (p Seq.<| cs) : parents - {- - undefined - -- FIXME: this case may be removed. - case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of - LT -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents - EQ -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents - GT -> undefined - -} -insertChild child ps@(TreeN parent treesParent:parents) = - trac ("insertChild: child="<>show child) $ - trac ("insertChild: ps="<>show ps) $ - dbg "insertChild" $ - -- FIXME: this case may be removed. - case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of - LT -> TreeN parent (treesParent |> child) : parents - EQ -> TreeN parent (treesParent |> child) : parents - GT -> undefined - -collapseRows :: Rows -> Tree (Cell Key) (Cell Value) -collapseRows [] = undefined -collapseRows [child] = dbg "collapseRows" $ child -collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents - - +appendChild :: Rows -> Tree (Cell Node) -> Rows +appendChild rows new@(Tree (Cell bn en n) ns) = + debug "appendChild" "new" new $ + debug "appendChild" "rows" rows $ + dbg "appendChild" $ + case rows of + [] -> [new] + old@(Tree (Cell bo eo o) os) : olds -> + (: olds) $ + if newPara + then + case (o,n) of + (NodePara,NodePara) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] + (NodePara,_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,Tree (Cell bn en NodePara) $ return new] + (_,NodePara) -> Tree (Cell bo en o) $ os|>new + (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] + _ -> Tree (Cell bo en o) $ os|>Tree (Cell bn en NodePara) (return new) + else + case (o,n) of + (NodePara,NodePara) -> Tree (Cell bo en NodePara) $ os<>ns + (NodePara,_) -> Tree (Cell bo en NodePara) $ os|>new + (_,NodePara) -> Tree (Cell bo en NodePara) $ old<|ns + (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] + _ -> + case Seq.viewr os of + EmptyR -> + Tree (Cell bo en o) $ + os |> Tree (Cell bn en NodePara) (return new) + ls :> Tree (Cell br _er r) rs -> + case r of + NodePara -> + if pos_column br == pos_column bn + then Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new) + else Tree (Cell bo en o) $ os |> Tree (Cell bn en NodePara) (return new) + _ -> Tree (Cell bo en o) $ os |> new + where newPara = pos_line bn - pos_line eo > 1 +collapseRows :: Rows -> Tree (Cell Node) +collapseRows rs = + debug "collapseRows" "rs" rs $ + dbg "collapseRows" $ + case rs of + [] -> undefined + [child] -> child + child:parents -> collapseRows $ appendChild parents child diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index cb05e90..0b4a3f5 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Write.HTML5 where +import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), forM_, mapM_, when) import Data.Bool import Data.Char (Char) @@ -37,6 +38,27 @@ import Text.Blaze.Utils import Language.TCT import qualified Language.TCT.Write.Plain as Plain +html5Document :: TCTs -> Html +html5Document body = do + H.docType + H.html $ do + H.head $ do + H.meta ! HA.httpEquiv "Content-Type" + ! HA.content "text/html; charset=UTF-8" + whenJust (tokensTitle body) $ \ts -> + H.title $ + H.toMarkup $ Plain.text def $ List.head $ toList ts + -- link ! rel "Chapter" ! title "SomeTitle"> + H.link ! HA.rel "stylesheet" + ! HA.type_ "text/css" + ! HA.href "style/tct-html5.css" + let (html5Body, State{}) = + runStateMarkup def $ + html5ify body + H.body $ do + H.a ! HA.id ("line-1") $ return () + html5Body + -- * Type 'Html5' type Html5 = StateMarkup State () @@ -67,26 +89,6 @@ instance Html5ify TL.Text where html5ify = html5ify . H.toMarkup instance Html5ify String where html5ify = html5ify . H.toMarkup -html5Document :: TCTs -> Html -html5Document body = do - H.docType - H.html $ do - H.head $ do - H.meta ! HA.httpEquiv "Content-Type" - ! HA.content "text/html; charset=UTF-8" - whenJust (tokensTitle body) $ \ts -> - H.title $ - H.toMarkup $ Plain.text def $ List.head $ toList ts - -- link ! rel "Chapter" ! title "SomeTitle"> - H.link ! HA.rel "stylesheet" - ! HA.type_ "text/css" - ! HA.href "style/tct-html5.css" - let (html5Body, State{}) = - runStateMarkup def $ - html5ify body - H.body $ do - H.a ! HA.id ("line-1") $ return () - html5Body instance Html5ify (Trees (Cell Key) Tokens) where html5ify = mapM_ html5ify instance Html5ify (Tree (Cell Key) Tokens) where @@ -184,12 +186,12 @@ instance Html5ify Token where H.span ! HA.class_ "elem-name" $$ html5ify name lenName = Text.length name - lenAttrs = sum $ (<$> attrs) $ \(attr_white,Attr{..}) -> - Text.length attr_white + - Text.length attr_name + - Text.length attr_open + - Text.length attr_value + - Text.length attr_close + lenAttrs = sum $ (<$> attrs) $ \(elemAttr_white,ElemAttr{..}) -> + Text.length elemAttr_white + + Text.length elemAttr_name + + Text.length elemAttr_open + + Text.length elemAttr_value + + Text.length elemAttr_close (lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0) | otherwise = (1+lenName+lenAttrs+1,2+lenName+1) o,c :: Html5 @@ -207,10 +209,11 @@ instance Html5ify Token where H.span ! HA.class_ "pair-content" $$ html5ify ts html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep () H.span ! HA.class_ "pair-close" $$ html5ify c - html5ify (Tree0 (Cell bp ep t)) = do - html5ify $ Cell bp ep () - case t of - TokenPlain txt -> html5ify txt + html5ify (Tree0 tok) = do + -- html5ify $ Cell bp ep () + case tok of + TokenPhrases ps -> html5ify ps + TokenRaw t -> html5ify t {-do lin <- S.get let lines = Text.splitOn "\n" txt @@ -230,21 +233,30 @@ instance Html5ify Token where H.span ! HA.class_ "tag-open" $$ html5ify '#' html5ify v - TokenEscape c -> html5ify ['\\',c] - TokenLink lnk -> + TokenEscape c -> html5ify $ ('\\' :) . pure <$> c + TokenLink (Cell bp ep lnk) -> do + html5ify $ Cell bp ep () H.a ! HA.href (attrify lnk) $$ html5ify lnk -instance Html5ify Attrs where +instance Html5ify Phrases where + html5ify = mapM_ html5ify +instance Html5ify Phrase where + html5ify p = + case p of + PhraseWord t -> html5ify t + PhraseWhite t -> html5ify t + PhraseOther t -> html5ify t +instance Html5ify ElemAttrs where html5ify = mapM_ html5ify -instance Html5ify (White,Attr) where - html5ify (attr_white,Attr{..}) = do - html5ify attr_white +instance Html5ify (White,ElemAttr) where + html5ify (elemAttr_white,ElemAttr{..}) = do + html5ify elemAttr_white H.span ! HA.class_ "attr-name" $$ - html5ify attr_name - html5ify attr_open + html5ify elemAttr_name + html5ify elemAttr_open H.span ! HA.class_ "attr-value" $$ - html5ify attr_value - html5ify attr_close + html5ify elemAttr_value + html5ify elemAttr_close -- * Utilities diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 2ab35c1..fb37399 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -4,8 +4,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Write.Plain where -import Control.Applicative (liftA2) -import Control.Monad (Monad(..)) +import Control.Applicative (Applicative(..), liftA2) +import Control.Monad (Monad(..), mapM) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) @@ -14,10 +14,11 @@ import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Int (Int64) +import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..)) +import Data.Sequence (Seq, ViewL(..)) import Data.String (String, IsString(..)) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..),Trees) @@ -31,7 +32,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB -- import Language.TCT.Tree --- import Language.TCT.Token +import Language.TCT.Token import Language.TCT.Cell import Language.TCT.Elem import Language.TCT.Read.Token @@ -70,6 +71,8 @@ instance Default State where -- * Class 'Plainify' class Plainify a where plainify :: a -> Plain +instance Plainify () where + plainify = mempty instance Plainify Char where plainify = return . TLB.singleton instance Plainify String where @@ -83,14 +86,15 @@ instance Plainify a => Plainify (Cell a) where Pos lineLast colLast <- S.gets state_pos case () of _ | lineLast < line -> do - plainify $ Text.replicate (line - lineLast - 1) "\n" - plainify $ Text.replicate (col - 1) " " + S.modify $ \s -> s{state_pos=ep} + plainify (Text.replicate (line - lineLast - 1) "\n") + <> plainify (Text.replicate (col - 1) " ") + <> plainify a _ | lineLast == line && colLast <= col -> do - plainify $ Text.replicate (col - colLast) " " + S.modify $ \s -> s{state_pos=ep} + plainify (Text.replicate (col - colLast) " ") + <> plainify a _ -> undefined - -- S.modify $ \s -> s{state_pos=bp} - S.modify $ \s -> s{state_pos=ep} - plainify a instance Plainify (Trees (Cell Key) Tokens) where plainify = foldMap plainify instance Plainify (Tree (Cell Key) Tokens) where @@ -112,7 +116,7 @@ instance Plainify (Key, Trees (Cell Key) Tokens) where plainify attrs <> plainify ts KeySection lvl -> - plainify (TL.replicate (int64 lvl) "#") <> " " <> + plainify (TL.replicate (int64 lvl) "#") <> case Seq.viewl ts of Tree0 title :< ts' -> plainify title <> @@ -133,41 +137,49 @@ instance Plainify Tokens where plainify = foldMap plainify instance Plainify Token where plainify = \case - TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts)) - Tree0 ts -> plainify ts -instance Plainify (TokenKey, Tokens) where - plainify (k,ts) = + TreeN (Cell bp ep k) ts -> + plainify (Cell bp ep ()) <> plainify o <> plainify ts <> plainify c where (o,c) = pairBorders k ts -instance Plainify TokenValue where - plainify = \case - TokenPlain txt -> plainify txt - {- TODO: remove - lnum <- S.get - let lines = Text.splitOn "\n" txt - S.put (lnum - 1 + List.length lines) - return $ - case lines of - [] -> undefined - (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls) - -} - TokenTag v -> plainify '#'<>plainify v - TokenEscape c -> do - esc <- S.gets state_escape - if esc - then plainify ['\\',c] - else plainify c - TokenLink lnk -> plainify lnk -instance Plainify Attrs where + Tree0 tok -> + -- plainify (Cell bp ep ()) <> + case tok of + TokenPhrases p -> plainify p + TokenRaw t -> plainify t + {- TODO: remove + lnum <- S.get + let lines = Text.splitOn "\n" txt + S.put (lnum - 1 + List.length lines) + return $ + case lines of + [] -> undefined + (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls) + -} + TokenTag v -> plainify $ ("#"<>) <$> v + TokenEscape c -> do + esc <- S.gets state_escape + if esc + then plainify $ (('\\' :) . pure) <$> c + else plainify c + TokenLink lnk -> plainify lnk +instance Plainify Phrases where plainify = foldMap plainify -instance Plainify (Text,Attr) where - plainify (attr_white,Attr{..}) = +instance Plainify Phrase where + plainify p = + case p of + PhraseWord t -> plainify t + PhraseWhite t -> plainify t + PhraseOther t -> plainify t +instance Plainify ElemAttrs where + plainify = foldMap plainify +instance Plainify (Text,ElemAttr) where + plainify (elemAttr_white,ElemAttr{..}) = mconcat $ plainify <$> - [ attr_white - , attr_name - , attr_open - , attr_value - , attr_close + [ elemAttr_white + , elemAttr_name + , elemAttr_open + , elemAttr_value + , elemAttr_close ] {- @@ -192,6 +204,34 @@ instance Textify Token where TokenLink lnk -> plainify lnk -} +-- * Class 'RackUpLeft' +class RackUpLeft a where + rackUpLeft :: a -> S.State (Maybe Pos) a +instance RackUpLeft Pos where + rackUpLeft pos@Pos{..} = do + S.get >>= \case + Nothing -> return pos + Just (Pos l0 c0) -> + return Pos + { linePos = linePos - l0 + 1 + , columnPos = columnPos - c0 + 1 + } +instance RackUpLeft (Cell a) where + rackUpLeft (Cell bp ep a) = do + S.modify $ \case + Nothing -> Just bp + p -> p + Cell + <$> rackUpLeft bp + <*> rackUpLeft ep + <*> pure a +instance RackUpLeft a => RackUpLeft (Seq a) where + rackUpLeft = mapM rackUpLeft +instance (RackUpLeft k, RackUpLeft a) => RackUpLeft (Tree k a) where + rackUpLeft = \case + Tree0 a -> Tree0 <$> rackUpLeft a + TreeN k ts -> TreeN <$> rackUpLeft k <*> rackUpLeft ts + {- -- * Utilities plainifyIndentCell :: (Pos,Pos) -> Plain @@ -206,21 +246,6 @@ plainifyIndentCell (Pos lineLast colLast,Pos line col) | otherwise = undefined -- ** 'Tree' -treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a) -treeRackUpLeft t = go t - where - Pos l0 c0 = posTree t - rackUpLeft pos = - Pos - (linePos pos - l0 + 1) - (columnPos pos - c0 + 1) - go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a) - go (Tree0 (Cell pos posEnd c)) = - Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c - go (TreeN (Cell pos posEnd c) ts) = - TreeN - (Cell (rackUpLeft pos) (rackUpLeft posEnd) c) - (go <$> ts) treePosLastCell :: Trees (Cell k) Tokens -> diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 1c5c078..2c790ce 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -28,6 +28,7 @@ import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TL +import qualified Control.Monad.Trans.State as S import qualified Language.TCT.Write.Plain as Plain import qualified System.FilePath as FP @@ -36,6 +37,53 @@ import Language.TCT hiding (Parser) import Language.XML import qualified Data.TreeSeq.Strict as TreeSeq +import Debug.Trace (trace) +import Text.Show (show) + +xmlDocument :: TCTs -> XMLs +xmlDocument trees = + -- (`S.evalState` def) $ + case Seq.viewl trees of + TreeN (unCell -> KeySection{}) vs :< ts -> + case spanlTokens vs of + (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') -> + let vs'' = + case Seq.findIndexL + (\case + TreeN (unCell -> KeyColon "about" _) _ -> True + _ -> False) vs' of + Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs' + Just{} -> vs' in + xmlify def + { inh_titles = titles + , inh_figure = True + , inh_tree0 = List.repeat xmlPara + } vs'' <> + xmlify def ts + _ -> xmlify def trees + _ -> xmlify def trees + +{- +-- * Type 'Xmls' +type Xmls = S.State State XMLs +type Xml = S.State State XML +instance Semigroup Xmls where + (<>) = liftA2 (<>) +instance Monoid Xmls where + mempty = return mempty + mappend = (<>) + +-- * Type 'State' +data State + = State + { state_pos :: Pos + } +instance Default State where + def = State + { state_pos = pos1 + } +-} + -- * Type 'Inh' data Inh = Inh @@ -64,7 +112,7 @@ instance Xmlify TCTs where , not (null body) -> (<| go inh ts) $ TreeN (Cell bp ep "artwork") $ - maybe id (\v -> (Tree0 (Cell bp ep (XmlAttr "type" v)) <|)) (mimetype n) $ + maybe id (\v -> (Tree0 (XmlAttr (Cell bp ep ("type", v))) <|)) (mimetype n) $ body >>= xmlify inh{inh_tree0=[]} TreeN key@(unCell -> KeyColon n _) cs :< ts @@ -171,15 +219,17 @@ instance Xmlify Token where case p of PairBracket | to <- Plain.text def ts , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> - Seq.singleton $ + Seq.singleton . TreeN (cell "rref") $ xmlAttrs [cell ("to",TL.toStrict to)] - PairStar -> Seq.singleton $ TreeN (cell "b") $ xmlify inh ts - PairSlash -> Seq.singleton $ TreeN (cell "i") $ xmlify inh ts - PairBackquote -> Seq.singleton $ TreeN (cell "code") $ xmlify inh ts + PairStar -> Seq.singleton . TreeN (cell "b") $ xmlify inh ts + PairSlash -> Seq.singleton . TreeN (cell "i") $ xmlify inh ts + PairBackquote -> Seq.singleton . TreeN (cell "code") $ xmlify inh ts PairFrenchquote -> - Seq.singleton $ + Seq.singleton . TreeN (cell "q") $ + xmlify inh ts + {- case ts of (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) -> case Seq.viewr ls of @@ -194,35 +244,47 @@ instance Xmlify Token where xmlify inh $ rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r))) _ -> xmlify inh ts + -} PairHash -> - Seq.singleton $ + Seq.singleton . TreeN (cell "ref") $ xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)] PairElem name attrs -> - Seq.singleton $ + Seq.singleton . TreeN (cell $ xmlLocalName name) $ - xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> - cell (xmlLocalName attr_name,attr_value)) <$> attrs) <> + xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) -> + cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <> xmlify inh ts _ -> let (o,c) = pairBorders p ts in - Seq.singleton (Tree0 $ Cell bp bp $ XmlText o) `unionXml` + Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell bp bp o) `unionXml` xmlify inh ts `unionXml` - Seq.singleton (Tree0 $ Cell ep ep $ XmlText c) + Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell ep ep c) where cell :: a -> Cell a cell = Cell bp ep - xmlify _inh (Tree0 (Cell bp ep tok)) = + xmlify inh (Tree0 tok) = do case tok of - TokenPlain t -> Seq.singleton $ Tree0 $ cell $ XmlText t + TokenPhrases ps -> xmlify inh $ ps + TokenEscape c -> Seq.singleton $ Tree0 $ XmlPhrases $ phrasify c + TokenRaw t -> Seq.singleton $ Tree0 $ XmlText t TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)] - TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c - TokenLink lnk -> Seq.singleton $ - TreeN (cell "eref") $ - xmlAttrs [cell ("to",lnk)] + TokenLink (Cell bp ep lnk) -> + xmlify (Cell bp ep ()) <> + Seq.singleton (TreeN (cell "eref") $ xmlAttrs [cell ("to",lnk)]) where cell :: a -> Cell a cell = Cell bp ep + {- + whites :: Pos -> Pos -> Seq XmlText + whites (Pos bLine bCol) (Pos eLine eCol) = + case bLine`compate`eLine of + LT -> verts <> + EQ -> horiz bCol eCol + GT -> + -} +instance Xmlify (Cell Phrase) where + xmlify _inh t = Seq.singleton $ Tree0 $ XmlPhrases $ Seq.singleton t mimetype :: Text -> Maybe Text mimetype "hs" = Just "text/x-haskell" @@ -238,31 +300,9 @@ xmlPara = xmlPhantom "para" xmlTitle :: Pos -> XMLs -> XML xmlTitle = xmlPhantom "title" xmlName :: Pos -> XMLs -> XML -xmlName bp (toList -> [Tree0 (unCell -> XmlText t)]) = Tree0 (Cell bp bp $ XmlAttr "name" t) +xmlName bp (toList -> [Tree0 (XmlText (unCell -> t))]) = Tree0 (XmlAttr $ Cell bp bp ("name", t)) xmlName bp ts = xmlPhantom "name" bp ts -xmlDocument :: TCTs -> XMLs -xmlDocument trees = - case Seq.viewl trees of - TreeN (unCell -> KeySection{}) vs :< ts -> - case spanlTokens vs of - (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') -> - let vs'' = - case Seq.findIndexL - (\case - TreeN (unCell -> KeyColon "about" _) _ -> True - _ -> False) vs' of - Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs' - Just{} -> vs' in - xmlify def - { inh_titles = titles - , inh_figure = True - , inh_tree0 = List.repeat xmlPara - } vs'' <> - xmlify def ts - _ -> xmlify def trees - _ -> xmlify def trees - xmlAbout :: Inh -> Cell Key -> Seq (Cell (XmlName, Text)) -> @@ -287,17 +327,21 @@ xmlKey inh (Cell bp ep key) attrs ts = KeyBar n _wh -> d_key n KeyDot _n -> TreeN (cell "li") $ xmlify inh ts KeyDash -> TreeN (cell "li") $ xmlify inh ts - KeyDashDash -> Tree0 $ cell $ XmlComment $ TL.toStrict com + KeyDashDash -> Tree0 $ XmlComment $ cell $ TL.toStrict com where com :: TL.Text com = - Plain.text def $ + trace ("TS: "<>show ts) $ + trace ("RS: "<>show (S.evalState (Plain.rackUpLeft ts) Nothing)) $ + Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing + {- TreeSeq.mapAlsoNode (cell1 . unCell) (\_k -> fmap $ TreeSeq.mapAlsoNode (cell1 . unCell) (\_k' -> cell1 . unCell)) <$> ts + -} KeyLower n as -> TreeN (cell "artwork") $ xmlify inh ts KeyBrackets ident -> let inh' = inh{inh_figure = False} in @@ -319,7 +363,7 @@ xmlKey inh (Cell bp ep key) attrs ts = xmlify inh ts xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs -xmlAttrs = ((\(Cell bp ep (n,v)) -> Tree0 (Cell bp ep $ XmlAttr n v)) <$>) +xmlAttrs = (Tree0 . XmlAttr <$>) -- | Unify two 'XMLs', merging border 'XmlText's if any. unionXml :: XMLs -> XMLs -> XMLs @@ -327,9 +371,15 @@ unionXml x y = case (Seq.viewr x, Seq.viewl y) of (xs :> x0, y0 :< ys) -> case (x0,y0) of - (Tree0 (Cell bx _ex (XmlText tx)), Tree0 (Cell _by ey (XmlText ty))) -> + ( Tree0 (XmlPhrases tx) + , Tree0 (XmlPhrases ty) ) -> + xs `unionXml` + Seq.singleton (Tree0 $ XmlPhrases $ tx <> ty) `unionXml` + ys + ( Tree0 (XmlText tx) + , Tree0 (XmlText ty) ) -> xs `unionXml` - Seq.singleton (Tree0 $ Cell bx ey $ XmlText $ tx <> ty) `unionXml` + Seq.singleton (Tree0 $ XmlText $ tx <> ty) `unionXml` ys _ -> x <> y (Seq.EmptyR, _) -> y @@ -352,6 +402,7 @@ spanlItems liKey ts = let (lis, ts') = spanLIs ts in foldl' accumLIs (mempty,ts') lis where + spanLIs :: TCTs -> (TCTs, TCTs) spanLIs = Seq.spanl $ \case TreeN (unCell -> liKey -> True) _ -> True Tree0 toks -> @@ -364,22 +415,26 @@ spanlItems liKey ts = _ -> False -} _ -> False + accumLIs :: (TCTs,TCTs) -> TCT -> (TCTs,TCTs) accumLIs acc@(oks,kos) t = case t of TreeN (unCell -> liKey -> True) _ -> (oks|>t,kos) Tree0 toks -> let (ok,ko) = (`Seq.spanl` toks) $ \case - TreeN (unCell -> PairElem "li" _) _ -> True - Tree0 (unCell -> TokenPlain txt) -> Char.isSpace`Text.all`txt - _ -> False in - ( if null ok then oks else oks|>Tree0 (rmTokenPlain ok) + TreeN (unCell -> PairElem "li" _) _ -> True + -- (isTokenWhite -> True) -> True -- TODO: see if this is still useful + _ -> False in + ( if null ok then oks else oks|>Tree0 (rmTokenWhite ok) , if null ko then kos else Tree0 ko<|kos ) _ -> acc - rmTokenPlain = + {- + rmTokenWhite :: Tokens -> Tokens + rmTokenWhite = Seq.filter $ \case - (Tree0 (unCell -> TokenPlain{})) -> False + (isTokenWhite -> False) -> True _ -> True + -} spanlKeyColon :: Name -> TCTs -> (TCTs, TCTs) spanlKeyColon name = diff --git a/Language/XML.hs b/Language/XML.hs index 45be9e3..b781130 100644 --- a/Language/XML.hs +++ b/Language/XML.hs @@ -20,11 +20,12 @@ import Prelude (error, pred, succ) import Text.Show (Show(..), showsPrec, showChar, showString) import qualified Data.List as List import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL import Language.TCT.Cell -- * Type 'XML' -type XML = Tree (Cell XmlName) (Cell XmlLeaf) +type XML = Tree (Cell XmlNode) type XMLs = Seq XML -- ** Type 'XmlName' @@ -60,14 +61,16 @@ instance IsString XmlName where xmlLocalName :: Text -> XmlName xmlLocalName = XmlName "" "" --- ** Type 'XmlLeaf' -data XmlLeaf - = XmlAttr XmlName Text - | XmlComment Text - | XmlText Text +-- ** Type 'XmlNode' +data XmlNode + = XmlElem XmlName + | XmlAttr XmlName TL.Text + | XmlComment TL.Text + | XmlText TL.Text deriving (Eq,Ord,Show) -- * Type 'Rank' +-- | nth child type Rank = Int -- * Type 'Nat' @@ -118,7 +121,7 @@ newtype MayText instance Semigroup MayText where MayText "" <> y = y x <> MayText "" = x - _x <> y = y + _x <> y = y whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m () whenMayText (MayText "") _f = pure () diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index 4dc1b36..e8f1984 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -28,6 +28,7 @@ import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy as TL import qualified System.Environment as Env import qualified Text.Blaze.Renderer.Utf8 as Blaze import qualified Text.Blaze.Utils as Blaze @@ -43,10 +44,10 @@ import qualified Language.DTC.Write.XML as DTC.Write.XML import qualified Text.Blaze.DTC as Blaze.DTC import qualified Text.Blaze.HTML5 as Blaze.HTML5 -} -import qualified Language.RNC.Write as RNC +-- import qualified Language.RNC.Write as RNC import qualified Language.TCT as TCT -import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 -import qualified Language.TCT.Write.XML as TCT.Write.XML +-- import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 +-- import qualified Language.TCT.Write.XML as TCT.Write.XML import qualified Text.Megaparsec as P import Read @@ -76,12 +77,13 @@ main = do mainWithCommand :: Command -> IO () mainWithCommand (CommandTCT ArgsTCT{..}) = readFile input $ \_fp txt -> - case TCT.readTCTs input txt of + case TCT.readTrees input $ TL.fromStrict txt of Left err -> error $ P.parseErrorPretty err Right tct -> do when (trace_TCT trace) $ do hPutStrLn stderr "### TCT ###" hPrint stderr $ Tree.Pretty tct + {- when (trace_XML trace) $ do hPutStrLn stderr "### XML ###" let xml = TCT.Write.XML.xmlDocument tct @@ -90,6 +92,7 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = TctFormatHTML5 -> Blaze.renderMarkupToByteStringIO BS.putStr $ TCT.Write.HTML5.html5Document tct + -} {- mainWithCommand (CommandDTC ArgsDTC{..}) = readFile input $ \_fp txt -> -- 2.42.0 From 5e9497c05e4a19353cd0d18d212f71242de2d69a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 26 Jan 2018 06:10:09 +0100 Subject: [PATCH 11/16] Maintain Plain and HTML5 rendering of TCT. --- Data/TreeSeq/Strict.hs | 51 ----- GNUmakefile | 7 +- Language/TCT.hs | 2 - Language/TCT/Cell.hs | 212 ++----------------- Language/TCT/Debug.hs | 148 ++++++++++++++ Language/TCT/Elem.hs | 74 ------- Language/TCT/Read.hs | 69 ++----- Language/TCT/Read/Cell.hs | 10 +- Language/TCT/Read/Elem.hs | 9 +- Language/TCT/Read/Token.hs | 189 ++++++++--------- Language/TCT/Read/Tree.hs | 26 +-- Language/TCT/Token.hs | 154 -------------- Language/TCT/Tree.hs | 112 +++++----- Language/TCT/Write/HTML5.hs | 395 +++++++++++++++++++----------------- Language/TCT/Write/Plain.hs | 286 ++++++++++---------------- Language/TCT/Write/XML.hs | 381 +++++++++++++++++----------------- Text/Blaze/Utils.hs | 4 +- exe/cli/Main.hs | 19 +- hdoc.cabal | 36 ++-- style/tct-html5.css | 20 +- 20 files changed, 905 insertions(+), 1299 deletions(-) create mode 100644 Language/TCT/Debug.hs delete mode 100644 Language/TCT/Token.hs diff --git a/Data/TreeSeq/Strict.hs b/Data/TreeSeq/Strict.hs index 38a21ed..f454ec8 100644 --- a/Data/TreeSeq/Strict.hs +++ b/Data/TreeSeq/Strict.hs @@ -53,57 +53,6 @@ isTree0 (Tree _ ts) = null ts isTreeN :: Tree a -> Bool isTreeN (Tree _ ts) = not (null ts) -{- -mapWithNode :: (Maybe k -> a -> b) -> Tree k a -> Tree k b -mapWithNode = go Nothing - where - go _k f (Tree k ts) = Tree k (go (Just k) f <$> ts) - go k f (Tree0 a) = Tree0 (f k a) - -mapAlsoNode :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b -mapAlsoNode fk fv = go Nothing - where - go _k (Tree k ts) = Tree (fk k) $ go (Just k) <$> ts - go k (Tree0 a) = Tree0 (fv k a) - -traverseWithNode :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b) -traverseWithNode = go Nothing - where - go _p f (Tree k ts) = Tree k <$> traverse (go (Just k) f) ts - go p f (Tree0 a) = Tree0 <$> f p a - -foldlWithTree :: (b -> Tree k a -> b) -> b -> Tree k a -> b -foldlWithTree f b t = - case t of - Tree _k ts -> foldl' (foldlWithTree f) (f b t) ts - Tree0{} -> f b t - -bindTree :: Tree k a -> (Tree k a -> Tree l b) -> Tree l b -bindTree t f = - case t of - Tree0{} -> f t - Tree _k ks -> - case f t of - u@Tree0{} -> u - Tree l ls -> Tree l $ ls <> ((`bindTree` f) <$> ks) - -bindTrees :: Tree k a -> (Tree k a -> Trees l b) -> Trees l b -bindTrees t f = - case t of - Tree0{} -> f t - Tree _k ks -> - f t >>= \fs -> - case fs of - Tree0 b -> Seq.singleton $ Tree0 b - Tree l ls -> pure $ Tree l $ ls <> (ks >>= (`bindTrees` f)) - -joinTrees :: Trees k (Trees k a) -> Trees k a -joinTrees ts = - ts >>= \case - Tree0 s -> s - Tree k ks -> Seq.singleton $ Tree k $ joinTrees ks --} - -- * Type 'Trees' type Trees a = Seq (Tree a) diff --git a/GNUmakefile b/GNUmakefile index bdceb0b..dabdab4 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,4 +1,4 @@ -CABAL := $(shell find . -maxdepth 1 -name '*.cabal' -print -quit) +CABAL := $(shell find . -maxdepth 1 -name '*.cabal' -printf %f -quit) all: build @@ -21,6 +21,11 @@ cleaner: %/fast: % +%/debug: override STACK_BUILD_FLAGS+=--flag $(CABAL:.cabal=):debug +%/debug: override STACK_TEST_FLAGS+=--flag $(CABAL:.cabal=):debug +%/debug: % + + doc: stack $(STACK_FLAGS) haddock $(STACK_HADDOCK_FLAGS) %.html: %.md diff --git a/Language/TCT.hs b/Language/TCT.hs index 8064df9..fc9cb6c 100644 --- a/Language/TCT.hs +++ b/Language/TCT.hs @@ -1,13 +1,11 @@ module Language.TCT ( module Language.TCT.Cell , module Language.TCT.Tree - , module Language.TCT.Token , module Language.TCT.Elem , module Language.TCT.Read ) where import Language.TCT.Cell import Language.TCT.Tree -import Language.TCT.Token import Language.TCT.Elem import Language.TCT.Read diff --git a/Language/TCT/Cell.hs b/Language/TCT/Cell.hs index 0c96836..ee7e6e3 100644 --- a/Language/TCT/Cell.hs +++ b/Language/TCT/Cell.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Language.TCT.Cell where +import Control.Monad (Monad(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor (Functor) @@ -15,6 +16,8 @@ import Text.Show (Show(..), showParen, showString, showChar) import qualified Data.Text as Text import qualified Data.Text.Lazy as TL +import Language.TCT.Debug + -- * Type 'Pos' -- | Relative position data Pos @@ -34,6 +37,9 @@ instance Show Pos where showChar ':' . showsPrec 11 pos_column +pos1 :: Pos +pos1 = Pos 1 1 + -- ** Type 'LineNum' type LineNum = Int @@ -54,12 +60,21 @@ instance Show a => Show (Cell a) where showChar ' ' . showsPrec 10 cell_begin . showChar ' ' . showsPrec 10 cell_end . showChar ' ' . showsPrec 11 unCell +instance Pretty a => Pretty (Cell a) where + pretty (Cell bp ep m) = do + s <- pretty m + return $ "Cell "<>show bp<>":"<>show ep<>" "<>s instance (FromPad a, Semigroup a) => Semigroup (Cell a) where - Cell bx (Pos lx _cx) x <> Cell (Pos ly cy) ey y = - Cell bx ey $ x <> fromPad (Pos (ly - lx) cy) <> y + Cell bx (Pos lx cx) x <> Cell (Pos ly cy) ey y = + Cell bx ey $ + x <> fromPad pad <> y + where + pad = Pos lyx $ if lyx == 0 then cy - cx else cy + lyx = ly - lx instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where mempty = cell0 mempty mappend = (<>) + cell0 :: a -> Cell a cell0 = Cell mempty mempty @@ -74,196 +89,3 @@ instance FromPad TL.Text where fromPad Pos{..} = TL.replicate (fromIntegral pos_line) "\n" <> TL.replicate (fromIntegral pos_column) " " - -{- -instance (FromPad a, Semigroup a) => Semigroup (Cell a) where - Cell bx ex x <> Cell by ey y = - Cell bx ey $ x <> fromPad by <> y -instance Applicative Cell where - pure = Cell mempty mempty - Cell of_ sf f <*> Cell bx ex x = - Cell of_ (sf<>bx<>ex) (f x) - -cell0 :: a -> Cell a -cell0 = pure - --- * Class 'Cellified' -class Cellified a where - reachOf :: a -> Pos - reachOf a = offsetOf a <> sizeOf a - offsetOf :: a -> Pos - sizeOf :: a -> Pos -instance Cellified (Cell a) where - offsetOf = cell_begin - sizeOf = cell_end -instance Cellified a => Cellified [a] where - reachOf = foldMap reachOf - offsetOf = \case - [] -> mempty - s0 : ss -> - if sizeOf s0 == mempty - then offsetOf s0 <> offsetOf ss - else offsetOf s0 - sizeOf = foldMap sizeOf -instance Cellified a => Cellified (Seq a) where - reachOf = foldMap reachOf - offsetOf s = case Seq.viewl s of - EmptyL -> mempty - s0 :< ss -> - if sizeOf s0 == mempty - then offsetOf s0 <> offsetOf ss - else offsetOf s0 - sizeOf = foldMap sizeOf -instance (Cellified k, Cellified a) => Cellified (Tree k a) where - reachOf = \case - TreeN k _ts -> reachOf k - Tree0 a -> reachOf a - offsetOf = \case - TreeN k _ts -> offsetOf k - Tree0 a -> offsetOf a - sizeOf = \case - TreeN k _ts -> sizeOf k - Tree0 a -> sizeOf a --} - -{- --- * Class 'Cellify' -class Cellify a where - cellify :: a -> Cell a -instance Cellify Text where - cellify t = Cell mempty s t - where - s = - Text.foldl' (\acc -> \case - '\n' -> acc{pos_line = pos_line acc + 1} - _ -> acc{pos_column = pos_column acc + 1}) - mempty t - --- * Type 'Pad' -type Pad = Pos - --- * Type 'Padded' -data Padded a - = Padded - { pad :: !Pad - , unPad :: !a - } deriving (Eq,Show) - - --- * Type 'Pos' --- | Absolute position -data Pos - = Pos - { pos_line :: {-# UNPACK #-} !LineNum - , pos_column :: {-# UNPACK #-} !ColNum - } deriving (Eq, Ord) -instance Show Pos where - showsPrec _p Pos{..} = showsPrec 11 (pos_line,pos_column) - -pos1 :: Pos -pos1 = Pos 1 1 - --} - - - - - - -{- -instance Applicative (Cell a) where - pure = cell0 - cf@(Cell bf ef f) <*> ca@(Cell ba ea a) = - | isCell0 cf || isCell0 ca = cell0 (f a) - Cell bf ea (f a) -isCell0 :: Cell a -> Bool -isCell0 (Cell bp ep _) = isPos0 bp && isPos0 ep --} - -{- -lineCell :: Cell a -> LineNum -lineCell = pos_line . cell_begin -columnCell :: Cell a -> ColNum -columnCell = pos_column . cell_begin - -cell1 :: a -> Cell a -cell1 = Cell pos1 pos1 --} - -{- -posSeq :: Seq (Cell a) -> Maybe (Pos,Pos) -posSeq toks = - case Seq.viewl toks of - EmptyL -> Nothing - Cell bp _ep _ :< _ -> - case Seq.viewr toks of - EmptyR -> Nothing - _ :> Cell _bp ep _ -> - Just (bp, ep) -posTrees :: Seq (Trees (Cell k) a) -> Maybe (Pos,Pos) -posTrees trees = - case Seq.viewl trees of - EmptyL -> Nothing - Tree0 toks :< ts -> - case posSeq toks of - Nothing -> posTrees ts - Just (bp,_ep) -> - Just $ - case Seq.viewr trees of - EmptyR -> (bp,bp) - _ :> TreeN _ toks | iiiii-> - - TreeN (Cell bp _ep _) _ :< _ -> - case Seq.viewr trees of - EmptyR -> Nothing - _ :> TreeN _ toks | iiiii-> - Just (Cell bp ep ()) --} - -{- -posTree :: Tree (Cell k) (Cell a) -> Pos -posTree (TreeN c _) = cell_begin c -posTree (Tree0 c) = cell_begin c - -posEndTree :: Tree (Cell k) (Cell a) -> Pos -posEndTree (TreeN c _) = cell_end c -posEndTree (Tree0 c) = cell_end c - -pos0 :: Pos -pos0 = Pos 0 0 --} -{- -instance Ord Pos where - Pos lx cx `compare` Pos ly cy = - compare lx ly <> - compare cx cy - -isPos0 :: Pos -> Bool -isPos0 (Pos 0 0 ) = True -isPos0 _ = False --} - -{- --- ** Class 'CellOf' -class CellOf a where - firstCellOf :: a -> Maybe (Cell ()) -instance CellOf (Cell a) where - firstCellOf = Just . (() <$) -instance CellOf a => CellOf (Seq a) where - firstCellOf s = - case Seq.viewl s of - EmptyL -> Nothing - s0 :< ss -> - firstCellOf s0 <|> - firstCellOf ss -instance CellOf a => CellOf [a] where - firstCellOf = \case - [] -> Nothing - s0 : ss -> - firstCellOf s0 <|> - firstCellOf ss -instance (CellOf k, CellOf a) => CellOf (Tree k a) where - firstCellOf = \case - Tree0 a -> firstCellOf a - TreeN k a -> firstCellOf k <|> firstCellOf a --} diff --git a/Language/TCT/Debug.hs b/Language/TCT/Debug.hs new file mode 100644 index 0000000..c61fddd --- /dev/null +++ b/Language/TCT/Debug.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +module Language.TCT.Debug where + +import Control.Monad (Monad(..), mapM) +import Data.Bool +import Data.Foldable (toList, null) +import Data.Function (($), (.)) +import Data.Int (Int) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (Maybe(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Sequence (Seq) +import Data.String (String) +import Data.Text (Text) +import Data.TreeSeq.Strict (Tree(..)) +import Prelude ((+)) +import Text.Show (Show(..)) +import qualified Control.Monad.Trans.Reader as R +import qualified Data.List as List +import qualified Data.Text.Lazy as TL +import qualified Text.Megaparsec as P + +-- * Debug +#if DEBUG +import qualified Debug.Trace as Trace + +debug :: String -> a -> a +debug = Trace.trace + +debug0 :: Pretty a => String -> a -> a +debug0 m a = Trace.trace (m <> ": " <> R.runReader (pretty a) 2) a + +debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r) +debug1 nf na f a = + (\r -> Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) r) $ + (Trace.trace (nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) f) + a + +debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r +debug1_ nf (na,a) r = + Trace.trace (nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) $ + Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) $ + r + +debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r) +debug2 nf na nb f a b = + (\r -> Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) r) $ + Trace.trace + (nf <> ":" + <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 + <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 + ) f a b + +debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r +debug2_ nf (na,a) (nb,b) r = + Trace.trace + (nf <> ":" + <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 + <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 + ) $ + Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) $ + r + +debugParser :: Show a => String -> P.Parsec e s a -> P.Parsec e s a +debugParser = P.dbg +#else +import Data.Function (id) + +debug :: String -> a -> a +debug _m = id +{-# INLINE debug #-} + +debug0 :: Pretty a => String -> a -> a +debug0 _m = id +{-# INLINE debug0 #-} + +debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r) +debug1 _nf _na = id +{-# INLINE debug1 #-} + +debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r) +debug2 _nf _na _nb = id +{-# INLINE debug2 #-} + +debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r +debug2_ _nf _a _b = id +{-# INLINE debug2_ #-} + +debugParser :: Show a => String -> P.Parsec e s a -> P.Parsec e s a +debugParser _m = id +{-# INLINE debugParser #-} +#endif + +-- * Class 'Pretty' +class Pretty a where + pretty :: a -> R.Reader Int String + default pretty :: Show a => a -> R.Reader Int String + pretty = return . show +instance Pretty Int +instance Pretty Text +instance Pretty TL.Text +instance (Pretty a, Pretty b) => Pretty (a,b) where + pretty (a,b) = do + i <- R.ask + a' <- R.local (+2) $ pretty a + b' <- R.local (+2) $ pretty b + return $ + "\n" <> List.replicate i ' ' <> "( " <> a' <> + "\n" <> List.replicate i ' ' <> ", " <> b' <> + "\n" <> List.replicate i ' ' <> ") " +instance Pretty a => Pretty [a] where + pretty [] = return "[]" + pretty as = do + i <- R.ask + s <- R.local (+2) $ mapM pretty as + return $ + "\n" <> List.replicate i ' ' <> "[ " <> + List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> + "\n" <> List.replicate i ' ' <> "] " +instance Pretty a => Pretty (NonEmpty a) where + pretty = pretty . toList +instance Pretty a => Pretty (Seq a) where + pretty ss + | null ss = return "[]" + | otherwise = do + let as = toList ss + i <- R.ask + s <- R.local (+2) $ mapM pretty as + return $ + "\n" <> List.replicate i ' ' <> "[ " <> + List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> + "\n" <> List.replicate i ' ' <> "] " +instance Pretty a => Pretty (Maybe a) where + pretty Nothing = return "Nothing" + pretty (Just m) = do + s <- pretty m + return $ "Just "<>s +instance Show a => Pretty (Tree a) where + pretty (Tree n ts) = do + s <- R.local (+2) (pretty ts) + return $ "Tree "<>showsPrec 11 n ""<>" "<>s diff --git a/Language/TCT/Elem.hs b/Language/TCT/Elem.hs index ed1f293..4e30138 100644 --- a/Language/TCT/Elem.hs +++ b/Language/TCT/Elem.hs @@ -1,84 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} module Language.TCT.Elem where -import Data.Bool -import Control.Monad (Monad(..), mapM) import Data.Eq (Eq) -import Data.Function (($), (.)) -import Data.Foldable (toList, null) -import Data.Int (Int) import Data.Ord (Ord) -import Data.Maybe (Maybe(..)) -import Prelude ((+)) -import Data.Semigroup (Semigroup(..)) -import Data.String (String) -import Data.Sequence (Seq) import Text.Show (Show(..)) -import Data.TreeSeq.Strict (Tree(..)) -import qualified Control.Monad.Trans.Reader as R -import qualified Data.List as List import qualified Data.Text.Lazy as TL -import Debug.Trace (trace) - -trac :: String -> a -> a --- trac _m x = x -trac = trace -{-# INLINE trac #-} - -debug :: Pretty a => String -> String -> a -> b -> b -debug f n a = trac (f <> ": " <> n <> " = " <> R.runReader (pretty a) 2) - -dbg :: Pretty a => String -> a -> a -dbg m x = trac (m <> ": " <> R.runReader (pretty x) 2) x -{-# INLINE dbg #-} - --- * Class 'Pretty' -class Pretty a where - pretty :: a -> R.Reader Int String -instance Pretty Int where - pretty = return . show -instance Pretty TL.Text where - pretty = return . show -instance (Pretty a, Pretty b) => Pretty (a,b) where - pretty (a,b) = do - i <- R.ask - a' <- R.local (+2) $ pretty a - b' <- R.local (+2) $ pretty b - return $ - "\n" <> List.replicate i ' ' <> "( " <> a' <> - "\n" <> List.replicate i ' ' <> ", " <> b' <> - "\n" <> List.replicate i ' ' <> ") " -instance Pretty a => Pretty [a] where - pretty [] = return "[]" - pretty as = do - i <- R.ask - s <- R.local (+2) $ mapM pretty as - return $ - "\n" <> List.replicate i ' ' <> "[ " <> - List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> - "\n" <> List.replicate i ' ' <> "] " -instance Pretty a => Pretty (Seq a) where - pretty ss - | null ss = return "[]" - | otherwise = do - let as = toList ss - i <- R.ask - s <- R.local (+2) $ mapM pretty as - return $ - "\n" <> List.replicate i ' ' <> "[ " <> - List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> - "\n" <> List.replicate i ' ' <> "] " -instance Pretty a => Pretty (Maybe a) where - pretty Nothing = return "Nothing" - pretty (Just m) = do - s <- pretty m - return $ "Just "<>s -instance Show a => Pretty (Tree a) where - pretty (Tree n ts) = do - s <- R.local (+2) (pretty ts) - return $ "Tree "<>showsPrec 11 n ""<>" "<>s - -- * Type 'ElemName' type ElemName = TL.Text diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs index 1250acc..e83e033 100644 --- a/Language/TCT/Read.hs +++ b/Language/TCT/Read.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module Language.TCT.Read ( module Language.TCT.Read.Tree , module Language.TCT.Read.Token @@ -9,82 +6,50 @@ module Language.TCT.Read ) where import Control.Applicative (Applicative(..)) -import Control.Monad (Monad(..), join) -import Data.Char (Char) +import Control.Monad (Monad(..)) import Data.Either (Either(..)) -import Data.Eq (Eq(..)) -import Data.Function (($), (.)) -import Data.Functor ((<$>), (<$)) import Data.Foldable (Foldable(..)) -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord(..)) -import Data.Proxy (Proxy(..)) -import Data.Semigroup (Semigroup(..)) -import Data.String (IsString) +import Data.Function (($)) +import Data.Functor ((<$>)) import Data.Traversable (Traversable(..)) import Data.TreeSeq.Strict (Tree(..), Trees) import Data.Void (Void) import System.IO (FilePath) -import Text.Show (Show(..)) import qualified Data.Text.Lazy as TL -import qualified Data.TreeSeq.Strict as Tree import qualified Text.Megaparsec as P --- import qualified Data.List as List +import Language.TCT.Debug import Language.TCT.Tree import Language.TCT.Cell import Language.TCT.Read.Cell import Language.TCT.Read.Tree import Language.TCT.Read.Token -import Debug.Trace (trace) - +-- | Parsing is done in two phases: +-- +-- 1. indentation-sensitive parsing on 'TL.Text' +-- 2. pair-sensitive parsing on some 'NodeText's resulting of 1. readTrees :: FilePath -> TL.Text -> Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node)) readTrees inp txt = do trs <- P.runParser (p_Trees <* P.eof) inp txt - {-(join <$>) $ -} - traverse (go Nothing) $ - trace ("### TRS ###\n"<>show (Tree.Pretty trs)) trs + traverse (go NodeGroup) $ debug0 "readTrees" trs where - go :: - Maybe Node -> - Tree (Cell Node) -> + go :: Node -> Tree (Cell Node) -> Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Tree (Cell Node)) - go p t@(Tree c@(Cell bn en nod) ts) = + go parent t@(Tree c@(Cell bn en nod) ts) = case nod of - NodeGroup{} -> Tree c <$> traverse (go (Just nod)) ts - NodeHeader{} -> Tree c <$> traverse (go (Just nod)) ts - NodeToken{} -> Tree c <$> traverse (go (Just nod)) ts - NodePair{} -> Tree c <$> traverse (go (Just nod)) ts - NodePara{} -> Tree c <$> traverse (go (Just nod)) ts - NodeLower{} -> Right t - -- NodeText n | TL.null n -> Right t + NodeLower{} -> Right t NodeText n -> - case p of - Just (NodeHeader HeaderBar{}) -> Right t - Just (NodeHeader HeaderEqual{}) -> Right t + case parent of + NodeHeader HeaderBar{} -> Right t + NodeHeader HeaderEqual{} -> Right t _ -> do - toks <- parseTokens <$> parseLexemes inp (n <$ c) + toks <- parseTokens <$> parseLexemes inp (Cell bn en n) return $ case toList toks of [tok] -> tok _ -> Tree (Cell bn en NodeGroup) toks - {- - NodeHeader _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts - NodeToken _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts - NodePair _n -> pure . Tree c . join <$> traverse (go (Just nod)) ts - NodeLower{} -> Right $ pure t - NodeText n | TL.null n -> Right $ pure t - NodeText n -> - case p of - Just (NodeHeader HeaderBar{}) -> Right $ pure t - Just (NodeHeader HeaderEqual{}) -> Right $ pure t - _ -> do - acc <- parseLexemes inp (n <$ c) - sn <- traverse (go (Just nod)) ts - return $ parseTokens $ - foldr (\s a -> orientLexemePairAny $ LexemeTree s:a) acc (join sn) - -} + _ -> Tree c <$> traverse (go nod) ts diff --git a/Language/TCT/Read/Cell.hs b/Language/TCT/Read/Cell.hs index c6f69d3..b8d1a9c 100644 --- a/Language/TCT/Read/Cell.hs +++ b/Language/TCT/Read/Cell.hs @@ -16,10 +16,9 @@ import Data.Maybe (Maybe(..)) import Data.Ord (Ord) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (String, IsString) +import Data.String (IsString) import Data.Tuple (snd) import System.FilePath (FilePath) -import Text.Show (Show) import qualified Data.Set as Set import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P @@ -110,10 +109,3 @@ instance P.Stream StreamCell where '\n' -> P.SourcePos n (line <> P.pos1) indent _ -> P.SourcePos n line (col <> P.pos1) advanceN s indent = TL.foldl' (P.advance1 s indent) - - --- * Debug -pdbg :: Show a => String -> Parser e s a -> Parser e s a -pdbg = P.dbg --- pdbg _m p = p -{-# INLINE pdbg #-} diff --git a/Language/TCT/Read/Elem.hs b/Language/TCT/Read/Elem.hs index e5f1878..cd5b4e0 100644 --- a/Language/TCT/Read/Elem.hs +++ b/Language/TCT/Read/Elem.hs @@ -18,6 +18,7 @@ import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Data.Text.Lazy as TL +import Language.TCT.Debug import Language.TCT.Elem import Language.TCT.Tree import Language.TCT.Read.Cell @@ -36,7 +37,7 @@ p_AlphaNums = P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum {- -- NOTE: could be done with TL.Text, which has a less greedy (<>). p_Word :: Parser e Text Text -p_Word = pdbg "Word" $ P.try p_take <|> p_copy +p_Word = debugParser "Word" $ P.try p_take <|> p_copy where p_take = do P.notFollowedBy $ P.satisfy $ not . Char.isAlphaNum @@ -57,7 +58,7 @@ p_Word = pdbg "Word" $ P.try p_take <|> p_copy -- * Elem p_ElemSingle :: P.Tokens s ~ TL.Text => Parser e s Pair -p_ElemSingle = pdbg "ElemSingle" $ +p_ElemSingle = debugParser "ElemSingle" $ PairElem <$ P.char '<' <*> p_ElemName @@ -65,7 +66,7 @@ p_ElemSingle = pdbg "ElemSingle" $ <* P.string "/>" p_ElemOpen :: P.Tokens s ~ TL.Text => Parser e s Pair -p_ElemOpen = pdbg "ElemOpen" $ +p_ElemOpen = debugParser "ElemOpen" $ PairElem <$ P.char '<' <*> p_ElemName @@ -77,7 +78,7 @@ p_ElemName = p_AlphaNums -- TODO: namespace p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair -p_ElemClose = pdbg "ElemClose" $ +p_ElemClose = debugParser "ElemClose" $ (`PairElem` []) <$ P.string " p_ElemName diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index 1401828..2abfe13 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -5,14 +5,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Read.Token where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) -import Data.Eq (Eq(..)) import Data.Either (Either(..)) +import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor ((<$>), ($>)) @@ -20,7 +21,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>)) +import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>)) import Data.String (String) import Data.TreeSeq.Strict (Tree(..), Trees) import Data.Tuple (fst,snd) @@ -35,28 +36,21 @@ import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P +import Language.TCT.Debug import Language.TCT.Cell import Language.TCT.Elem --- import Language.TCT.Token import Language.TCT.Tree import Language.TCT.Read.Elem import Language.TCT.Read.Cell -instance Pretty Pair where - pretty = return . show -instance Pretty a => Pretty (Cell a) where - pretty (Cell bp ep m) = do - s <- pretty m - return $ "Cell "<>show bp<>":"<>show ep<>" "<>s -instance Pretty Lexeme where - pretty = return . show - -- * Type 'Pairs' --- | Right-only Dyck language +-- | Right-only Dyck language, +-- to keep track of opened 'Pair's. type Pairs = (Tokens,[Opening]) type Tokens = Trees (Cell Node) -- ** Type 'Opening' +-- | An opened 'Pair' and its content so far. type Opening = (Cell Pair,Tokens) appendToken :: Pairs -> Tree (Cell Node) -> Pairs @@ -67,6 +61,9 @@ appendTokens :: Pairs -> Tokens -> Pairs appendTokens (ts,[]) toks = (ts<>toks,[]) appendTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0<>toks):ps) +-- | Appending 'TL.Text' is a special case +-- to append at the 'TokenText' level is possible, +-- instead of the higher 'NodeToken' level. appendText :: Pairs -> Cell TL.Text -> Pairs appendText ps tok = case ps of @@ -74,10 +71,10 @@ appendText ps tok = (ts,(p0,ts0):pss) -> (ts,(p0,appendTokenText ts0 tok):pss) appendTokenText :: Tokens -> Cell TL.Text -> Tokens -appendTokenText ts (Cell bn en n) +appendTokenText ts (Cell bn en n) = {- | TL.null n = ts - | otherwise-} = + | otherwise = -} case Seq.viewr ts of EmptyR -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n is :> Tree (Cell bo _eo nod) st -> @@ -104,9 +101,9 @@ openPair (t,ps) p = (t,(p,mempty):ps) -- | Close a 'Pair' when there is a matching 'LexemePairClose'. closePair :: Pairs -> Cell Pair -> Pairs -closePair ps@(_,[]) (Cell bp ep p) = -- dbg "closePair" $ +closePair ps@(_,[]) (Cell bp ep p) = -- debug0 "closePair" $ appendText ps $ Cell bp ep $ snd $ pairBorders p -closePair (t,(p1,t1):ts) p = -- dbg "closePair" $ +closePair (t,(p1,t1):ts) p = -- debug0 "closePair" $ case (p1,p) of (Cell bx _ex (PairElem nx ax), Cell _by ey (PairElem ny ay)) | nx == ny -> appendToken (t,ts) $ @@ -124,11 +121,11 @@ closePair (t,(p1,t1):ts) p = -- dbg "closePair" $ -- | Close a 'Pair' when there is no matching 'LexemePairClose'. closeImpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens -closeImpaired acc (Cell bp ep p,toks) = dbg "closeImpaired" $ +closeImpaired acc (Cell bp ep p,toks) = -- debug0 "closeImpaired" $ case p of -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'. - PairHash | Just (Cell bt et t, ts) <- tagFrom $ toks <> acc -> - Tree0 (Cell bt et $ NodeToken $ TokenTag t) <| ts + PairHash | Just (Cell _bt et t, ts) <- tagFrom $ toks <> acc -> + Tree0 (Cell bp et $ NodeToken $ TokenTag t) <| ts {- PairHash | (Tree0 (Cell bt et (TokenPlain t))) :< ts <- Seq.viewl $ toks <> acc -> case Text.span isTagChar t of @@ -145,70 +142,31 @@ closeImpaired acc (Cell bp ep p,toks) = dbg "closeImpaired" $ toksHash :: Cell TL.Text toksHash = Cell bp ep $ fst $ pairBorders p -isTagChar :: Char -> Bool -isTagChar c = - Char.isAlphaNum c || - c=='·' || - case Char.generalCategory c of - Char.DashPunctuation -> True - Char.ConnectorPunctuation -> True - _ -> False - --- * Class 'TagFrom' -class TagFrom a where - tagFrom :: a -> Maybe (Cell Tag, a) -instance TagFrom Tokens where - tagFrom ts = - case Seq.viewl ts of - EmptyL -> Nothing - Tree0 (Cell b0 e0 n) :< ns -> - case n of - NodeToken (TokenText t) -> - case tagFrom $ Cell b0 e0 t of - Nothing -> Nothing - Just (t0,r0) -> - if TL.null (unCell r0) - then - case tagFrom ns of - Just (t1@(Cell b1 _e1 _), r1) | e0 == b1 -> - Just (t0<>t1, r1) - _ -> Just (t0, n0 <| ns) - else Just (t0, n0 <| ns) - where n0 = (Tree0 $ NodeToken . TokenText <$> r0) - _ -> Nothing - _ -> Nothing -instance TagFrom (Cell TL.Text) where - tagFrom (Cell bp ep t) - | (w,r) <- TL.span isTagChar t - , not $ TL.null w - , ew <- pos_column bp + sum (Text.length <$> (TL.toChunks w)) = - Just - ( Cell bp bp{pos_column=ew} w - , Cell bp{pos_column=ew} ep r ) - tagFrom _ = Nothing - -- | Close remaining 'Pair's at end of parsing. closePairs :: Pairs -> Tokens -closePairs (t0,ps) = -- dbg "closePairs" $ +closePairs (t0,ps) = -- debug0 "closePairs" $ t0 <> foldl' closeImpaired mempty ps appendLexeme :: Lexeme -> Pairs -> Pairs -appendLexeme lex acc = - -- dbg "appendLexeme" $ +appendLexeme lex acc = -- debug2 "appendLexeme" "lex" "acc" $ \lex acc -> case lex of - LexemePairOpen ps -> foldl' openPair acc ps - {- + LexemePairOpen ps -> foldl' open acc ps where - open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Tree0 $ Cell ep ep $ TokenPhrase $ PhraseWhite "") - open a p = openPair a p - -} + -- NOTE: insert an empty node to encode , not + open a p@(Cell _bp ep (PairElem{})) = + openPair a p `appendToken` + (Tree0 $ Cell ep ep $ NodeToken $ TokenText "") + open a p = openPair a p LexemePairClose ps -> foldl' closePair acc ps + LexemePairAny ps -> foldl' openPair acc ps + {- LexemePairAny ps -> appendText acc $ sconcat $ ((fst . pairBordersWithoutContent) <$>) <$> ps - LexemePairBoth ps -> appendTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps - LexemeEscape c -> appendToken acc $ Tree0 $ NodeToken . TokenEscape <$> c - LexemeLink t -> appendToken acc $ Tree0 $ NodeToken . TokenLink <$> t + -} + LexemePairBoth ps -> appendTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps + LexemeEscape c -> appendToken acc $ Tree0 $ NodeToken . TokenEscape <$> c + LexemeLink t -> appendToken acc $ Tree0 $ NodeToken . TokenLink <$> t {-LexemeWhite (unCell -> "") -> acc-} -- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc LexemeWhite t -> appendText acc t @@ -217,29 +175,18 @@ appendLexeme lex acc = LexemeTree t -> appendToken acc t LexemeEnd -> acc -{- TODEL -appendTokenChild :: Pairs -> Tree (Cell Node) -> Pairs -appendTokenChild pairs tree = - debug "appendTokenChild" "pairs" pairs $ - debug "appendTokenChild" "tree" tree $ - dbg "appendTokenChild" $ - go pairs tree - where - go (ts@(toList -> [unTree -> Cell bo _eo NodeText{}]),[]) - tok@(Tree (Cell _bn en _n) _ns) = - (pure $ Tree (Cell bo en NodePara) (ts |> tok),[]) - go (ts,[]) tok = (ts |> tok,[]) - go (ts,(p0,t0):ps) tok = (ts,(p0,t0|>tok):ps) --} - appendLexemes :: Pairs -> [Lexeme] -> Pairs appendLexemes = foldr appendLexeme -- * Type 'Lexeme' +-- | 'Lexeme's cut the input in the longest chunks of common semantic, +-- this enables 'orientLexemePairAny' to work with a more meaningful context. data Lexeme = LexemePairOpen !(NonEmpty (Cell Pair)) | LexemePairClose !(NonEmpty (Cell Pair)) | LexemePairAny !(NonEmpty (Cell Pair)) + -- ^ orientation depending on the surrounding 'Lexeme's, + -- see 'orientLexemePairAny' | LexemePairBoth !(NonEmpty (Cell Pair)) | LexemeEscape !(Cell Char) | LexemeLink !(Cell TL.Text) @@ -249,15 +196,13 @@ data Lexeme | LexemeTree !(Tree (Cell Node)) | LexemeEnd deriving (Eq, Show) - --- ** Type 'Lexemes' -type Lexemes = Seq Lexeme +instance Pretty Lexeme parseTokens :: [Lexeme] -> Tokens parseTokens ps = closePairs $ appendLexemes mempty $ - -- dbg "Lexemes (post orient)" $ + -- debug0 "Lexemes (post orient)" $ orientLexemePairAny $ LexemeEnd : ps @@ -267,15 +212,19 @@ parseLexemes :: Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) [Lexeme] parseLexemes inp = runParserOnCell inp (p_Lexemes <* P.eof) --- | Parse 'Lexeme's, returning them in reverse order to apply 'orientLexemePairAny'. +-- | Parse 'Lexeme's, returning them in reverse order +-- to apply 'orientLexemePairAny'. p_Lexemes :: P.Tokens s ~ TL.Text => Parser e s [Lexeme] -p_Lexemes = pdbg "Lexemes" $ go [] +p_Lexemes = debugParser "Lexemes" $ go [] where go :: P.Tokens s ~ TL.Text => [Lexeme] -> Parser e s [Lexeme] go acc = (P.eof $> acc) <|> (p_Lexeme >>= \next -> go $ orientLexemePairAny $ next:acc) +-- | Must be called on parsed 'Lexeme's after the prepending of any new 'Lexeme', +-- so that it can try to orient nearby 'LexemePairAny' +-- to 'LexemePairOpen' or 'LexemePairClose'. orientLexemePairAny :: [Lexeme] -> [Lexeme] orientLexemePairAny = \case -- LexemeOther (Cell _bx ex x):LexemeOther (Cell by _ey y):acc -> LexemeOther (Cell by ex (x<>y)):acc @@ -309,15 +258,12 @@ orientLexemePairAny = \case -- "( o@LexemePairOpen{}:LexemePairAny p:acc -> o:LexemePairClose p:acc -- )" - LexemePairAny p:c@LexemePairClose{}:acc -> c:LexemePairClose p:acc + LexemePairAny p:c@LexemePairClose{}:acc -> LexemePairClose p:c:acc acc -> acc -p_some :: Parser e s a -> Parser e s (NonEmpty a) -p_some p = NonEmpty.fromList <$> P.some p - p_Lexeme :: P.Tokens s ~ TL.Text => Parser e s Lexeme -p_Lexeme = pdbg "Lexeme" $ +p_Lexeme = debugParser "Lexeme" $ P.choice [ P.try $ LexemeWhite <$> p_Cell p_Spaces1 , P.try $ LexemePairAny <$> p_some (p_Cell $ p_satisfyMaybe pairAny) @@ -330,6 +276,9 @@ p_Lexeme = pdbg "Lexeme" $ , LexemeOther <$> p_Cell (TL.singleton <$> P.anyChar) ] +p_some :: Parser e s a -> Parser e s (NonEmpty a) +p_some p = NonEmpty.fromList <$> P.some p + pairAny :: Char -> Maybe Pair pairAny = \case '-' -> Just PairDash @@ -449,3 +398,45 @@ pairBorders = \case PairParen -> ("(",")") PairBrace -> ("{","}") PairBracket -> ("[","]") + +-- * Class 'TagFrom' +class TagFrom a where + tagFrom :: a -> Maybe (Cell Tag, a) +instance TagFrom Tokens where + tagFrom ts = + case Seq.viewl ts of + EmptyL -> Nothing + Tree0 (Cell b0 e0 n) :< ns -> + case n of + NodeToken (TokenText t) -> + case tagFrom $ Cell b0 e0 t of + Nothing -> Nothing + Just (t0,r0) -> + if TL.null (unCell r0) + then + case tagFrom ns of + Just (t1@(Cell b1 _e1 _), r1) | e0 == b1 -> + Just (t0<>t1, r1) + _ -> Just (t0, n0 <| ns) + else Just (t0, n0 <| ns) + where n0 = (Tree0 $ NodeToken . TokenText <$> r0) + _ -> Nothing + _ -> Nothing +instance TagFrom (Cell TL.Text) where + tagFrom (Cell bp ep t) + | (w,r) <- TL.span isTagChar t + , not $ TL.null w + , ew <- pos_column bp + sum (Text.length <$> (TL.toChunks w)) = + Just + ( Cell bp bp{pos_column=ew} w + , Cell bp{pos_column=ew} ep r ) + tagFrom _ = Nothing + +isTagChar :: Char -> Bool +isTagChar c = + Char.isAlphaNum c || + c=='·' || + case Char.generalCategory c of + Char.DashPunctuation -> True + Char.ConnectorPunctuation -> True + _ -> False diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index 9763e2b..91b652c 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -7,15 +7,12 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Read.Tree where --- import Data.String (IsString(..)) --- import qualified Data.TreeSeq.Strict as TreeSeq import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..), void) import Data.Bool import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>), ($>), (<$)) -import Data.Foldable (toList) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) @@ -26,18 +23,18 @@ import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P +import Language.TCT.Debug import Language.TCT.Cell --- import Language.TCT.Token import Language.TCT.Tree import Language.TCT.Read.Cell import Language.TCT.Read.Elem import Language.TCT.Read.Token p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row -p_CellHeader row = pdbg "CellHeader" $ do +p_CellHeader row = debugParser "CellHeader" $ do P.skipMany $ P.char ' ' pos <- p_Position - header <- pdbg "Header" $ + header <- debugParser "Header" $ P.choice $ [ P.try $ P.char '-' >> P.char ' ' $> HeaderDash <|> @@ -100,7 +97,7 @@ p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_Line1 = P.takeWhile1P (Just "Line") (/='\n') p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row -p_CellLower row = pdbg "CellLower" $ do +p_CellLower row = debugParser "CellLower" $ do indent <- p_HSpaces pos <- p_Position void $ P.char '<' @@ -150,26 +147,26 @@ p_CellLower row = pdbg "CellLower" $ do >> go (l:ls)) p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row -p_CellText row = pdbg "CellText" $ do +p_CellText row = debugParser "CellText" $ do P.skipMany $ P.char ' ' n <- p_Cell $ NodeText <$> p_Line1 return $ Tree0 n : row p_CellSpaces :: Row -> Parser e s Row -p_CellSpaces row = pdbg "CellSpaces" $ do +p_CellSpaces row = debugParser "CellSpaces" $ do P.skipSome $ P.char ' ' pos <- p_Position return $ Tree0 (Cell pos pos $ NodeText "") : row p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row -p_CellEnd row = pdbg "CellEnd" $ +p_CellEnd row = debugParser "CellEnd" $ P.try (p_CellLower row) <|> P.try (p_CellText row) <|> p_CellSpaces row <|> return row p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row -p_Row row = pdbg "Row" $ +p_Row row = debugParser "Row" $ P.try (p_CellHeader row) <|> p_CellEnd row @@ -181,9 +178,6 @@ p_Rows rows = (P.newline >> P.eof $> rows' <|> p_Rows rows') p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node)) -p_Trees = unNodePara . subTrees . collapseRows <$> p_Rows [root] +p_Trees = subTrees . collapseRows <$> p_Rows [root] where - root = Tree (cell0 $ NodeHeader HeaderDashDash) mempty - unNodePara :: Trees (Cell Node) -> Trees (Cell Node) - unNodePara (toList -> [(Tree (unCell -> NodePara) ts)]) = ts - unNodePara ts = ts + root = Tree0 (cell0 NodeGroup) diff --git a/Language/TCT/Token.hs b/Language/TCT/Token.hs deleted file mode 100644 index a5ba2df..0000000 --- a/Language/TCT/Token.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -module Language.TCT.Token where - -import Data.Char (Char) -import Data.Eq (Eq(..)) -import Data.Int (Int) -import Data.Ord (Ord(..)) -import Data.Sequence (Seq) -import Data.Text (Text) --- import Data.TreeSeq.Strict (Tree(..)) -import Text.Show (Show(..)) -import System.FilePath (FilePath) -import qualified Data.Text.Lazy as TL - -import Language.TCT.Cell -import Language.TCT.Elem - - - - - - -{- --- * Type 'TCT' -type TCT = Tree (Padded Key) Tokens - --- * Type 'Key' -data Key - = KeyColon !Name !White -- ^ @name: @ - | KeyEqual !Name !White -- ^ @name=@ - | KeyBar !Name !White -- ^ @name|@ - | KeyGreat !Name !White -- ^ @name>@ - | KeyLower !Name !ElemAttrs -- ^ @value@ - | PairHash -- ^ @#value#@ - | PairStar -- ^ @*value*@ - | PairSlash -- ^ @/value/@ - | PairUnderscore -- ^ @_value_@ - | PairDash -- ^ @-value-@ - | PairBackquote -- ^ @`value`@ - | PairSinglequote -- ^ @'value'@ - | PairDoublequote -- ^ @"value"@ - | PairFrenchquote -- ^ @«value»@ - | PairParen -- ^ @(value)@ - | PairBrace -- ^ @{value}@ - | PairBracket -- ^ @[value]@ - deriving (Eq,Ord,Show) - --- ** Type 'TokenValue' -data TokenValue - = TokenPhrases !Phrases - | TokenEscape !Char - | TokenTag !Tag - | TokenLink !Link - | TokenTree !TCT - | TokenRaw !TL.Text - deriving (Eq,Show) - --- * Type 'Phrases' -type Phrases = Seq (Padded Phrase) - --- ** Type 'Phrase' -data Phrase - = PhraseWord !Text - | PhraseWhite !Text - | PhraseOther !Text - deriving (Eq,Ord,Show) - --- * Type 'Tag' -type Tag = TL.Text --- newtype Tag = Tag Text - -type family Sourced a :: * -type instance Sourced (Padded a) = Padded (Sourced a) -type instance Sourced [a] = [Sourced a] -type instance Sourced (Seq a) = Seq (Sourced a) -type instance Sourced (Tree k a) = Tree (Sourced k) (Sourced a) -type instance Sourced Key = Cell Key -type instance Sourced Value = Cell Value -type instance Sourced TokenKey = Cell TokenKey -type instance Sourced TokenValue = TokenValue -type instance Sourced Phrase = Cell Phrase - --- * Type Pos -class Sourcify a where - sourcify :: a -> Sourced a -instance Sourced a => Sourced [a] where - type Sourced = [At a] - sourcify = (sourcify <$>) --} - -{- -instance Buildable Token where - build (TokenPlain t) = build t - build (TokenTag t) = "#"<>build t - build (TokenLink lnk) = build lnk - build (TokenEscape c) = "\\"<>build c - build (TokenPair p ts) = build c<>buildTokens ts<>build o - where (o,c) = pairBorders p ts - -buildTokens :: Tokens -> Builder -buildTokens = foldr (\a -> (<> build (unCell a))) "" - -instance Semigroup Tokens where - Tokens (Seq.viewr -> xs:>TokenPlain x) <> - Tokens (Seq.viewl -> TokenPlain y:(TokenPlain (x<>y)<|ys)) - Tokens x <> Tokens y = Tokens (x<>y) -instance Monoid Tokens where - mempty = Tokens mempty - mappend = (<>) -instance Buildable Tokens where - build (Tokens ts) = foldr (\a -> (<> build a)) "" ts -instance IsList Tokens where - type Item Tokens = Token - fromList = Tokens . fromList - toList (Tokens ts) = toList ts - -unTokens :: Tokens -> Seq Token -unTokens (Tokens ts) = ts --} diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index f2eb4ec..b505ad0 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -module Language.TCT.Tree where +module Language.TCT.Tree + ( module Language.TCT.Tree + , Tree(..), Trees + ) where import Control.Monad (Monad(..)) import Data.Bool @@ -26,28 +28,33 @@ import qualified Data.Text.Lazy as TL import Language.TCT.Cell import Language.TCT.Elem --- import Language.TCT.Token +import Language.TCT.Debug --- ** Type 'TCT' -type Root = Tree Node -type Roots = Trees Node +-- * Type 'Root' +-- | A single 'Tree' to rule all the 'Node's simplifies the navigation. +-- For error reporting, each 'Node' is annotated with a 'Cell' +-- spanning over all its content (sub-'Trees' included). +type Root = Tree (Cell Node) +type Roots = Trees (Cell Node) pattern Tree0 :: a -> Tree a pattern Tree0 a <- Tree a (null -> True) where Tree0 a = Tree a mempty --- ** Type 'Node' +-- * Type 'Node' data Node - = NodeHeader !Header - | NodePair !Pair - | NodeToken !Token - | NodeText !TL.Text - | NodeLower !Name !ElemAttrs -- ^ @ XML node + | NodeGroup -- ^ node, group trees into a single tree, + -- useful to return many trees when only one is expected deriving (Eq,Show) --- ** Type 'Header' +-- * Type 'Header' data Header = HeaderColon !Name !White -- ^ @name: @ | HeaderEqual !Name !White -- ^ @name=@ @@ -61,13 +68,13 @@ data Header | HeaderDotSlash !FilePath -- ^ @./file @ deriving (Eq, Ord, Show) --- *** Type 'Name' +-- ** Type 'Name' type Name = TL.Text --- *** Type 'LevelSection' +-- ** Type 'LevelSection' type LevelSection = Int --- ** Type 'Pair' +-- * Type 'Pair' data Pair = PairElem !ElemName !ElemAttrs -- ^ @value@ | PairHash -- ^ @#value#@ @@ -83,8 +90,9 @@ data Pair | PairBrace -- ^ @{value}@ | PairBracket -- ^ @[value]@ deriving (Eq,Ord,Show) +instance Pretty Pair --- ** Type 'Token' +-- * Type 'Token' data Token = TokenText !TL.Text | TokenEscape !Char @@ -92,20 +100,20 @@ data Token | TokenTag !Tag deriving (Eq,Show) --- *** Type 'Tag' +-- ** Type 'Tag' type Tag = TL.Text --- *** Type 'Link' +-- ** Type 'Link' type Link = TL.Text -- * Type 'Row' -- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line. -type Row = [Tree (Cell Node)] +type Row = [Root] -- ** Type 'Rows' -- | In reverse order: a list of nodes in scope -- (hence to which the next line can append to). -type Rows = [Tree (Cell Node)] +type Rows = [Root] -- | @appendRow rows row@ appends @row@ to @rows@. -- @@ -116,19 +124,17 @@ appendRow [] row = List.reverse row appendRow rows [] = rows appendRow rows@(old@(Tree (Cell bo eo o) os):olds) row@(new@(Tree (Cell bn en n) ns):news) = - debug "appendRow" "row" row $ - debug "appendRow" "rows" rows $ - dbg "appendRow" $ - case dbg "colOld" (pos_column bo) `compare` - dbg "colNew" (pos_column bn) of + debug2_ "appendRow" ("row",row) ("rows",rows) $ + case debug0 "colOld" (pos_column bo) `compare` + debug0 "colNew" (pos_column bn) of LT -> mergeNodeText lt EQ -> mergeNodeText $ case (o,n) of (_, NodeHeader (HeaderSection secNew)) | Just (secOld, s0:ss) <- collapseSection (pos_column bn) rows -> - case dbg "secOld" secOld `compare` - dbg "secNew" secNew of + case debug0 "secOld" secOld `compare` + debug0 "secNew" secNew of LT -> appendRow (new:s0:ss) news EQ -> appendRow (new:appendChild ss s0) news GT -> gt @@ -140,9 +146,9 @@ appendRow rows@(old@(Tree (Cell bo eo o) os):olds) GT -> gt where newPara = pos_line bn - pos_line eo > 1 - lt = debug "appendRow" "action" ("lt"::TL.Text) $ List.reverse row <> rows - eq = debug "appendRow" "action" ("eq"::TL.Text) $ appendRow (new : appendChild olds old) news - gt = debug "appendRow" "action" ("gt"::TL.Text) $ appendRow ( appendChild olds old) row + lt = debug "appendRow/lt" $ List.reverse row <> rows + eq = debug "appendRow/eq" $ appendRow (new : appendChild olds old) news + gt = debug "appendRow/gt" $ appendRow ( appendChild olds old) row -- | Find the first section (if any), returning its level, and the path collapsed upto it. collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows) @@ -164,7 +170,7 @@ appendRow rows@(old@(Tree (Cell bo eo o) os):olds) , not (TL.null to) , not (TL.null tn) -> -- debug "appendRow" "action" ("mergeNodeText"::TL.Text) $ - dbg "mergeNodeText" $ + debug0 "mergeNodeText" $ appendRow (merged : olds) news where merged = Tree (Cell bo en $ NodeText $ to<>tp<>tn) ns @@ -174,11 +180,9 @@ appendRow rows@(old@(Tree (Cell bo eo o) os):olds) } _ -> rs -appendChild :: Rows -> Tree (Cell Node) -> Rows +appendChild :: Rows -> Root -> Rows appendChild rows new@(Tree (Cell bn en n) ns) = - debug "appendChild" "new" new $ - debug "appendChild" "rows" rows $ - dbg "appendChild" $ + debug2_ "appendChild" ("new",Seq.singleton new) ("rows",rows) $ case rows of [] -> [new] old@(Tree (Cell bo eo o) os) : olds -> @@ -190,7 +194,7 @@ appendChild rows new@(Tree (Cell bn en n) ns) = (NodePara,_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,Tree (Cell bn en NodePara) $ return new] (_,NodePara) -> Tree (Cell bo en o) $ os|>new (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] - _ -> Tree (Cell bo en o) $ os|>Tree (Cell bn en NodePara) (return new) + _ -> Tree (Cell bo en o) $ os|> newTree else case (o,n) of (NodePara,NodePara) -> Tree (Cell bo en NodePara) $ os<>ns @@ -199,23 +203,25 @@ appendChild rows new@(Tree (Cell bn en n) ns) = (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] _ -> case Seq.viewr os of - EmptyR -> - Tree (Cell bo en o) $ - os |> Tree (Cell bn en NodePara) (return new) + EmptyR -> Tree (Cell bo en o) $ return newTree ls :> Tree (Cell br _er r) rs -> case r of - NodePara -> - if pos_column br == pos_column bn - then Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new) - else Tree (Cell bo en o) $ os |> Tree (Cell bn en NodePara) (return new) + NodePara + | pos_column br == pos_column bn + -> Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new) + | otherwise -> Tree (Cell bo en o) $ os |> newTree _ -> Tree (Cell bo en o) $ os |> new - where newPara = pos_line bn - pos_line eo > 1 - -collapseRows :: Rows -> Tree (Cell Node) -collapseRows rs = - debug "collapseRows" "rs" rs $ - dbg "collapseRows" $ - case rs of + where + newPara = pos_line bn - pos_line eo > 1 + newTree = + case n of + NodeHeader{} -> new + NodeLower{} -> new + _ -> Tree (Cell bn en NodePara) (return new) + +collapseRows :: Rows -> Root +collapseRows = + debug1 "collapseRows" "rs" $ \case [] -> undefined [child] -> child child:parents -> collapseRows $ appendChild parents child diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index 0b4a3f5..62df667 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -3,24 +3,21 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Write.HTML5 where -import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), forM_, mapM_, when) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Function (($), (.), id) -import Data.Functor ((<$>)) +import Data.Function (($), (.)) import Data.Functor.Compose (Compose(..)) +import Data.Int (Int) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) -import Data.Ord (Ord(..)) +import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..)) import Data.String (String, IsString(..)) -import Data.Text (Text) -import Data.TreeSeq.Strict (Tree(..),Trees) import Prelude (Num(..), undefined, error) import Text.Blaze ((!)) import Text.Blaze.Html (Html) @@ -28,26 +25,26 @@ import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S import qualified Data.List as List import qualified Data.Sequence as Seq -import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as HA --- import Debug.Trace (trace) +import qualified Text.Blaze.Html5.Attributes as HA -import Text.Blaze.Utils import Language.TCT +import Language.TCT.Debug +import Language.TCT.Write.Plain (int) +import Text.Blaze.Utils import qualified Language.TCT.Write.Plain as Plain -html5Document :: TCTs -> Html +html5Document :: Trees (Cell Node) -> Html html5Document body = do H.docType H.html $ do H.head $ do H.meta ! HA.httpEquiv "Content-Type" ! HA.content "text/html; charset=UTF-8" - whenJust (tokensTitle body) $ \ts -> + whenJust (titleFrom body) $ \t -> H.title $ - H.toMarkup $ Plain.text def $ List.head $ toList ts + H.toMarkup $ Plain.text def t -- link ! rel "Chapter" ! title "SomeTitle"> H.link ! HA.rel "stylesheet" ! HA.type_ "text/css" @@ -59,193 +56,232 @@ html5Document body = do H.a ! HA.id ("line-1") $ return () html5Body +titleFrom :: Roots -> Maybe Root +titleFrom tct = + List.find (\case + Tree (unCell -> NodeHeader HeaderSection{}) _ts -> True + _ -> False) tct >>= + \case + Tree (unCell -> NodeHeader (HeaderSection _lvl)) + (Seq.viewl -> title:<_) -> Just title + _ -> Nothing + -- * Type 'Html5' type Html5 = StateMarkup State () +instance IsString Html5 where + fromString = mapM_ html5ify + +html5 :: H.ToMarkup a => a -> Html5 +html5 = Compose . return . H.toMarkup + -- ** Type 'State' data State = State - { state_pos :: Pos - } + { state_pos :: Pos + , state_indent :: Int + , state_italic :: Bool + } deriving (Eq, Show) instance Default State where def = State - { state_pos = pos1 + { state_pos = pos1 + , state_indent = 1 + , state_italic = False } +instance Pretty State -- * Class 'Html5ify' class Html5ify a where html5ify :: a -> Html5 -instance Html5ify H.Markup where - html5ify = Compose . return -instance Html5ify Html5 where - html5ify = id instance Html5ify () where html5ify = mempty instance Html5ify Char where - html5ify = html5ify . H.toMarkup -instance Html5ify Text where - html5ify = html5ify . H.toMarkup -instance Html5ify TL.Text where - html5ify = html5ify . H.toMarkup + html5ify = \case + '\n' -> do + (indent, lnum) <- + liftStateMarkup $ do + s@State{state_pos=Pos line _col, state_indent} <- S.get + S.put $ s{state_pos=Pos (line + 1) state_indent} + return (state_indent, line + 1) + html5 '\n' + H.a ! HA.id ("line-"<>attrify lnum) $$ return () + html5 $ List.replicate (indent - 1) ' ' + c -> do + liftStateMarkup $ S.modify $ \s@State{state_pos=Pos line col} -> + s{state_pos=Pos line (col + 1)} + html5 c instance Html5ify String where - html5ify = html5ify . H.toMarkup -instance Html5ify (Trees (Cell Key) Tokens) where html5ify = mapM_ html5ify -instance Html5ify (Tree (Cell Key) Tokens) where - html5ify = \case - TreeN (Cell bp ep k) ts -> html5ify (Cell bp ep (k,ts)) - Tree0 ts -> html5ify ts -instance Html5ify a => Html5ify (Cell a) where - html5ify (Cell next@(Pos line col) ep a) = do - prev@(Pos lineLast colLast) <- liftStateMarkup $ S.gets state_pos - case () of - _ | lineLast < line -> do - forM_ [lineLast+1..line] $ \lnum -> do - html5ify '\n' +instance Html5ify TL.Text where + html5ify t + | TL.null t = mempty + | otherwise = + let (h,ts) = TL.span (/='\n') t in + case TL.uncons ts of + Nothing -> do + liftStateMarkup $ S.modify $ \s@State{state_pos=Pos line col} -> + s{state_pos=Pos line (col + int (TL.length h))} + html5 h + Just (_n,ts') -> do + html5 h + -- NOTE: useless to increment the pos_column for h, + -- since the following '\n' will reset the pos_column. + html5ify '\n' + html5ify ts' +instance Html5ify Pos where + html5ify new@(Pos lineNew colNew) = do + old@(Pos lineOld colOld) <- + liftStateMarkup $ do + s <- S.get + S.put s{state_pos=new} + return $ state_pos s + case lineOld`compare`lineNew of + LT -> do + forM_ [lineOld+1..lineNew] $ \lnum -> do + html5 '\n' H.a ! HA.id ("line-"<>attrify lnum) $$ return () - html5ify $ Text.replicate (col - 1) " " - _ | lineLast == line && colLast <= col -> do - html5ify $ Text.replicate (col - colLast) " " - _ -> error $ "html5ify: non-ascending positions: " - <> "\n prev: " <> show prev - <> "\n next: " <> show next - -- liftStateMarkup $ S.modify $ \s -> s{state_pos=bp} - liftStateMarkup $ S.modify $ \s -> s{state_pos=ep} - html5ify a -instance Html5ify (Key, Trees (Cell Key) Tokens) where - html5ify (key, ts) = - case key of - KeyPara -> html5ify ts - KeyColon n wh -> html5Key "" "" n wh ":" "" "colon" - KeyGreat n wh -> html5Key "" "" n wh ">" "" "great" - KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal" - KeyBar n wh -> html5Key "" "" n wh "|" "" "bar" - KeyDot n -> html5Key "" "" n "" "." "" "dot" - KeyDash -> html5Key "" "" "" "" "-" " " "dash" - KeyDashDash -> html5Key "" "" "" "" "--" " " "dashdash" - KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash" - KeyLower name attrs -> do - H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $$ do - H.span ! HA.class_ "key-mark" $$ html5ify '<' - H.span ! HA.class_ "key-name" $$ html5ify name + html5 $ List.replicate (colNew - 1) ' ' + EQ | colOld <= colNew -> do + html5 $ List.replicate (colNew - colOld) ' ' + _ -> error $ "html5ify: non-ascending Pos:" + <> "\n old: " <> show old + <> "\n new: " <> show new +instance Html5ify Roots where + html5ify = mapM_ html5ify +instance Html5ify Root where + html5ify (Tree (Cell bp _ep nod) ts) = do + html5ify bp + case nod of + NodeGroup -> html5ify ts + NodeToken t -> html5ify t + NodePara -> do + ind <- + liftStateMarkup $ do + s <- S.get + S.put $ s{state_indent = pos_column bp} + return $ state_indent s + r <- html5ify ts + liftStateMarkup $ S.modify $ \s -> s{state_indent=ind} + return r + NodeText t -> do + ind <- + liftStateMarkup $ do + s <- S.get + S.put $ s{state_indent = pos_column bp} + return $ state_indent s + r <- html5ify t + liftStateMarkup $ S.modify $ \s -> s{state_indent=ind} + return r + NodeHeader hdr -> + case hdr of + HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon" + HeaderGreat n wh -> html5Header "" "" n wh ">" "" "great" + HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal" + HeaderBar n wh -> html5Header "" "" n wh "|" "" "bar" + HeaderDot n -> html5Header "" "" n "" "." "" "dot" + HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash" + HeaderDash -> html5Header "" "" "" "" "-" " " "dash" + HeaderDashDash -> html5Header "" "" "" "" "--" " " "dashdash" + HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash" + HeaderSection lvl -> do + H.section $$ do + H.span ! HA.class_ "section-title" $$ do + H.span ! HA.class_ "section-mark" $$ do + html5ify $ List.replicate lvl '#' + case Seq.viewl ts of + title :< _ -> h lvl $$ html5ify title + _ -> return () + html5ify $ + case Seq.viewl ts of + _ :< ts' -> ts' + _ -> ts + where + h 1 = H.h1 + h 2 = H.h2 + h 3 = H.h3 + h 4 = H.h4 + h 5 = H.h5 + h 6 = H.h6 + h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n) + h _ = undefined + where + html5Header :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5 + html5Header markBegin whmb name whn markEnd whme cl = do + H.span ! HA.class_ (mconcat $ ["header header-",cl] <> + if TL.null name then [] else [" header-name-",attrify name]) $$ do + when (markBegin/="") $ + H.span ! HA.class_ "header-mark" $$ html5ify markBegin + html5ify whmb + when (name/="") $ + H.span ! HA.class_ "header-name" $$ html5ify name + html5ify whn + when (markEnd/="") $ + H.span ! HA.class_ "header-mark" $$ html5ify markEnd + html5ify whme + H.span ! HA.class_ "header-value" $$ + html5ify ts + NodePair pair -> + case pair of + PairElem name attrs -> do + H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do + H.span ! HA.class_ "pair-open" $$ o + when (not $ null ts) $ do + H.span ! HA.class_ "pair-content" $$ html5ify ts + H.span ! HA.class_ "pair-close" $$ c + where + html5Name = + H.span ! HA.class_ "elem-name" $$ + html5ify name + o,c :: Html5 + (o,c) + | null ts = + ( "<"<>html5Name<>html5ify attrs<>"/>" + , mempty ) + | otherwise = + ( "<"<>html5Name<>html5ify attrs<>">" + , "html5Name<>">" ) + _ -> do + H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do + H.span ! HA.class_ "pair-open" $$ html5ify o + H.span ! HA.class_ "pair-content" $$ + em $ + html5ify ts + H.span ! HA.class_ "pair-close" $$ html5ify c + where + (o,c) | null ts = pairBordersWithoutContent pair + | otherwise = pairBorders pair + where + em :: Html5 -> Html5 + em h = + case pair of + p | p == PairSlash + || p == PairFrenchquote + || p == PairDoublequote -> do + State{..} <- liftStateMarkup $ S.get + liftStateMarkup $ S.modify $ \s -> s{state_italic = not state_italic} + r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h + liftStateMarkup $ S.modify $ \s -> s{state_italic} + return r + _ -> h + NodeLower name attrs -> do + H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do + H.span ! HA.class_ "header-mark" $$ html5ify '<' + H.span ! HA.class_ "header-name" $$ html5ify name html5ify attrs html5ify ts - KeySection lvl -> do - H.section $$ do - H.span ! HA.class_ "section-title" $$ do - H.span ! HA.class_ "section-mark" $$ do - html5ify $ Text.replicate lvl "#" - case Seq.viewl ts of - Tree0 title :< _ -> h lvl $$ html5ify title - _ -> return () - html5ify $ - case Seq.viewl ts of - Tree0{} :< ts' -> ts' - _ -> ts - where - h 1 = H.h1 - h 2 = H.h2 - h 3 = H.h3 - h 4 = H.h4 - h 5 = H.h5 - h 6 = H.h6 - h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n) - h _ = undefined - where - html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html5 - html5Key markBegin whmb name whn markEnd whme cl = do - H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $$ do - when (markBegin/="") $ - H.span ! HA.class_ "key-mark" $$ html5ify markBegin - html5ify whmb - when (name/="") $ - H.span ! HA.class_ "key-name" $$ html5ify name - html5ify whn - when (markEnd/="") $ - H.span ! HA.class_ "key-mark" $$ html5ify markEnd - html5ify whme - H.span ! HA.class_ "key-value" $$ - html5ify ts -instance Html5ify Tokens where - html5ify = mapM_ html5ify instance Html5ify Token where - html5ify (TreeN (Cell bp ep p) ts) = do - case p of - PairElem name attrs -> do - H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do - html5ify $ Cell bp bp{columnPos = columnPos bp + lenO} () - when (lenO > 0) $ - H.span ! HA.class_ "pair-open" $$ o - when (not $ Seq.null ts) $ - H.span ! HA.class_ "pair-content" $$ html5ify ts - html5ify $ Cell ep{columnPos = columnPos ep - lenC} ep () - when (lenC > 0) $ - H.span ! HA.class_ "pair-close" $$ c - where - html5Name = - H.span ! HA.class_ "elem-name" $$ - html5ify name - lenName = Text.length name - lenAttrs = sum $ (<$> attrs) $ \(elemAttr_white,ElemAttr{..}) -> - Text.length elemAttr_white + - Text.length elemAttr_name + - Text.length elemAttr_open + - Text.length elemAttr_value + - Text.length elemAttr_close - (lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0) - | otherwise = (1+lenName+lenAttrs+1,2+lenName+1) - o,c :: Html5 - (o,c) | Seq.null ts = - ( "<"<>html5Name<>html5ify attrs<>"/>" - , mempty ) - | otherwise = - ( "<"<>html5Name<>html5ify attrs<>">" - , "html5Name<>">" ) - _ -> do - let (o,c) = pairBorders p ts - H.span ! HA.class_ ("pair-"<>fromString (show p)) $$ do - html5ify $ Cell bp bp{columnPos = columnPos bp + Text.length o} () - H.span ! HA.class_ "pair-open" $$ html5ify o - H.span ! HA.class_ "pair-content" $$ html5ify ts - html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep () - H.span ! HA.class_ "pair-close" $$ html5ify c - html5ify (Tree0 tok) = do - -- html5ify $ Cell bp ep () + html5ify tok = case tok of - TokenPhrases ps -> html5ify ps - TokenRaw t -> html5ify t - {-do - lin <- S.get - let lines = Text.splitOn "\n" txt - let lnums = html5ify : - [ \line -> do - html5ify '\n' - H.a ! HA.id ("line-"<>attrify lnum) $$ return () - html5ify indent - html5ify line - | lnum <- [lin+1..] - ] - S.put (lin - 1 + List.length lines) - return $ mconcat $ List.zipWith ($) lnums lines - -} + TokenText t -> html5ify t TokenTag v -> H.span ! HA.class_ "tag" $$ do H.span ! HA.class_ "tag-open" $$ html5ify '#' html5ify v - TokenEscape c -> html5ify $ ('\\' :) . pure <$> c - TokenLink (Cell bp ep lnk) -> do - html5ify $ Cell bp ep () - H.a ! HA.href (attrify lnk) $$ - html5ify lnk -instance Html5ify Phrases where - html5ify = mapM_ html5ify -instance Html5ify Phrase where - html5ify p = - case p of - PhraseWord t -> html5ify t - PhraseWhite t -> html5ify t - PhraseOther t -> html5ify t + TokenEscape c -> html5ify ['\\', c] + TokenLink l -> do + H.a ! HA.href (attrify l) $$ + html5ify l instance Html5ify ElemAttrs where html5ify = mapM_ html5ify instance Html5ify (White,ElemAttr) where @@ -257,18 +293,3 @@ instance Html5ify (White,ElemAttr) where H.span ! HA.class_ "attr-value" $$ html5ify elemAttr_value html5ify elemAttr_close - --- * Utilities - -tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens -tokensTitle tct = - List.find (\case - TreeN (unCell -> KeySection{}) _ts -> True - _ -> False) tct >>= - \case - TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title - _ -> Nothing - -html5Spaces :: Column -> Html5 -html5Spaces 0 = return () -html5Spaces sp = H.span $$ html5ify $ Text.replicate sp " " diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index fb37399..20fee68 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -11,31 +11,25 @@ import Data.Char (Char) import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Function (($), (.)) +import Data.Function (($)) import Data.Functor ((<$>)) -import Data.Int (Int64) +import Data.Int (Int) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) -import Data.Ord (Ord(..)) +import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq, ViewL(..)) +import Data.Sequence (Seq) import Data.String (String, IsString(..)) -import Data.Text (Text) -import Data.TreeSeq.Strict (Tree(..),Trees) import Data.Tuple (fst) -import Prelude (Num(..), undefined, Integral(..)) +import Prelude (Num(..), error) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S -import qualified Data.Sequence as Seq -import qualified Data.Text as Text +import qualified Data.List as List import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB --- import Language.TCT.Tree -import Language.TCT.Token -import Language.TCT.Cell -import Language.TCT.Elem -import Language.TCT.Read.Token +import Language.TCT +import Language.TCT.Utils -- * Type 'Plain' type Plain = S.State State TLB.Builder @@ -43,7 +37,7 @@ type Plain = S.State State TLB.Builder -- associate mappend calls to the right. -- NOTE: (Semigroup.<>) associates to the right. instance IsString Plain where - fromString = return . fromString + fromString = plainify instance Semigroup Plain where (<>) = liftA2 (<>) instance Monoid Plain where @@ -56,16 +50,21 @@ runPlain p s = TLB.toLazyText $ fst $ S.runState p s text :: Plainify a => State -> a -> TL.Text text st a = runPlain (plainify a) st +plainDocument :: Roots -> TL.Text +plainDocument = text def + -- ** Type 'State' data State = State { state_escape :: Bool -- FIXME: useful? , state_pos :: Pos + , state_indent :: Int } deriving (Eq, Show) instance Default State where def = State { state_escape = True , state_pos = pos1 + , state_indent = 1 } -- * Class 'Plainify' @@ -74,105 +73,102 @@ class Plainify a where instance Plainify () where plainify = mempty instance Plainify Char where - plainify = return . TLB.singleton + plainify = \case + '\n' -> do + S.modify $ \s@State{state_pos=Pos line _col, state_indent} -> + s{state_pos=Pos (line + 1) state_indent} + indent <- S.gets state_indent + return $ TLB.singleton '\n' <> fromString (List.replicate (indent - 1) ' ') + c -> do + S.modify $ \s@State{state_pos=Pos line col} -> + s{state_pos=Pos line (col + 1)} + return $ TLB.singleton c instance Plainify String where - plainify = return . fromString -instance Plainify Text where - plainify = plainify . TL.fromStrict -instance Plainify TL.Text where - plainify = return . TLB.fromLazyText -instance Plainify a => Plainify (Cell a) where - plainify (Cell _bp@(Pos line col) ep a) = do - Pos lineLast colLast <- S.gets state_pos - case () of - _ | lineLast < line -> do - S.modify $ \s -> s{state_pos=ep} - plainify (Text.replicate (line - lineLast - 1) "\n") - <> plainify (Text.replicate (col - 1) " ") - <> plainify a - _ | lineLast == line && colLast <= col -> do - S.modify $ \s -> s{state_pos=ep} - plainify (Text.replicate (col - colLast) " ") - <> plainify a - _ -> undefined -instance Plainify (Trees (Cell Key) Tokens) where plainify = foldMap plainify -instance Plainify (Tree (Cell Key) Tokens) where - plainify = \case - TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts)) - Tree0 ts -> plainify ts -instance Plainify (Key, Trees (Cell Key) Tokens) where - plainify (key, ts) = - case key of - KeyColon n wh -> textKey n wh ":" - KeyGreat n wh -> textKey n wh ">" - KeyEqual n wh -> textKey n wh "=" - KeyBar n wh -> textKey n wh "|" - KeyDash -> textKey "" "" "- " - KeyDashDash -> textKey "" "" "-- " - KeyLower name attrs -> - "<" <> - plainify name <> - plainify attrs <> - plainify ts - KeySection lvl -> - plainify (TL.replicate (int64 lvl) "#") <> - case Seq.viewl ts of - Tree0 title :< ts' -> - plainify title <> - plainify ts' - _ -> plainify ts - KeyDotSlash p -> - plainify ("./"::TL.Text) <> - plainify p <> - plainify ts - where - textKey :: Text -> White -> TL.Text -> Plain - textKey name wh mark = - plainify name <> - plainify wh <> - plainify mark <> - plainify ts -instance Plainify Tokens where +instance Plainify TL.Text where + plainify t + | TL.null t = mempty + | otherwise = + let (h,ts) = TL.span (/='\n') t in + case TL.uncons ts of + Nothing -> do + S.modify $ \s@State{state_pos=Pos line col} -> + s{state_pos=Pos line (col + int (TL.length h))} + return $ TLB.fromLazyText h + Just (_n,ts') -> + return (TLB.fromLazyText h) <> + -- NOTE: useless to increment the pos_column for h, + -- since the following '\n' will reset the pos_column. + plainify '\n' <> + plainify ts' +instance Plainify Pos where + plainify new@(Pos lineNew colNew) = do + old@(Pos lineOld colOld) <- S.gets state_pos + S.modify $ \s -> s{state_pos=new} + case lineOld`compare`lineNew of + LT -> + return $ + fromString (List.replicate (lineNew - lineOld) '\n') <> + fromString (List.replicate (colNew - 1) ' ') + EQ | colOld <= colNew -> + return $ + fromString (List.replicate (colNew - colOld) ' ') + _ -> error $ "plainify: non-ascending Pos:" + <> "\n old: " <> show old + <> "\n new: " <> show new +instance Plainify Roots where plainify = foldMap plainify +instance Plainify Root where + plainify (Tree (Cell bp _ep nod) ts) = + plainify bp <> + case nod of + NodePara -> do + ind <- S.gets state_indent + S.modify $ \s -> s{state_indent = pos_column bp} + r <- plainify ts + S.modify $ \s -> s{state_indent=ind} + return r + NodeGroup -> plainify ts + NodeHeader h -> plainify h <> plainify ts + NodeToken t -> plainify t + NodeText t -> do + ind <- S.gets state_indent + S.modify $ \s -> s{state_indent = pos_column bp} + r <- plainify t + S.modify $ \s -> s{state_indent=ind} + return r + NodePair p -> + plainify o <> plainify ts <> plainify c + where (o,c) | null ts = pairBordersWithoutContent p + | otherwise = pairBorders p + NodeLower n as -> + "<" <> plainify n <> plainify as <> plainify ts +instance Plainify Header where + plainify hdr = + case hdr of + HeaderColon n wh -> plainify n <> plainify wh <> ":" + HeaderGreat n wh -> plainify n <> plainify wh <> ">" + HeaderEqual n wh -> plainify n <> plainify wh <> "=" + HeaderBar n wh -> plainify n <> plainify wh <> "|" + HeaderDot n -> plainify n <> "." + HeaderBrackets n -> "[" <> plainify n <> "]" + HeaderDash -> "- " + HeaderDashDash -> "-- " + HeaderSection lvl -> plainify (List.replicate lvl '#') + HeaderDotSlash n -> "./" <> plainify n instance Plainify Token where plainify = \case - TreeN (Cell bp ep k) ts -> - plainify (Cell bp ep ()) <> - plainify o <> plainify ts <> plainify c - where (o,c) = pairBorders k ts - Tree0 tok -> - -- plainify (Cell bp ep ()) <> - case tok of - TokenPhrases p -> plainify p - TokenRaw t -> plainify t - {- TODO: remove - lnum <- S.get - let lines = Text.splitOn "\n" txt - S.put (lnum - 1 + List.length lines) - return $ - case lines of - [] -> undefined - (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls) - -} - TokenTag v -> plainify $ ("#"<>) <$> v - TokenEscape c -> do - esc <- S.gets state_escape - if esc - then plainify $ (('\\' :) . pure) <$> c - else plainify c - TokenLink lnk -> plainify lnk -instance Plainify Phrases where - plainify = foldMap plainify -instance Plainify Phrase where - plainify p = - case p of - PhraseWord t -> plainify t - PhraseWhite t -> plainify t - PhraseOther t -> plainify t + TokenText t -> plainify t + TokenTag t -> plainify '#' <> plainify t + TokenLink l -> plainify l + TokenEscape c -> do + esc <- S.gets state_escape + if esc + then plainify ['\\', c] + else plainify c instance Plainify ElemAttrs where plainify = foldMap plainify -instance Plainify (Text,ElemAttr) where +instance Plainify (White,ElemAttr) where plainify (elemAttr_white,ElemAttr{..}) = mconcat $ plainify <$> [ elemAttr_white @@ -182,28 +178,6 @@ instance Plainify (Text,ElemAttr) where , elemAttr_close ] -{- --- * Class 'Textify' -class Textify a where - plainify :: a -> TL.Text -instance Textify Text where - plainify = TL.fromStrict -instance Textify TL.Text where - plainify = id -instance Textify Tokens where - plainify = foldMap plainify -instance Textify Token where - plainify = \case - TreeN (unCell -> p) ts -> plainify o<>plainify ts<>plainify c - where (o,c) = pairBorders p ts - Tree0 (unCell -> t) -> - case t of - TokenPlain txt -> plainify txt - TokenTag v -> "#"<>plainify v - TokenEscape c -> TL.singleton c -- plainify $ Text.pack ['\\',c] - TokenLink lnk -> plainify lnk --} - -- * Class 'RackUpLeft' class RackUpLeft a where rackUpLeft :: a -> S.State (Maybe Pos) a @@ -213,8 +187,8 @@ instance RackUpLeft Pos where Nothing -> return pos Just (Pos l0 c0) -> return Pos - { linePos = linePos - l0 + 1 - , columnPos = columnPos - c0 + 1 + { pos_line = pos_line - l0 + 1 + , pos_column = pos_column - c0 + 1 } instance RackUpLeft (Cell a) where rackUpLeft (Cell bp ep a) = do @@ -227,48 +201,8 @@ instance RackUpLeft (Cell a) where <*> pure a instance RackUpLeft a => RackUpLeft (Seq a) where rackUpLeft = mapM rackUpLeft -instance (RackUpLeft k, RackUpLeft a) => RackUpLeft (Tree k a) where - rackUpLeft = \case - Tree0 a -> Tree0 <$> rackUpLeft a - TreeN k ts -> TreeN <$> rackUpLeft k <*> rackUpLeft ts - -{- --- * Utilities -plainifyIndentCell :: (Pos,Pos) -> Plain -plainifyIndentCell (Pos lineLast colLast,Pos line col) - | lineLast < line = - return $ - TL.replicate (int64 $ line - (lineLast+1)) "\n" <> - TL.replicate (int64 $ col - 1) " " - | lineLast == line && colLast <= col = - return $ - TL.replicate (int64 $ col - colLast) " " - | otherwise = undefined - --- ** 'Tree' - -treePosLastCell :: - Trees (Cell k) Tokens -> - Trees (Pos,Cell k) (Pos,Tokens) -treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1) - where - go :: Tree (Cell k) Tokens -> - S.State Pos (Tree (Pos,Cell k) (Pos,Tokens)) - go (Tree0 ts) = do - lastPos <- S.get - case Seq.viewr ts of - EmptyR -> - return $ Tree0 (lastPos,ts) - _ :> r -> do - S.put $ posEndTree r - return $ Tree0 (lastPos,ts) - go (TreeN p ts) = do - lastPos <- S.get - S.put $ posEndCell p - ts' <- go`mapM`ts - return $ TreeN (lastPos,p) ts' --} - --- ** 'Int64' -int64 :: Integral i => i -> Int64 -int64 = fromInteger . toInteger +instance RackUpLeft a => RackUpLeft (Tree a) where + rackUpLeft (Tree n ts) = + Tree + <$> rackUpLeft n + <*> rackUpLeft ts diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 2c790ce..3c3520a 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -40,19 +40,19 @@ import qualified Data.TreeSeq.Strict as TreeSeq import Debug.Trace (trace) import Text.Show (show) -xmlDocument :: TCTs -> XMLs +xmlDocument :: Roots -> XMLs xmlDocument trees = -- (`S.evalState` def) $ case Seq.viewl trees of - TreeN (unCell -> KeySection{}) vs :< ts -> + Tree (unCell -> NodeHeader HeaderSection{}) vs :< ts -> case spanlTokens vs of (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') -> let vs'' = case Seq.findIndexL (\case - TreeN (unCell -> KeyColon "about" _) _ -> True + Tree (unCell -> NodeHeader (HeaderColon "about" _)) _ -> True _ -> False) vs' of - Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs' + Nothing -> Tree (Cell bp bp $ NodeHeader $ HeaderColon "about" "") mempty <| vs' Just{} -> vs' in xmlify def { inh_titles = titles @@ -101,42 +101,42 @@ instance Default Inh where -- * Class 'Xmlify' class Xmlify a where xmlify :: Inh -> a -> XMLs -instance Xmlify TCTs where +instance Xmlify Roots where xmlify inh_orig = go inh_orig where - go :: Inh -> TCTs -> XMLs + go :: Inh -> Roots -> XMLs go inh trees = case Seq.viewl trees of - TreeN (Cell bp ep (KeyBar n _)) _ :< _ + Tree (Cell bp ep (NodeHeader (HeaderBar n _))) _ :< _ | (body,ts) <- spanlBar n trees , not (null body) -> (<| go inh ts) $ - TreeN (Cell bp ep "artwork") $ + Tree (Cell bp ep "artwork") $ maybe id (\v -> (Tree0 (XmlAttr (Cell bp ep ("type", v))) <|)) (mimetype n) $ body >>= xmlify inh{inh_tree0=[]} - TreeN key@(unCell -> KeyColon n _) cs :< ts - | (cs',ts') <- spanlKeyColon n ts + Tree nod@(unCell -> NodeHeader (HeaderColon n _)) cs :< ts + | (cs',ts') <- spanlHeaderColon n ts , not (null cs') -> - go inh $ TreeN key (cs<>cs') <| ts' + go inh $ Tree nod (cs<>cs') <| ts' - TreeN (Cell bp ep KeyBrackets{}) _ :< _ + Tree (Cell bp ep (NodeHeader HeaderBrackets{})) _ :< _ | (rl,ts) <- spanlBrackets trees , not (null rl) -> (<| go inh ts) $ - TreeN (Cell bp ep "references") $ + Tree (Cell bp ep "references") $ rl >>= xmlify inh_orig - _ | (ul,ts) <- spanlItems (==KeyDash) trees - , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ul -> + _ | (ul,ts) <- spanlItems (==HeaderDash) trees + , Tree (Cell bp ep _) _ :< _ <- Seq.viewl ul -> (<| go inh ts) $ - TreeN (Cell bp ep "ul") $ + Tree (Cell bp ep "ul") $ ul >>= xmlify inh{inh_tree0=List.repeat xmlPara} - _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trees - , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ol -> + _ | (ol,ts) <- spanlItems (\case HeaderDot{} -> True; _ -> False) trees + , Tree (Cell bp ep _) _ :< _ <- Seq.viewl ol -> (<| go inh ts) $ - TreeN (Cell bp ep "ol") $ + Tree (Cell bp ep "ol") $ ol >>= xmlify inh{inh_tree0=List.repeat xmlPara} t@(Tree0 toks) :< ts -> @@ -154,124 +154,155 @@ instance Xmlify TCTs where go inh ts _ -> mempty -instance Xmlify TCT where - xmlify inh tr = - case tr of - TreeN (Cell bp ep KeySection{}) ts -> - let (attrs,body) = partitionAttributesChildren ts in - let inh' = inh - { inh_tree0 = xmlTitle : List.repeat xmlPara - , inh_figure = True - } in - Seq.singleton $ - TreeN (Cell bp ep "section") $ - xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <> - xmlify inh' body - - TreeN key@(Cell bp ep (KeyColon kn _)) ts -> - let (attrs,body) = partitionAttributesChildren ts in - let inh' = inh { inh_tree0 = - case kn of - "about" -> xmlTitle : xmlTitle : List.repeat xmlPara - "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara - "serie" -> List.repeat xmlName - "author" -> List.repeat xmlName - "editor" -> List.repeat xmlName - "org" -> List.repeat xmlName - _ -> [] - } in - case () of - _ | kn == "about" -> xmlAbout inh' key attrs body - - _ | inh_figure inh && not (kn`List.elem`elems) -> +instance Xmlify Root where + xmlify inh (Tree (Cell bp ep nod) ts) = + case nod of + NodeHeader hdr -> + case hdr of + HeaderSection{} -> + let (attrs,body) = partitionAttributesChildren ts in + let inh' = inh + { inh_tree0 = xmlTitle : List.repeat xmlPara + , inh_figure = True + } in Seq.singleton $ - TreeN (Cell bp ep "figure") $ - xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <> - case toList body of - [Tree0{}] -> xmlify inh'{inh_tree0 = List.repeat xmlPara} body - _ -> xmlify inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body - - _ -> Seq.singleton $ xmlKey inh' key attrs body - - TreeN key ts -> Seq.singleton $ xmlKey inh key mempty ts - - Tree0 ts -> xmlify inh ts + Tree (Cell bp ep "section") $ + xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <> + xmlify inh' body + HeaderColon kn _wh -> + let (attrs,body) = partitionAttributesChildren ts in + let inh' = inh { inh_tree0 = + case kn of + "about" -> xmlTitle : xmlTitle : List.repeat xmlPara + "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara + "serie" -> List.repeat xmlName + "author" -> List.repeat xmlName + "editor" -> List.repeat xmlName + "org" -> List.repeat xmlName + _ -> [] + } in + case () of + _ | kn == "about" -> xmlAbout inh' nod attrs body + _ | inh_figure inh && not (kn`List.elem`elems) -> + Seq.singleton $ + Tree (Cell bp ep "figure") $ + xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <> + case toList body of + [Tree0{}] -> xmlify inh'{inh_tree0 = List.repeat xmlPara} body + _ -> xmlify inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body + _ -> Seq.singleton $ x_Header inh' n + HeaderGreat n _wh -> x_Header inh' n + HeaderEqual n _wh -> x_Header inh' n + HeaderBar n _wh -> x_Header inh' n + HeaderDot _n -> Tree (cell "li") $ xmlify inh ts + HeaderDash -> Tree (cell "li") $ xmlify inh ts + HeaderDashDash -> Tree0 $ XmlComment $ cell $ + -- debug1_ ("TS", ts) $ + -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $ + Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing + {- + TreeSeq.mapAlsoNode + (cell1 . unCell) + (\_k -> fmap $ + TreeSeq.mapAlsoNode + (cell1 . unCell) + (\_k' -> cell1 . unCell)) <$> ts + -} + HeaderLower n as -> Tree (cell "artwork") $ xmlify inh ts + HeaderBrackets ident -> + let inh' = inh{inh_figure = False} in + let (attrs',body) = partitionAttributesChildren ts in + Tree (cell "reference") $ + xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <> + xmlify inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body + HeaderDotSlash p -> + Tree (cell "include") $ + xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <> + xmlify inh ts + NodePair pair -> + case pair of + PairBracket | to <- Plain.text def ts + , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> + Seq.singleton . + Tree (cell "rref") $ + xmlAttrs [cell ("to",TL.toStrict to)] + PairStar -> Seq.singleton . Tree (cell "b") $ xmlify inh ts + PairSlash -> Seq.singleton . Tree (cell "i") $ xmlify inh ts + PairBackquote -> Seq.singleton . Tree (cell "code") $ xmlify inh ts + PairFrenchquote -> + Seq.singleton . + Tree (cell "q") $ + xmlify inh ts + {- + case ts of + (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) -> + case Seq.viewr ls of + m :> Tree0 (Cell br er (TokenPlain r)) -> + xmlify inh $ + Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l))) + <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r)))) + _ -> + xmlify inh $ + Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls + (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) -> + xmlify inh $ + rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r))) + _ -> xmlify inh ts + -} + PairHash -> + Seq.singleton . + Tree (cell "ref") $ + xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)] + PairElem name attrs -> + Seq.singleton . + Tree (cell $ xmlLocalName name) $ + xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) -> + cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <> + xmlify inh ts + _ -> + let (o,c) = pairBorders p ts in + Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell bp bp o) `unionXml` + xmlify inh ts `unionXml` + Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell ep ep c) + NodeToken tok -> + case tok of + TokenEscape c -> Seq.singleton $ Tree0 $ XmlPhrases $ phrasify c + TokenText t -> Seq.singleton $ Tree0 $ XmlText t + TokenTag t -> Seq.singleton $ Tree (cell "ref") $ xmlAttrs [cell ("to",t)] + TokenLink lnk -> Seq.singleton $ Tree (cell "eref") $ xmlAttrs [cell ("to",lnk)] + where + cell :: a -> Cell a + cell = Cell bp ep + x_Header :: Inh -> Text -> XML + x_Header inh' n = + Tree (cell $ xmlLocalName n) $ + xmlAttrs attrs <> + xmlify inh' ts + + + instance Xmlify Tokens where xmlify inh toks = case Seq.viewl toks of - TreeN (Cell bp _ep PairParen) paren - :< (Seq.viewl -> TreeN (Cell bb eb PairBracket) bracket + Tree (Cell bp _ep (NodePair PairParen)) paren + :< (Seq.viewl -> Tree (Cell bb eb (NodePair PairBracket)) bracket :< ts) -> (<| xmlify inh ts) $ case bracket of (toList -> [Tree0 (Cell bl el (TokenLink lnk))]) -> - TreeN (Cell bp eb "eref") $ + Tree (Cell bp eb "eref") $ xmlAttrs [Cell bl el ("to",lnk)] <> xmlify inh paren _ -> - TreeN (Cell bp eb "rref") $ + Tree (Cell bp eb "rref") $ xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.text def bracket)] <> xmlify inh paren t :< ts -> xmlify inh t `unionXml` xmlify inh ts Seq.EmptyL -> mempty +{- instance Xmlify Token where - xmlify inh (TreeN (Cell bp ep p) ts) = - case p of - PairBracket | to <- Plain.text def ts - , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> - Seq.singleton . - TreeN (cell "rref") $ - xmlAttrs [cell ("to",TL.toStrict to)] - PairStar -> Seq.singleton . TreeN (cell "b") $ xmlify inh ts - PairSlash -> Seq.singleton . TreeN (cell "i") $ xmlify inh ts - PairBackquote -> Seq.singleton . TreeN (cell "code") $ xmlify inh ts - PairFrenchquote -> - Seq.singleton . - TreeN (cell "q") $ - xmlify inh ts - {- - case ts of - (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) -> - case Seq.viewr ls of - m :> Tree0 (Cell br er (TokenPlain r)) -> - xmlify inh $ - Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l))) - <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r)))) - _ -> - xmlify inh $ - Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls - (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) -> - xmlify inh $ - rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r))) - _ -> xmlify inh ts - -} - PairHash -> - Seq.singleton . - TreeN (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)] - PairElem name attrs -> - Seq.singleton . - TreeN (cell $ xmlLocalName name) $ - xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) -> - cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <> - xmlify inh ts - _ -> - let (o,c) = pairBorders p ts in - Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell bp bp o) `unionXml` - xmlify inh ts `unionXml` - Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell ep ep c) - where - cell :: a -> Cell a - cell = Cell bp ep + xmlify inh (Tree (Cell bp ep (NodePair p)) ts) = xmlify inh (Tree0 tok) = do - case tok of - TokenPhrases ps -> xmlify inh $ ps - TokenEscape c -> Seq.singleton $ Tree0 $ XmlPhrases $ phrasify c - TokenRaw t -> Seq.singleton $ Tree0 $ XmlText t - TokenTag t -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)] - TokenLink (Cell bp ep lnk) -> - xmlify (Cell bp ep ()) <> - Seq.singleton (TreeN (cell "eref") $ xmlAttrs [cell ("to",lnk)]) where cell :: a -> Cell a cell = Cell bp ep @@ -285,6 +316,7 @@ instance Xmlify Token where -} instance Xmlify (Cell Phrase) where xmlify _inh t = Seq.singleton $ Tree0 $ XmlPhrases $ Seq.singleton t +-} mimetype :: Text -> Maybe Text mimetype "hs" = Just "text/x-haskell" @@ -294,7 +326,7 @@ mimetype "shellscript" = Just "text/x-shellscript" mimetype _ = Nothing xmlPhantom :: XmlName -> Pos -> XMLs -> XML -xmlPhantom n bp = TreeN (Cell bp bp n) +xmlPhantom n bp = Tree (Cell bp bp n) xmlPara :: Pos -> XMLs -> XML xmlPara = xmlPhantom "para" xmlTitle :: Pos -> XMLs -> XML @@ -305,62 +337,21 @@ xmlName bp ts = xmlPhantom "name" bp ts xmlAbout :: Inh -> - Cell Key -> Seq (Cell (XmlName, Text)) -> - TCTs -> XMLs -xmlAbout inh key attrs body = + Cell Header -> Seq (Cell (XmlName, Text)) -> + Roots -> XMLs +xmlAbout inh hdr attrs body = Seq.singleton $ - xmlKey inh key attrs $ + xmlHeader inh hdr attrs $ case Seq.viewl (inh_titles inh) of (Seq.viewl -> (posTree -> bt) :< _) :< _ -> ((<$> inh_titles inh) $ \title -> - TreeN (Cell bt bt $ KeyColon "title" "") $ + Tree (Cell bt bt $ NodeHeader $ HeaderColon "title" "") $ Seq.singleton $ Tree0 title) <> body _ -> body -xmlKey :: Inh -> Cell Key -> Seq (Cell (XmlName, Text)) -> TCTs -> XML -xmlKey inh (Cell bp ep key) attrs ts = - 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 -> TreeN (cell "li") $ xmlify inh ts - KeyDash -> TreeN (cell "li") $ xmlify inh ts - KeyDashDash -> Tree0 $ XmlComment $ cell $ TL.toStrict com - where - com :: TL.Text - com = - trace ("TS: "<>show ts) $ - trace ("RS: "<>show (S.evalState (Plain.rackUpLeft ts) Nothing)) $ - Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing - {- - TreeSeq.mapAlsoNode - (cell1 . unCell) - (\_k -> fmap $ - TreeSeq.mapAlsoNode - (cell1 . unCell) - (\_k' -> cell1 . unCell)) <$> ts - -} - KeyLower n as -> TreeN (cell "artwork") $ xmlify inh ts - KeyBrackets ident -> - let inh' = inh{inh_figure = False} in - let (attrs',body) = partitionAttributesChildren ts in - TreeN (cell "reference") $ - xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <> - xmlify inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body - KeyDotSlash p -> - TreeN (cell "include") $ - xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <> - xmlify inh ts - where - cell :: a -> Cell a - cell = Cell bp ep - d_key :: Text -> XML - d_key n = - TreeN (cell $ xmlLocalName n) $ - xmlAttrs attrs <> - xmlify inh ts +xmlHeader :: Inh -> Cell Header -> Seq (Cell (XmlName, Text)) -> Roots -> XML +xmlHeader inh (Cell bp ep hdr) attrs ts = xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs xmlAttrs = (Tree0 . XmlAttr <$>) @@ -385,29 +376,29 @@ unionXml x y = (Seq.EmptyR, _) -> y (_, Seq.EmptyL) -> x -spanlBar :: Name -> TCTs -> (TCTs, TCTs) -spanlBar name = first unKeyBar . spanBar +spanlBar :: Name -> Roots -> (Roots, Roots) +spanlBar name = first unHeaderBar . spanBar where - unKeyBar :: TCTs -> TCTs - unKeyBar = (=<<) $ \case - TreeN (unCell -> KeyBar{}) ts -> ts + unHeaderBar :: Roots -> Roots + unHeaderBar = (=<<) $ \case + Tree (unCell -> NodeHeader HeaderBar{}) ts -> ts _ -> mempty spanBar = Seq.spanl $ \case - TreeN (unCell -> KeyBar n _) _ | n == name -> True + Tree (unCell -> NodeHeader (HeaderBar n _)) _ | n == name -> True _ -> False -spanlItems :: (Key -> Bool) -> TCTs -> (TCTs, TCTs) -spanlItems liKey ts = +spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots) +spanlItems liHeader ts = let (lis, ts') = spanLIs ts in foldl' accumLIs (mempty,ts') lis where - spanLIs :: TCTs -> (TCTs, TCTs) + spanLIs :: Roots -> (Roots, Roots) spanLIs = Seq.spanl $ \case - TreeN (unCell -> liKey -> True) _ -> True - Tree0 toks -> + Tree (unCell -> NodeHeader (liHeader -> True)) _ -> True + Tree (NodeToken toks) _ -> (`any` toks) $ \case - TreeN (unCell -> PairElem "li" _) _ -> True + TreeN (unCell -> NodePair (PairElem "li" _)) _ -> True _ -> False {- case toList $ Seq.dropWhileR (isTokenWhite . unCell) toks of @@ -415,14 +406,14 @@ spanlItems liKey ts = _ -> False -} _ -> False - accumLIs :: (TCTs,TCTs) -> TCT -> (TCTs,TCTs) + accumLIs :: (Roots,Roots) -> Root -> (Roots,Roots) accumLIs acc@(oks,kos) t = case t of - TreeN (unCell -> liKey -> True) _ -> (oks|>t,kos) + Tree (unCell -> NodeHeader (liHeader -> True)) _ -> (oks|>t,kos) Tree0 toks -> let (ok,ko) = (`Seq.spanl` toks) $ \case - TreeN (unCell -> PairElem "li" _) _ -> True + Tree (unCell -> NodePair (PairElem "li" _)) _ -> True -- (isTokenWhite -> True) -> True -- TODO: see if this is still useful _ -> False in ( if null ok then oks else oks|>Tree0 (rmTokenWhite ok) @@ -436,20 +427,20 @@ spanlItems liKey ts = _ -> True -} -spanlKeyColon :: Name -> TCTs -> (TCTs, TCTs) -spanlKeyColon name = +spanlHeaderColon :: Name -> Roots -> (Roots, Roots) +spanlHeaderColon name = Seq.spanl $ \case - TreeN (unCell -> KeyBar n _) _ -> n == name - TreeN (unCell -> KeyGreat n _) _ -> n == name + Tree (unCell -> NodeHeader (HeaderBar n _)) _ -> n == name + Tree (unCell -> NodeHeader (HeaderGreat n _)) _ -> n == name _ -> False -spanlBrackets :: TCTs -> (TCTs, TCTs) +spanlBrackets :: Roots -> (Roots, Roots) spanlBrackets = Seq.spanl $ \case - TreeN (unCell -> KeyBrackets{}) _ -> True + Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True _ -> False -spanlTokens :: TCTs -> (Seq Tokens, TCTs) +spanlTokens :: Roots -> (Seq Tokens, Roots) spanlTokens = first ((\case Tree0 ts -> ts @@ -458,7 +449,7 @@ spanlTokens = Tree0{} -> True _ -> False) -getAttrId :: TCTs -> Text +getAttrId :: Roots -> Text getAttrId ts = case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of Just (Tree0 toks) -> TL.toStrict $ Plain.text def toks @@ -476,15 +467,15 @@ defXmlAttr a@(unCell -> (k, _v)) as = Just _idx -> as Nothing -> a <| as -partitionAttributesChildren :: TCTs -> (Seq (Cell (XmlName, Text)), TCTs) +partitionAttributesChildren :: Roots -> (Seq (Cell (XmlName, Text)), Roots) partitionAttributesChildren ts = (attrs,cs) where (as,cs) = (`Seq.partition` ts) $ \case - TreeN (unCell -> KeyEqual{}) _cs -> True + Tree (unCell -> NodeHeader HeaderEqual{}) _cs -> True _ -> False attrs = attr <$> as attr = \case - TreeN (Cell bp ep (KeyEqual n _wh)) a -> + Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a -> Cell bp ep (xmlLocalName n, v) where v = TL.toStrict $ diff --git a/Text/Blaze/Utils.hs b/Text/Blaze/Utils.hs index b801e09..24d0f7a 100644 --- a/Text/Blaze/Utils.hs +++ b/Text/Blaze/Utils.hs @@ -111,9 +111,11 @@ instance Monad (StateMarkup st) where case ma >>= B.Empty . a2csmb of B.Append _ma (B.Empty csmb) -> B.Append ma <$> getCompose csmb - _ -> undefined + _ -> undefined -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'. +{- NOTE: the 'st' may need to use the 'String', so no such instance. instance IsString (StateMarkup st ()) where fromString = Compose . return . fromString +-} -- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one. ($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index e8f1984..8833519 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where @@ -29,6 +30,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL import qualified System.Environment as Env import qualified Text.Blaze.Renderer.Utf8 as Blaze import qualified Text.Blaze.Utils as Blaze @@ -46,7 +48,8 @@ import qualified Text.Blaze.HTML5 as Blaze.HTML5 -} -- import qualified Language.RNC.Write as RNC import qualified Language.TCT as TCT --- import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 +import qualified Language.TCT.Write.Plain as TCT.Write.Plain +import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 -- import qualified Language.TCT.Write.XML as TCT.Write.XML import qualified Text.Megaparsec as P @@ -88,11 +91,14 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = hPutStrLn stderr "### XML ###" let xml = TCT.Write.XML.xmlDocument tct hPrint stderr $ Tree.Pretty xml + -} case format of + TctFormatPlain -> + TL.putStr $ + TCT.Write.Plain.plainDocument tct TctFormatHTML5 -> Blaze.renderMarkupToByteStringIO BS.putStr $ TCT.Write.HTML5.html5Document tct - -} {- mainWithCommand (CommandDTC ArgsDTC{..}) = readFile input $ \_fp txt -> @@ -227,10 +233,15 @@ pArgsTCT = -- *** Type 'TctFormat' data TctFormat - = TctFormatHTML5 + = TctFormatPlain + | TctFormatHTML5 pTctFormat :: Parser TctFormat pTctFormat = + flag TctFormatPlain TctFormatPlain + [ long "plain" + , help "Render as plain text." + ] <|> flag TctFormatHTML5 TctFormatHTML5 [ long "html5" , help "Render as HTML5." diff --git a/hdoc.cabal b/hdoc.cabal index 0707fbb..a39fd4d 100644 --- a/hdoc.cabal +++ b/hdoc.cabal @@ -22,6 +22,11 @@ Source-Repository head location: git://git.autogeree.net/hdoc type: git +Flag debug + Default: False + Description: Turn on debugging settings. + Manual: True + Flag prof Default: False Description: Turn on profiling settings. @@ -31,14 +36,14 @@ Library exposed-modules: Data.Locale Data.TreeSeq.Strict - Data.TreeSeq.Strict.Zipper - Language.DTC.Document - Language.DTC.Anchor - Language.DTC.Read.TCT - Language.DTC.Sym - Language.DTC.Write.HTML5 - Language.DTC.Write.Plain - Language.DTC.Write.XML + -- Data.TreeSeq.Strict.Zipper + -- Language.DTC.Document + -- Language.DTC.Anchor + -- Language.DTC.Read.TCT + -- Language.DTC.Sym + -- Language.DTC.Write.HTML5 + -- Language.DTC.Write.Plain + -- Language.DTC.Write.XML Language.RNC.Fixity Language.RNC.Sym Language.RNC.Write @@ -50,11 +55,11 @@ Library Language.TCT.Read.Elem Language.TCT.Read.Token Language.TCT.Read.Tree - Language.TCT.Token Language.TCT.Tree + Language.TCT.Debug Language.TCT.Write.HTML5 Language.TCT.Write.Plain - Language.TCT.Write.XML + -- Language.TCT.Write.XML Language.XML Text.Blaze.DTC Text.Blaze.DTC.Attributes @@ -73,6 +78,9 @@ Library -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-warn-tabs + -- -fhide-source-paths + if flag(debug) + cpp-options: -DDEBUG if flag(prof) cpp-options: -DPROFILING ghc-options: -fprof-auto @@ -109,6 +117,7 @@ Test-Suite hdoc-test -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-warn-tabs + -- -fhide-source-paths hs-source-dirs: test main-is: Main.hs other-modules: @@ -140,7 +149,6 @@ Executable hdoc MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude - OverloadedStrings PatternGuards PolyKinds Rank2Types @@ -149,13 +157,15 @@ Executable hdoc StandaloneDeriving TupleSections TypeApplications - TypeFamilies TypeOperators ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-warn-tabs + -- -fhide-source-paths + if flag(debug) + cpp-options: -DDEBUG if flag(prof) cpp-options: -DPROFILING ghc-options: -fprof-auto -rtsopts @@ -181,8 +191,6 @@ Executable hdoc -- , safe >= 0.2 , safe-exceptions , semigroups - -- , symantic-document - -- , symantic-grammar , strict , hdoc , text diff --git a/style/tct-html5.css b/style/tct-html5.css index ac9ee8b..2071997 100644 --- a/style/tct-html5.css +++ b/style/tct-html5.css @@ -28,36 +28,32 @@ section { color:#8B4513; } -.key > .key-name { +.header > .header-name { //color:#C4451D; color:darkcyan; } -.key .key-mark { +.header .header-mark { color:gray; //color:#CD853F; //color:green; //font-weight:bold; } -.key.key-colon > .key-name { +.header.header-colon > .header-name { color:#C4451D; } -.key.key-dash > .key-mark { +.header.header-dash > .header-mark { color:#C4451D; font-weight:bold; } -.key.key-equal { +.header.header-equal { color:gray; } -.key.key-lower { +.header.header-lower { color:black; } .pair-PairStar > .pair-content { font-weight:bold; } -.pair-elem-i > .pair-content, -.pair-PairSlash > .pair-content { - font-style:italic; - } .pair-PairUnderscore > .pair-content { text-decoration:underline; } @@ -77,10 +73,10 @@ section { //color:#000080; color:darkgrey; } -.key.key-name-i > .key-value { +.header.header-name-i > .header-value { font-style:italic; } -.key.key-name-dashdash > .key-value { +.header.header-dashdash > .header-value { color:darkgrey; } .elem-name { -- 2.42.0 From 4e9b3679ea9c8c96cca85dc5d71832e873b101ac Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 3 Feb 2018 23:55:02 +0100 Subject: [PATCH 12/16] Fix NodePara parsing. --- Language/TCT/Cell.hs | 11 +- Language/TCT/Debug.hs | 36 ++- Language/TCT/Read.hs | 17 +- Language/TCT/Read/Cell.hs | 5 +- Language/TCT/Read/Elem.hs | 12 +- Language/TCT/Read/Token.hs | 195 ++++++------- Language/TCT/Read/Tree.hs | 14 +- Language/TCT/Tree.hs | 308 +++++++++++++-------- Language/TCT/Utils.hs | 12 + Language/TCT/Write/HTML5.hs | 28 +- Language/TCT/Write/Plain.hs | 96 ++++--- Language/TCT/Write/XML.hs | 528 ++++++++++++++++++------------------ Language/XML.hs | 31 ++- Text/Blaze/Utils.hs | 2 +- exe/cli/Main.hs | 4 +- 15 files changed, 721 insertions(+), 578 deletions(-) create mode 100644 Language/TCT/Utils.hs diff --git a/Language/TCT/Cell.hs b/Language/TCT/Cell.hs index ee7e6e3..c5292b4 100644 --- a/Language/TCT/Cell.hs +++ b/Language/TCT/Cell.hs @@ -36,6 +36,7 @@ instance Show Pos where showsPrec 11 pos_line . showChar ':' . showsPrec 11 pos_column +instance Pretty Pos pos1 :: Pos pos1 = Pos 1 1 @@ -65,15 +66,17 @@ instance Pretty a => Pretty (Cell a) where s <- pretty m return $ "Cell "<>show bp<>":"<>show ep<>" "<>s instance (FromPad a, Semigroup a) => Semigroup (Cell a) where - Cell bx (Pos lx cx) x <> Cell (Pos ly cy) ey y = + Cell bx ex x <> Cell by ey y = Cell bx ey $ - x <> fromPad pad <> y + x<>fromPad (Pos lines columns)<>y where - pad = Pos lyx $ if lyx == 0 then cy - cx else cy - lyx = ly - lx + lines = pos_line by - pos_line ex + columns = pos_column by - pos_column (if lines <= 0 then ex else bx) +{- instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where mempty = cell0 mempty mappend = (<>) +-} cell0 :: a -> Cell a cell0 = Cell mempty mempty diff --git a/Language/TCT/Debug.hs b/Language/TCT/Debug.hs index c61fddd..d4556f0 100644 --- a/Language/TCT/Debug.hs +++ b/Language/TCT/Debug.hs @@ -15,6 +15,7 @@ import Data.Function (($), (.)) import Data.Int (Int) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) +import Data.Ord (Ord) import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq) import Data.String (String) @@ -39,21 +40,21 @@ debug0 m a = Trace.trace (m <> ": " <> R.runReader (pretty a) 2) a debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r) debug1 nf na f a = - (\r -> Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) r) $ - (Trace.trace (nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) f) + (\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $ + (Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) f) a debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r debug1_ nf (na,a) r = - Trace.trace (nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) $ - Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) $ + Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) $ + Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ r debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r) debug2 nf na nb f a b = - (\r -> Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) r) $ + (\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $ Trace.trace - (nf <> ":" + ("[ " <> nf <> ":" <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 ) f a b @@ -61,14 +62,21 @@ debug2 nf na nb f a b = debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r debug2_ nf (na,a) (nb,b) r = Trace.trace - (nf <> ":" + ("[ " <> nf <> ":" <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 ) $ - Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) $ + Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ r -debugParser :: Show a => String -> P.Parsec e s a -> P.Parsec e s a +debugParser :: + ( P.Stream s + , P.ShowToken (P.Token s) + , P.ShowErrorComponent e + , Ord e + , Show a + ) => + String -> P.Parsec e s a -> P.Parsec e s a debugParser = P.dbg #else import Data.Function (id) @@ -93,7 +101,14 @@ debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) debug2_ _nf _a _b = id {-# INLINE debug2_ #-} -debugParser :: Show a => String -> P.Parsec e s a -> P.Parsec e s a +debugParser :: + ( P.Stream s + , P.ShowToken (P.Token s) + , P.ShowErrorComponent e + , Ord e + , Show a + ) => + String -> P.Parsec e s a -> P.Parsec e s a debugParser _m = id {-# INLINE debugParser #-} #endif @@ -103,6 +118,7 @@ class Pretty a where pretty :: a -> R.Reader Int String default pretty :: Show a => a -> R.Reader Int String pretty = return . show +instance Pretty Bool instance Pretty Int instance Pretty Text instance Pretty TL.Text diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs index e83e033..23061c1 100644 --- a/Language/TCT/Read.hs +++ b/Language/TCT/Read.hs @@ -28,7 +28,7 @@ import Language.TCT.Read.Token -- | Parsing is done in two phases: -- -- 1. indentation-sensitive parsing on 'TL.Text' --- 2. pair-sensitive parsing on some 'NodeText's resulting of 1. +-- 2. Pair-sensitive parsing on some 'NodeText's resulting of 1. readTrees :: FilePath -> TL.Text -> Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node)) @@ -42,14 +42,23 @@ readTrees inp txt = do go parent t@(Tree c@(Cell bn en nod) ts) = case nod of NodeLower{} -> Right t + -- NOTE: preserve NodeText "" + NodeText n | TL.null n -> Right t NodeText n -> case parent of - NodeHeader HeaderBar{} -> Right t - NodeHeader HeaderEqual{} -> Right t + NodeHeader HeaderBar{} -> Right t + NodeHeader HeaderEqual{} -> Right t + NodeHeader HeaderDashDash{} -> Right t _ -> do toks <- parseTokens <$> parseLexemes inp (Cell bn en n) return $ case toList toks of [tok] -> tok _ -> Tree (Cell bn en NodeGroup) toks - _ -> Tree c <$> traverse (go nod) ts + _ -> Tree c <$> traverse (go nod') ts + where + -- NOTE: skip parent 'Node's whose semantic does not change 'NodeText' + nod' = case nod of + NodeGroup -> parent + NodePara -> parent + _ -> nod diff --git a/Language/TCT/Read/Cell.hs b/Language/TCT/Read/Cell.hs index b8d1a9c..6dbe56d 100644 --- a/Language/TCT/Read/Cell.hs +++ b/Language/TCT/Read/Cell.hs @@ -24,6 +24,9 @@ import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import Language.TCT.Cell +import Language.TCT.Debug + +instance Pretty P.Pos -- * Type 'Parser' -- | Convenient alias. @@ -85,7 +88,7 @@ runParserOnCell inp p (Cell bp _ep s) = , P.stateTabWidth = indent , P.stateTokensProcessed = 0 } - where indent = P.mkPos $ pos_column bp + where indent = debug0 "runParserOnCell: indent" $ P.mkPos $ pos_column bp -- * Type 'StreamCell' -- | Wrap 'TL.Text' to have a 'P.Stream' instance diff --git a/Language/TCT/Read/Elem.hs b/Language/TCT/Read/Elem.hs index cd5b4e0..64c3017 100644 --- a/Language/TCT/Read/Elem.hs +++ b/Language/TCT/Read/Elem.hs @@ -31,9 +31,13 @@ p_Spaces1 = P.takeWhile1P (Just "Space") Char.isSpace p_HSpaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_HSpaces = P.takeWhileP (Just "HSpace") (==' ') p_Digits :: P.Tokens s ~ TL.Text => Parser e s TL.Text -p_Digits = P.takeWhile1P (Just "Digit") Char.isDigit +p_Digits = P.takeWhileP (Just "Digit") Char.isDigit +p_Digits1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_Digits1 = P.takeWhile1P (Just "Digit1") Char.isDigit p_AlphaNums :: P.Tokens s ~ TL.Text => Parser e s TL.Text -p_AlphaNums = P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum +p_AlphaNums = P.takeWhileP (Just "AlphaNum") Char.isAlphaNum +p_AlphaNums1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text +p_AlphaNums1 = P.takeWhile1P (Just "AlphaNum1") Char.isAlphaNum {- -- NOTE: could be done with TL.Text, which has a less greedy (<>). p_Word :: Parser e Text Text @@ -49,7 +53,7 @@ p_Word = debugParser "Word" $ P.try p_take <|> p_copy return w p_copy = (<>) - <$> p_AlphaNums + <$> p_AlphaNums1 <*> P.option "" (P.try $ (<>) <$> ((Text.pack <$>) $ P.some $ P.char '_' <|> P.char '-') @@ -74,7 +78,7 @@ p_ElemOpen = debugParser "ElemOpen" $ <* P.char '>' p_ElemName :: P.Tokens s ~ TL.Text => Parser e s ElemName -p_ElemName = p_AlphaNums +p_ElemName = p_AlphaNums1 -- TODO: namespace p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index 2abfe13..0a8b5dc 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -21,7 +21,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>)) +import Data.Sequence (ViewL(..), ViewR(..), (<|)) import Data.String (String) import Data.TreeSeq.Strict (Tree(..), Trees) import Data.Tuple (fst,snd) @@ -53,48 +53,36 @@ type Tokens = Trees (Cell Node) -- | An opened 'Pair' and its content so far. type Opening = (Cell Pair,Tokens) -appendToken :: Pairs -> Tree (Cell Node) -> Pairs -appendToken (ts,[]) tok = (ts|>tok,[]) -appendToken (ts,(p0,t0):ps) tok = (ts,(p0,t0|>tok):ps) - -appendTokens :: Pairs -> Tokens -> Pairs -appendTokens (ts,[]) toks = (ts<>toks,[]) -appendTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0<>toks):ps) - --- | Appending 'TL.Text' is a special case --- to append at the 'TokenText' level is possible, --- instead of the higher 'NodeToken' level. -appendText :: Pairs -> Cell TL.Text -> Pairs -appendText ps tok = - case ps of - (ts,[]) -> (appendTokenText ts tok,[]) - (ts,(p0,ts0):pss) -> (ts,(p0,appendTokenText ts0 tok):pss) - -appendTokenText :: Tokens -> Cell TL.Text -> Tokens -appendTokenText ts (Cell bn en n) = - {- - | TL.null n = ts - | otherwise = -} - case Seq.viewr ts of - EmptyR -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n - is :> Tree (Cell bo _eo nod) st -> - case nod of - NodeToken (TokenText o) -> is |> i - where i = Tree (Cell bo en (NodeToken $ TokenText (o <> n))) st - _ -> ts |> Tree0 (Cell bn en $ NodeToken $ TokenText n) - -prependTokenText :: Tokens -> Cell TL.Text -> Tokens -prependTokenText ts (Cell bn en n) - {- - | TL.null n = ts - | otherwise-} = - case Seq.viewl ts of - EmptyL -> pure $ Tree0 $ Cell bn en $ NodeToken $ TokenText n - Tree (Cell _bo eo nod) st :< is -> - case nod of - NodeToken (TokenText o) -> i <| is - where i = Tree (Cell bn eo (NodeToken $ TokenText (n <> o))) st - _ -> Tree0 (Cell bn en $ NodeToken $ TokenText n) <| ts +appendPairsToken :: Pairs -> Tree (Cell Node) -> Pairs +appendPairsToken ps t = appendPairsTokens ps (pure t) + +appendPairsText :: Pairs -> Cell TL.Text -> Pairs +appendPairsText ps (Cell bp ep t) = + appendPairsToken ps $ + Tree0 $ Cell bp ep $ + NodeToken $ TokenText t + +appendPairsTokens :: Pairs -> Tokens -> Pairs +appendPairsTokens (ts,[]) toks = (ts`unionTokens`toks,[]) +appendPairsTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0`unionTokens`toks):ps) + +-- | Unify two 'Tokens', merging border 'TokenText's if any. +unionTokens :: Tokens -> Tokens -> Tokens +unionTokens x y = + case (Seq.viewr x, Seq.viewl y) of + (xs :> x0, y0 :< ys) -> + case (x0,y0) of + ( Tree (Cell bx _ex (NodeToken (TokenText tx))) sx + , Tree (Cell _by ey (NodeToken (TokenText ty))) sy ) -> + xs `unionTokens` + pure (Tree (Cell bx ey $ NodeToken $ TokenText $ tx <> ty) (sx<>sy)) `unionTokens` + ys + _ -> x <> y + (EmptyR, _) -> y + (_, EmptyL) -> x + +unionsTokens :: Foldable f => f Tokens -> Tokens +unionsTokens = foldl' unionTokens mempty openPair :: Pairs -> Cell Pair -> Pairs openPair (t,ps) p = (t,(p,mempty):ps) @@ -102,50 +90,41 @@ openPair (t,ps) p = (t,(p,mempty):ps) -- | Close a 'Pair' when there is a matching 'LexemePairClose'. closePair :: Pairs -> Cell Pair -> Pairs closePair ps@(_,[]) (Cell bp ep p) = -- debug0 "closePair" $ - appendText ps $ Cell bp ep $ snd $ pairBorders p + appendPairsText ps $ Cell bp ep $ + snd $ pairBordersDouble p closePair (t,(p1,t1):ts) p = -- debug0 "closePair" $ case (p1,p) of (Cell bx _ex (PairElem nx ax), Cell _by ey (PairElem ny ay)) | nx == ny -> - appendToken (t,ts) $ + appendPairsToken (t,ts) $ Tree (Cell bx ey $ NodePair $ PairElem nx as) t1 where as | null ay = ax | otherwise = ax<>ay (Cell bx _ex x, Cell _by ey y) | x == y -> - appendToken (t,ts) $ + appendPairsToken (t,ts) $ Tree (Cell bx ey $ NodePair x) t1 _ -> (`closePair` p) $ - appendTokens + appendPairsTokens (t,ts) (closeImpaired mempty (p1,t1)) -- | Close a 'Pair' when there is no matching 'LexemePairClose'. -closeImpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens -closeImpaired acc (Cell bp ep p,toks) = -- debug0 "closeImpaired" $ - case p of +closeImpaired :: Tokens -> (Cell Pair, Tokens) -> Tokens +closeImpaired acc (Cell bp ep pair, toks) = -- debug0 "closeImpaired" $ + case pair of -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'. - PairHash | Just (Cell _bt et t, ts) <- tagFrom $ toks <> acc -> - Tree0 (Cell bp et $ NodeToken $ TokenTag t) <| ts - {- - PairHash | (Tree0 (Cell bt et (TokenPlain t))) :< ts <- Seq.viewl $ toks <> acc -> - case Text.span isTagChar t of - ("",_) | Text.null t -> toksHash mempty <> toks <> acc - | otherwise -> Tree0 (Cell bp et (TokenTag t)) <| ts - (tag,t') -> - let len = Text.length tag in - Tree0 (Cell bp bt{columnPos = columnPos bt + len} (TokenTag tag)) <| - Tree0 (Cell bt{columnPos = columnPos bt + len + 1} et (TokenPlain t')) <| - ts - -} - _ -> prependTokenText (toks <> acc) toksHash + PairHash | Just (Cell _bt et tag, rest) <- tagFrom body -> + Tree0 (Cell bp et $ NodeToken $ TokenTag tag) <| rest + -- NOTE: use bp (not bt) to include the '#' + _ -> pure open `unionTokens` body where - toksHash :: Cell TL.Text - toksHash = Cell bp ep $ fst $ pairBorders p + body = toks `unionTokens` acc + open = Tree0 $ Cell bp ep $ NodeToken $ TokenText $ fst $ pairBordersDouble pair -- | Close remaining 'Pair's at end of parsing. closePairs :: Pairs -> Tokens closePairs (t0,ps) = -- debug0 "closePairs" $ - t0 <> foldl' closeImpaired mempty ps + t0 `unionTokens` foldl' closeImpaired mempty ps appendLexeme :: Lexeme -> Pairs -> Pairs appendLexeme lex acc = -- debug2 "appendLexeme" "lex" "acc" $ \lex acc -> @@ -153,26 +132,24 @@ appendLexeme lex acc = -- debug2 "appendLexeme" "lex" "acc" $ \lex acc -> LexemePairOpen ps -> foldl' open acc ps where -- NOTE: insert an empty node to encode , not - open a p@(Cell _bp ep (PairElem{})) = - openPair a p `appendToken` - (Tree0 $ Cell ep ep $ NodeToken $ TokenText "") + open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendPairsText` Cell ep ep "" open a p = openPair a p LexemePairClose ps -> foldl' closePair acc ps - LexemePairAny ps -> foldl' openPair acc ps + LexemePairAny ps -> foldl' openPair acc ps {- LexemePairAny ps -> - appendText acc $ sconcat $ - ((fst . pairBordersWithoutContent) <$>) <$> ps + appendPairsText acc $ sconcat $ + ((fst . pairBordersSingle) <$>) <$> ps -} - LexemePairBoth ps -> appendTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps - LexemeEscape c -> appendToken acc $ Tree0 $ NodeToken . TokenEscape <$> c - LexemeLink t -> appendToken acc $ Tree0 $ NodeToken . TokenLink <$> t + LexemePairBoth ps -> appendPairsTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps + LexemeEscape c -> appendPairsToken acc $ Tree0 $ NodeToken . TokenEscape <$> c + LexemeLink t -> appendPairsToken acc $ Tree0 $ NodeToken . TokenLink <$> t {-LexemeWhite (unCell -> "") -> acc-} -- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc - LexemeWhite t -> appendText acc t - LexemeAlphaNum t -> appendText acc t - LexemeOther t -> appendText acc t - LexemeTree t -> appendToken acc t + LexemeWhite t -> appendPairsText acc t + LexemeAlphaNum t -> appendPairsText acc t + LexemeOther t -> appendPairsText acc t + LexemeTree t -> appendPairsToken acc t LexemeEnd -> acc appendLexemes :: Pairs -> [Lexeme] -> Pairs @@ -345,28 +322,12 @@ p_Link = || c=='?' || c=='=' --- | Build 'Tokens' from many 'Token's. -tokens :: [Cell Token] -> Tokens -tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts - --- | Build 'Tokens' from one 'Token'. -tokens1 :: Tree (Cell Node) -> Tokens -tokens1 = Seq.singleton - -unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens)) -unTokenElem toks = - case toList $ {-Seq.dropWhileR isTokenWhite-} toks of - [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts)) - _ -> Nothing - -isTokenElem :: Tokens -> Bool -isTokenElem toks = - case toList $ {-Seq.dropWhileR isTokenWhite-} toks of - [Tree (unCell -> NodePair PairElem{}) _] -> True - _ -> False +pairBorders :: Foldable f => Pair -> f a -> (TL.Text,TL.Text) +pairBorders p ts | null ts = pairBordersSingle p + | otherwise = pairBordersDouble p -pairBordersWithoutContent :: Pair -> (TL.Text,TL.Text) -pairBordersWithoutContent = \case +pairBordersSingle :: Pair -> (TL.Text,TL.Text) +pairBordersSingle = \case PairElem n as -> ("<"<>n<>foldMap f as<>"/>","") where f (elemAttr_white,ElemAttr{..}) = @@ -375,10 +336,10 @@ pairBordersWithoutContent = \case elemAttr_open <> elemAttr_value <> elemAttr_close - p -> pairBorders p + p -> pairBordersDouble p -pairBorders :: Pair -> (TL.Text,TL.Text) -pairBorders = \case +pairBordersDouble :: Pair -> (TL.Text,TL.Text) +pairBordersDouble = \case PairElem n as -> ("<"<>n<>foldMap f as<>">","n<>">") where f (elemAttr_white,ElemAttr{..}) = elemAttr_white <> @@ -417,8 +378,8 @@ instance TagFrom Tokens where case tagFrom ns of Just (t1@(Cell b1 _e1 _), r1) | e0 == b1 -> Just (t0<>t1, r1) - _ -> Just (t0, n0 <| ns) - else Just (t0, n0 <| ns) + _ -> Just (t0, pure n0 `unionTokens` ns) + else Just (t0, pure n0 `unionTokens` ns) where n0 = (Tree0 $ NodeToken . TokenText <$> r0) _ -> Nothing _ -> Nothing @@ -440,3 +401,25 @@ isTagChar c = Char.DashPunctuation -> True Char.ConnectorPunctuation -> True _ -> False + +{- +-- | Build 'Tokens' from many 'Token's. +tokens :: [Cell Token] -> Tokens +tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts + +-- | Build 'Tokens' from one 'Token'. +tokens1 :: Tree (Cell Node) -> Tokens +tokens1 = Seq.singleton + +unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens)) +unTokenElem toks = + case toList $ {-Seq.dropWhileR isTokenWhite-} toks of + [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts)) + _ -> Nothing + +isTokenElem :: Tokens -> Bool +isTokenElem toks = + case toList $ {-Seq.dropWhileR isTokenWhite-} toks of + [Tree (unCell -> NodePair PairElem{}) _] -> True + _ -> False +-} diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index 91b652c..350b164 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -111,14 +111,14 @@ p_CellLower row = debugParser "CellLower" $ do let (o,_) = bs $ PairElem name attrs in Tree0 $ Cell pos p $ nod $ o<>t where - bs | hasContent = pairBorders - | otherwise = pairBordersWithoutContent - tree <- + bs | hasContent = pairBordersDouble + | otherwise = pairBordersSingle + cel <- P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|> P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|> P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|> (P.eof $> treeHere (Cell posClose posClose "")) - return $ tree : row + return $ cel : row where p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text) p_CellLine = p_Cell p_Line @@ -173,11 +173,9 @@ p_Row row = debugParser "Row" $ p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows p_Rows rows = p_Row [] >>= \row -> - let rows' = appendRow rows (List.reverse row) in + let rows' = rows `appendRow` List.reverse row in (P.eof $> rows') <|> (P.newline >> P.eof $> rows' <|> p_Rows rows') p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node)) -p_Trees = subTrees . collapseRows <$> p_Rows [root] - where - root = Tree0 (cell0 NodeGroup) +p_Trees = collapseRows <$> p_Rows initRows diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index b505ad0..f100627 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -12,12 +12,13 @@ import Data.Char (Char) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($)) +import Data.Functor ((<$>)) import Data.Int (Int) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ordering(..), Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence ((|>), (<|), ViewR(..)) +import Data.Sequence ((|>), ViewR(..)) import Data.TreeSeq.Strict (Tree(..), Trees) import Prelude (undefined, Num(..)) import System.FilePath (FilePath) @@ -26,12 +27,15 @@ import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text.Lazy as TL +import Language.TCT.Utils import Language.TCT.Cell import Language.TCT.Elem import Language.TCT.Debug -- * Type 'Root' --- | A single 'Tree' to rule all the 'Node's simplifies the navigation. +-- | A single 'Tree' to rule all the 'Node's +-- simplifies the navigation and transformations. +-- -- For error reporting, each 'Node' is annotated with a 'Cell' -- spanning over all its content (sub-'Trees' included). type Root = Tree (Cell Node) @@ -53,20 +57,22 @@ data Node | NodeGroup -- ^ node, group trees into a single tree, -- useful to return many trees when only one is expected deriving (Eq,Show) +instance Pretty Node -- * Type 'Header' data Header - = HeaderColon !Name !White -- ^ @name: @ - | HeaderEqual !Name !White -- ^ @name=@ - | HeaderBar !Name !White -- ^ @name|@ - | HeaderGreat !Name !White -- ^ @name>@ - | HeaderDot !Name -- ^ @1. @ + = HeaderColon !Name !White -- ^ @name: @ + | HeaderEqual !Name !White -- ^ @name=@ + | HeaderBar !Name !White -- ^ @name|@ + | HeaderGreat !Name !White -- ^ @name>@ + | HeaderBrackets !Name -- ^ @[name]@ + | HeaderDot !Name -- ^ @1. @ | HeaderDash -- ^ @- @ | HeaderDashDash -- ^ @-- @ | HeaderSection !LevelSection -- ^ @# @ - | HeaderBrackets !Name -- ^ @[name]@ | HeaderDotSlash !FilePath -- ^ @./file @ deriving (Eq, Ord, Show) +instance Pretty Header -- ** Type 'Name' type Name = TL.Text @@ -115,113 +121,199 @@ type Row = [Root] -- (hence to which the next line can append to). type Rows = [Root] +-- | Having an initial 'Root' simplifies 'appendRow': +-- one can always put the last 'Root' as a child to a previous one. +-- This 'Root' just has to be discarded by 'collapseRows'. +initRows :: Rows +initRows = [Tree0 (Cell p p NodeGroup)] + where p = pos1{pos_line= -1, pos_column=0} + -- NOTE: such that any following 'Root' + -- is 'NodePara' if possible, and always a child. + -- | @appendRow rows row@ appends @row@ to @rows@. -- -- [@rows@] parent 'Rows', from closest to farthest (non-strictly descending) -- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending) appendRow :: Rows -> Row -> Rows -appendRow [] row = List.reverse row -appendRow rows [] = rows -appendRow rows@(old@(Tree (Cell bo eo o) os):olds) - row@(new@(Tree (Cell bn en n) ns):news) = - debug2_ "appendRow" ("row",row) ("rows",rows) $ - case debug0 "colOld" (pos_column bo) `compare` - debug0 "colNew" (pos_column bn) of - LT -> mergeNodeText lt - EQ -> - mergeNodeText $ - case (o,n) of - (_, NodeHeader (HeaderSection secNew)) - | Just (secOld, s0:ss) <- collapseSection (pos_column bn) rows -> - case debug0 "secOld" secOld `compare` - debug0 "secNew" secNew of - LT -> appendRow (new:s0:ss) news - EQ -> appendRow (new:appendChild ss s0) news - GT -> gt - (NodeHeader HeaderSection{}, _) -> lt - (_, NodeText tn) | TL.null tn -> gt - (NodePara, _) | not newPara -> lt - _ | newPara -> gt - _ -> eq - GT -> gt +appendRow rows row = + debug2_ "appendRow" ("news",row) ("olds",rows) $ + case (row,rows) of + (_, []) -> undefined -- NOTE: cannot happen with initRows + ([], _) -> rows + (new@(Tree (Cell bn en n) ns):news, old@(Tree (Cell bo eo o) os):olds) -> + case debug0 "appendRow/colNew" (pos_column bn) `compare` + debug0 "appendRow/colOld" (pos_column bo) of + -- NOTE: new is vertically lower + LT -> + case (n,o) of + -- NOTE: merge adjacent NodeText + -- first + -- second + (NodeText tn, NodeText to) + | TL.null tn || TL.null to -> child + | not isNewPara && isIndented -> merge $ Tree t (os<>ns) + where + t = NodeText <$> Cell boNew eo (indent<>to) <> Cell bn en tn + boNew = bo{pos_column=pos_column bn} + indent = TL.replicate (int64 $ pos_column bo - pos_column bn) " " + -- | Whether the horizontal diff is made of spaces + isIndented = + debug0 "appendRow/isIndented" $ + case olds of + [] -> True + (unTree -> cell_end -> ep) : _ -> + case pos_line ep `compare` pos_line bo of + LT -> True + EQ -> pos_column ep <= pos_column bn + _ -> False + _ -> child + -- NOTE: new is vertically aligned + EQ -> + case (n,o) of + -- NOTE: preserve all NodeText "", but still split into two NodePara + (NodeText tn, NodeText to) + | TL.null tn || TL.null to -> child + | not isNewPara -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) + -- NOTE: HeaderSection can parent Nodes at the same level + (NodeHeader (HeaderSection lvlNew), _) + | Just (lvlOld, rows'@(old':olds')) <- collapseSection (pos_column bn) rows -> + if debug0 "appendRow/lvlNew" lvlNew + > debug0 "appendRow/lvlOld" lvlOld + then -- # old + -- ## new + {-concat-} List.reverse row <> rows' + else -- ## old or # old + -- # new # new + {-child old'-} appendRow (appendChild old' olds') row + -- NOTE: concat everything else following a HeaderSection. + (_, NodeHeader HeaderSection{}) -> concat + {- + (NodeHeader ho@HeaderGreat{}, NodeHeader hn) | ho == hn -> + debug "appendRow/HeaderGreat" $ appendRow rows news + -} + -- + _ -> replace + -- NOTE: new is vertically greater + GT -> + case (n,o) of + -- NOTE: keep NodeText "" out of old NodePara + (NodeText "", NodePara) -> child + -- NOTE: merge adjacent NodeText + (NodeText tn, NodeText to) -> + case isNewPara of + _ | TL.null tn || TL.null to -> child + -- old + -- + -- new + True -> appendRow (appendChild old olds) (shifted:news) + where + shifted = Tree (Cell bnNew en $ NodeText $ indent<>tn) (os<>ns) + bnNew = bn{pos_column=pos_column bo} + indent = TL.replicate (int64 $ pos_column bn - pos_column bo) " " + -- old + -- new + False -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) + -- + _ -> concat + where + isNewPara = pos_line bn - pos_line eo > 1 + concat = debug "appendRow/concat" $ List.reverse row <> rows + merge m = debug "appendRow/merge" $ appendRow (m : olds) news + child = debug "appendRow/child" $ appendRow (appendChild old olds) row + replace = debug "appendRow/replace" $ appendRow (new : appendChild old olds) news + +-- | Collapse downto any last HeaderSection, returning it and its level. +collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows) +collapseSection col = debug1 "collapseSection" "rows" go where - newPara = pos_line bn - pos_line eo > 1 - lt = debug "appendRow/lt" $ List.reverse row <> rows - eq = debug "appendRow/eq" $ appendRow (new : appendChild olds old) news - gt = debug "appendRow/gt" $ appendRow ( appendChild olds old) row - - -- | Find the first section (if any), returning its level, and the path collapsed upto it. - collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows) - collapseSection col xxs@(x:xs) | pos_column (cell_begin (unTree x)) == col = - case x of - Tree (unCell -> NodeHeader (HeaderSection lvl)) _ -> Just (lvl, xxs) - _ -> do - (lvl, cs) <- collapseSection col xs - return (lvl, appendChild cs x) - collapseSection _ _ = Nothing - - mergeNodeText :: Rows -> Rows - mergeNodeText rs - | newPara = rs - | otherwise = - case (o,n) of - (NodeText to, NodeText tn) - | null os - , not (TL.null to) - , not (TL.null tn) -> - -- debug "appendRow" "action" ("mergeNodeText"::TL.Text) $ - debug0 "mergeNodeText" $ - appendRow (merged : olds) news - where - merged = Tree (Cell bo en $ NodeText $ to<>tp<>tn) ns - tp = fromPad Pos - { pos_line = pos_line bn - pos_line eo - , pos_column = pos_column bn - pos_column bo - } - _ -> rs - -appendChild :: Rows -> Root -> Rows -appendChild rows new@(Tree (Cell bn en n) ns) = + go rows@(new@(unTree -> Cell bn _en n):olds) + | col == pos_column bn = + case n of + NodeHeader (HeaderSection lvl) -> return (lvl, rows) + _ -> (appendChild new <$>) <$> go olds + go _ = Nothing + +-- | Like 'appendRow', but without maintaining the appending, +-- hence collapsing all the 'Root's of the given 'Rows'. +-- +-- NOTE: 'initRows' MUST have been the first 'Rows' +-- before calling 'appendRow' on it to get the given 'Rows'. +collapseRows :: Rows -> Roots +collapseRows = debug1 "collapseRows" "rows" $ \case + [] -> mempty + new@(Tree (Cell bn _en n) _ns):olds -> + case olds of + [] -> subTrees new + old@(Tree (Cell bo eo o) _os):oldss -> + case debug0 "colNew" (pos_column bn) `compare` + debug0 "colOld" (pos_column bo) of + -- NOTE: new is vertically aligned + EQ -> + case (n,o) of + (NodeHeader (HeaderSection lvlNew), _) + | Just (lvlOld, old':olds') <- collapseSection (pos_column bn) olds -> + if debug0 "collapseRows/lvlNew" lvlNew + > debug0 "collapseRows/lvlOld" lvlOld + then -- # old + -- ## new + {-child new-} collapseRows $ appendChild new $ old':olds' + else -- ## old or # old + -- # new # new + {-child old'-} collapseRows $ new:appendChild old' olds' + -- NOTE: in case of alignment, HeaderSection is parent. + (_, NodeHeader HeaderSection{}) -> child + -- NOTE: merge within old NodePara. + (_, NodePara{}) | not isNewPara -> child + -- + _ -> child2 + -- NOTE: new is either vertically lower or greater + _ -> child + where + isNewPara = pos_line bn - pos_line eo > 1 + child, child2 :: Roots + child = debug "collapseRows/child" $ collapseRows $ appendChild new olds + child2 = debug "collapseRows/child2" $ collapseRows $ appendChild new $ appendChild old oldss + +-- | Put a 'Root' as a child of the head 'Root'. +-- +-- NOTE: 'appendChild' is where 'NodePara' may be introduced. +-- NOTE: any NodeText/NodeText merging must have been done before. +appendChild :: Root -> Rows -> Rows +appendChild new@(Tree (Cell bn en n) _ns) rows = debug2_ "appendChild" ("new",Seq.singleton new) ("rows",rows) $ case rows of - [] -> [new] + [] -> return new old@(Tree (Cell bo eo o) os) : olds -> - (: olds) $ - if newPara - then - case (o,n) of - (NodePara,NodePara) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] - (NodePara,_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,Tree (Cell bn en NodePara) $ return new] - (_,NodePara) -> Tree (Cell bo en o) $ os|>new - (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] - _ -> Tree (Cell bo en o) $ os|> newTree - else - case (o,n) of - (NodePara,NodePara) -> Tree (Cell bo en NodePara) $ os<>ns - (NodePara,_) -> Tree (Cell bo en NodePara) $ os|>new - (_,NodePara) -> Tree (Cell bo en NodePara) $ old<|ns - (NodeText{},_) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new] - _ -> - case Seq.viewr os of - EmptyR -> Tree (Cell bo en o) $ return newTree - ls :> Tree (Cell br _er r) rs -> - case r of - NodePara - | pos_column br == pos_column bn - -> Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new) - | otherwise -> Tree (Cell bo en o) $ os |> newTree - _ -> Tree (Cell bo en o) $ os |> new + case (n,o) of + -- NOTE: never put a NodePara directly within another + (NodePara, NodePara) -> child2 + -- NOTE: never put a child to NodeText + (_, NodeText{}) -> child2 + -- NOTE: NodeText can begin a NodePara + (NodeText tn, _) | not $ TL.null tn -> + case o of + -- NOTE: no NodePara within those + NodeHeader HeaderEqual{} -> child + NodeHeader HeaderBar{} -> child + NodeHeader HeaderDashDash{} -> child + -- NOTE: NodePara within those + NodePara | isNewPara -> para + NodeHeader{} -> para + NodeGroup -> para + _ -> child + _ -> child where - newPara = pos_line bn - pos_line eo > 1 - newTree = - case n of - NodeHeader{} -> new - NodeLower{} -> new - _ -> Tree (Cell bn en NodePara) (return new) - -collapseRows :: Rows -> Root -collapseRows = - debug1 "collapseRows" "rs" $ \case - [] -> undefined - [child] -> child - child:parents -> collapseRows $ appendChild parents child + isNewPara = pos_line bn - pos_line eo > 1 + child = Tree (Cell bo en o) (os |> new) : olds + child2 = appendChild new $ appendChild old olds + para = Tree (Cell bn en NodePara) (return new) : rows + +-- | Return a 'Tree' from a 'Cell' node and 'subTrees', +-- while adjusting the node's 'cell_end' +-- with the last 'Tree' of the 'subTrees'. +tree :: Cell a -> Trees (Cell a) -> Tree (Cell a) +tree (Cell bp ep a) ts = Tree (Cell bp ep' a) ts + where + ep' = case Seq.viewr ts of + EmptyR -> ep + _ :> (unTree -> cell_end -> p) -> p diff --git a/Language/TCT/Utils.hs b/Language/TCT/Utils.hs new file mode 100644 index 0000000..77edc39 --- /dev/null +++ b/Language/TCT/Utils.hs @@ -0,0 +1,12 @@ +module Language.TCT.Utils where + +import Data.Function ((.)) +import Data.Int (Int, Int64) +import Prelude (Num(..), Integral(..)) + +-- * 'Int' +int :: Integral i => i -> Int +int = fromInteger . toInteger + +int64 :: Integral i => i -> Int64 +int64 = fromInteger . toInteger diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index 62df667..2b8230c 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -31,7 +31,7 @@ import qualified Text.Blaze.Html5.Attributes as HA import Language.TCT import Language.TCT.Debug -import Language.TCT.Write.Plain (int) +import Language.TCT.Utils import Text.Blaze.Utils import qualified Language.TCT.Write.Plain as Plain @@ -107,7 +107,7 @@ instance Html5ify Char where H.a ! HA.id ("line-"<>attrify lnum) $$ return () html5 $ List.replicate (indent - 1) ' ' c -> do - liftStateMarkup $ S.modify $ \s@State{state_pos=Pos line col} -> + liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + 1)} html5 c instance Html5ify String where @@ -119,7 +119,7 @@ instance Html5ify TL.Text where let (h,ts) = TL.span (/='\n') t in case TL.uncons ts of Nothing -> do - liftStateMarkup $ S.modify $ \s@State{state_pos=Pos line col} -> + liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + int (TL.length h))} html5 h Just (_n,ts') -> do @@ -153,7 +153,9 @@ instance Html5ify Root where html5ify bp case nod of NodeGroup -> html5ify ts + ---------------------- NodeToken t -> html5ify t + ---------------------- NodePara -> do ind <- liftStateMarkup $ do @@ -161,8 +163,9 @@ instance Html5ify Root where S.put $ s{state_indent = pos_column bp} return $ state_indent s r <- html5ify ts - liftStateMarkup $ S.modify $ \s -> s{state_indent=ind} + liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind} return r + ---------------------- NodeText t -> do ind <- liftStateMarkup $ do @@ -170,8 +173,9 @@ instance Html5ify Root where S.put $ s{state_indent = pos_column bp} return $ state_indent s r <- html5ify t - liftStateMarkup $ S.modify $ \s -> s{state_indent=ind} + liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind} return r + ---------------------- NodeHeader hdr -> case hdr of HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon" @@ -220,6 +224,7 @@ instance Html5ify Root where html5ify whme H.span ! HA.class_ "header-value" $$ html5ify ts + ---------------------- NodePair pair -> case pair of PairElem name attrs -> do @@ -242,14 +247,10 @@ instance Html5ify Root where , "html5Name<>">" ) _ -> do H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do + let (o,c) = pairBorders pair ts H.span ! HA.class_ "pair-open" $$ html5ify o - H.span ! HA.class_ "pair-content" $$ - em $ - html5ify ts + H.span ! HA.class_ "pair-content" $$ em $ html5ify ts H.span ! HA.class_ "pair-close" $$ html5ify c - where - (o,c) | null ts = pairBordersWithoutContent pair - | otherwise = pairBorders pair where em :: Html5 -> Html5 em h = @@ -258,11 +259,12 @@ instance Html5ify Root where || p == PairFrenchquote || p == PairDoublequote -> do State{..} <- liftStateMarkup $ S.get - liftStateMarkup $ S.modify $ \s -> s{state_italic = not state_italic} + liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic} r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h - liftStateMarkup $ S.modify $ \s -> s{state_italic} + liftStateMarkup $ S.modify' $ \s -> s{state_italic} return r _ -> h + ---------------------- NodeLower name attrs -> do H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do H.span ! HA.class_ "header-mark" $$ html5ify '<' diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 20fee68..0d85cac 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -4,8 +4,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Write.Plain where -import Control.Applicative (Applicative(..), liftA2) -import Control.Monad (Monad(..), mapM) +import Control.Applicative (liftA2) +import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) @@ -18,7 +18,7 @@ import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq) +import Data.Sequence (ViewL(..)) import Data.String (String, IsString(..)) import Data.Tuple (fst) import Prelude (Num(..), error) @@ -27,6 +27,7 @@ import qualified Control.Monad.Trans.State as S import qualified Data.List as List import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Sequence as Seq import Language.TCT import Language.TCT.Utils @@ -48,25 +49,40 @@ runPlain :: Plain -> State -> TL.Text runPlain p s = TLB.toLazyText $ fst $ S.runState p s text :: Plainify a => State -> a -> TL.Text -text st a = runPlain (plainify a) st +text s a = runPlain (plainify a) s plainDocument :: Roots -> TL.Text -plainDocument = text def +plainDocument doc = text (setStart doc def) doc -- ** Type 'State' data State = State - { state_escape :: Bool -- FIXME: useful? - , state_pos :: Pos - , state_indent :: Int + { state_escape :: Bool -- FIXME: useful? + , state_pos :: Pos + , state_indent :: Int + , state_unindent :: Int } deriving (Eq, Show) instance Default State where def = State - { state_escape = True - , state_pos = pos1 - , state_indent = 1 + { state_escape = True + , state_pos = pos1 + , state_indent = 1 + , state_unindent = 0 } +-- | Set the starting 'Pos' of given 'State' +-- by using the first 'cell_begin'. +setStart :: Roots -> State -> State +setStart ts st = st + { state_unindent = pos_column - 1 + , state_pos = pos1{pos_line} + } + where + Pos{..} = + case Seq.viewl ts of + EmptyL -> pos1 + Tree Cell{cell_begin} _ :< _ -> cell_begin + -- * Class 'Plainify' class Plainify a where plainify :: a -> Plain @@ -75,12 +91,13 @@ instance Plainify () where instance Plainify Char where plainify = \case '\n' -> do - S.modify $ \s@State{state_pos=Pos line _col, state_indent} -> + S.modify' $ \s@State{state_pos=Pos line _col, state_indent} -> s{state_pos=Pos (line + 1) state_indent} - indent <- S.gets state_indent - return $ TLB.singleton '\n' <> fromString (List.replicate (indent - 1) ' ') + State{..} <- S.get + let indent = state_indent - 1 - state_unindent + return $ TLB.singleton '\n' <> fromString (List.replicate indent ' ') c -> do - S.modify $ \s@State{state_pos=Pos line col} -> + S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + 1)} return $ TLB.singleton c instance Plainify String where @@ -92,7 +109,7 @@ instance Plainify TL.Text where let (h,ts) = TL.span (/='\n') t in case TL.uncons ts of Nothing -> do - S.modify $ \s@State{state_pos=Pos line col} -> + S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + int (TL.length h))} return $ TLB.fromLazyText h Just (_n,ts') -> @@ -103,19 +120,23 @@ instance Plainify TL.Text where plainify ts' instance Plainify Pos where plainify new@(Pos lineNew colNew) = do - old@(Pos lineOld colOld) <- S.gets state_pos - S.modify $ \s -> s{state_pos=new} - case lineOld`compare`lineNew of - LT -> - return $ + State + { state_pos=old@(Pos lineOld colOld) + , state_unindent + } <- S.get + S.modify' $ \s -> s{state_pos=new} + return $ + case lineOld`compare`lineNew of + LT -> fromString (List.replicate (lineNew - lineOld) '\n') <> - fromString (List.replicate (colNew - 1) ' ') - EQ | colOld <= colNew -> - return $ - fromString (List.replicate (colNew - colOld) ' ') - _ -> error $ "plainify: non-ascending Pos:" - <> "\n old: " <> show old - <> "\n new: " <> show new + fromString (List.replicate indent ' ') + where indent = colNew - 1 - state_unindent + EQ | colOld <= colNew -> + fromString (List.replicate indent ' ') + where indent = (colNew - colOld) - state_unindent + _ -> error $ "plainify: non-ascending Pos:" + <> "\n old: " <> show old + <> "\n new: " <> show new instance Plainify Roots where plainify = foldMap plainify instance Plainify Root where @@ -123,24 +144,23 @@ instance Plainify Root where plainify bp <> case nod of NodePara -> do - ind <- S.gets state_indent - S.modify $ \s -> s{state_indent = pos_column bp} + State{..} <- S.get + S.modify' $ \s -> s{state_indent = pos_column bp} r <- plainify ts - S.modify $ \s -> s{state_indent=ind} + S.modify' $ \s -> s{state_indent} return r NodeGroup -> plainify ts NodeHeader h -> plainify h <> plainify ts NodeToken t -> plainify t NodeText t -> do - ind <- S.gets state_indent - S.modify $ \s -> s{state_indent = pos_column bp} + State{..} <- S.get + S.modify' $ \s -> s{state_indent = pos_column bp} r <- plainify t - S.modify $ \s -> s{state_indent=ind} + S.modify' $ \s -> s{state_indent} return r NodePair p -> plainify o <> plainify ts <> plainify c - where (o,c) | null ts = pairBordersWithoutContent p - | otherwise = pairBorders p + where (o,c) = pairBorders p ts NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts instance Plainify Header where @@ -178,6 +198,7 @@ instance Plainify (White,ElemAttr) where , elemAttr_close ] +{- -- * Class 'RackUpLeft' class RackUpLeft a where rackUpLeft :: a -> S.State (Maybe Pos) a @@ -192,7 +213,7 @@ instance RackUpLeft Pos where } instance RackUpLeft (Cell a) where rackUpLeft (Cell bp ep a) = do - S.modify $ \case + S.modify' $ \case Nothing -> Just bp p -> p Cell @@ -206,3 +227,4 @@ instance RackUpLeft a => RackUpLeft (Tree a) where Tree <$> rackUpLeft n <*> rackUpLeft ts +-} diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 3c3520a..2abdc89 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -11,42 +11,36 @@ import Control.Monad (Monad(..), (=<<)) import Data.Bool import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) -import Data.Foldable (null, foldl', any) +import Data.Foldable (Foldable(..)) import Data.Function (($), (.), id) -import Data.Functor (Functor(..), (<$>)) -import Data.Maybe (Maybe(..), maybe) +import Data.Functor ((<$>), (<$)) +import Data.Maybe (Maybe(..), maybe, fromMaybe) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>)) +import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|)) import Data.Set (Set) -import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..)) -import GHC.Exts (toList) +import Data.Tuple (uncurry) import Prelude (undefined) import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Sequence as Seq -import qualified Data.Text as Text import qualified Data.Text.Lazy as TL -import qualified Control.Monad.Trans.State as S import qualified Language.TCT.Write.Plain as Plain import qualified System.FilePath as FP import Text.Blaze.XML () import Language.TCT hiding (Parser) +import Language.TCT.Debug import Language.XML -import qualified Data.TreeSeq.Strict as TreeSeq - -import Debug.Trace (trace) -import Text.Show (show) xmlDocument :: Roots -> XMLs xmlDocument trees = -- (`S.evalState` def) $ case Seq.viewl trees of Tree (unCell -> NodeHeader HeaderSection{}) vs :< ts -> - case spanlTokens vs of - (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') -> + case spanlNodeToken vs of + (titles@(Seq.viewl -> (unTree -> cell_begin -> bp) :< _), vs') -> let vs'' = case Seq.findIndexL (\case @@ -57,7 +51,7 @@ xmlDocument trees = xmlify def { inh_titles = titles , inh_figure = True - , inh_tree0 = List.repeat xmlPara + , inh_para = List.repeat xmlPara } vs'' <> xmlify def ts _ -> xmlify def trees @@ -88,90 +82,138 @@ instance Default State where data Inh = Inh { inh_figure :: Bool - , inh_tree0 :: [Pos -> XMLs -> XML] - , inh_titles :: Seq Tokens + , inh_para :: [Cell () -> XMLs -> XML] + , inh_titles :: Roots } instance Default Inh where def = Inh { inh_figure = False - , inh_tree0 = [] + , inh_para = [] , inh_titles = mempty } +{- +newtype Merge a = Merge a + deriving (Functor) +instance Semigroup (Merge Roots) where + (<>) = unionTokens +instance Monad (Merge Roots) where + return = Merge + Merge m >>= f = + foldMap nn +-} + -- * Class 'Xmlify' class Xmlify a where xmlify :: Inh -> a -> XMLs instance Xmlify Roots where - xmlify inh_orig = go inh_orig - where - go :: Inh -> Roots -> XMLs - go inh trees = - case Seq.viewl trees of - Tree (Cell bp ep (NodeHeader (HeaderBar n _))) _ :< _ - | (body,ts) <- spanlBar n trees - , not (null body) -> - (<| go inh ts) $ - Tree (Cell bp ep "artwork") $ - maybe id (\v -> (Tree0 (XmlAttr (Cell bp ep ("type", v))) <|)) (mimetype n) $ - body >>= xmlify inh{inh_tree0=[]} - - Tree nod@(unCell -> NodeHeader (HeaderColon n _)) cs :< ts - | (cs',ts') <- spanlHeaderColon n ts - , not (null cs') -> - go inh $ Tree nod (cs<>cs') <| ts' - - Tree (Cell bp ep (NodeHeader HeaderBrackets{})) _ :< _ - | (rl,ts) <- spanlBrackets trees - , not (null rl) -> - (<| go inh ts) $ - Tree (Cell bp ep "references") $ - rl >>= xmlify inh_orig - - _ | (ul,ts) <- spanlItems (==HeaderDash) trees - , Tree (Cell bp ep _) _ :< _ <- Seq.viewl ul -> - (<| go inh ts) $ - Tree (Cell bp ep "ul") $ - ul >>= xmlify inh{inh_tree0=List.repeat xmlPara} - - _ | (ol,ts) <- spanlItems (\case HeaderDot{} -> True; _ -> False) trees - , Tree (Cell bp ep _) _ :< _ <- Seq.viewl ol -> - (<| go inh ts) $ - Tree (Cell bp ep "ol") $ - ol >>= xmlify inh{inh_tree0=List.repeat xmlPara} - - t@(Tree0 toks) :< ts -> - case inh_tree0 inh of - [] -> xmlify inh_orig t <> go inh ts - _ | isTokenElem toks -> xmlify inh_orig t <> go inh ts - tree0:inh_tree0 -> - (case Seq.viewl toks of - EmptyL -> id - (posTree -> bp) :< _ -> (tree0 bp (xmlify inh_orig t) <|)) $ - go inh{inh_tree0} ts - - t: - xmlify inh_orig t <> - go inh ts - - _ -> mempty + xmlify inh roots = + case Seq.viewl roots of + EmptyL -> mempty + l@(Tree cel@(Cell bp _ep nod) ts) :< rs -> + case nod of + NodeHeader (HeaderBar n _wh) + | (span, rest) <- spanlHeaderBar n roots -> + let (attrs,body) = partitionAttrs span in + (<| xmlify inh rest) $ + element "artwork" $ + xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <> + xmlify inh{inh_para=[]} body + ---------------------- + NodeHeader (HeaderGreat n _wh) + | (span, rest) <- spanlHeaderGreat n roots -> + let (attrs,body) = partitionAttrs span in + (<| xmlify inh rest) $ + element "artwork" $ + xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <> + xmlify inh{inh_para=[]} (debug0 "body" body) + ---------------------- + NodeHeader (HeaderColon n _wh) + | (span, rest) <- spanlHeaderColon n rs + , not $ null span -> + xmlify inh $ Tree cel (ts<>span) <| rest + ---------------------- + NodeHeader HeaderBrackets{} + | (span,rest) <- spanlBrackets roots + , not (null span) -> + (<| xmlify inh rest) $ + element "references" $ + xmlify inh span + ---------------------- + NodeText x + | Tree (cy@(unCell -> NodeText y)) ys :< rs' <- Seq.viewl rs -> + xmlify inh $ Tree (NodeText <$> (x <$ cel) <> (y <$ cy)) (ts <> ys) <| rs' + ---------------------- + NodePair PairParen + | Tree (Cell bb eb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs -> + (<| xmlify inh rs') $ + case bracket of + (toList -> [unTree -> Cell bl el (NodeToken (TokenLink lnk))]) -> + element "eref" $ + xmlAttrs [Cell bl el ("to",lnk)] <> + xmlify inh ts + _ -> + element "rref" $ + xmlAttrs [Cell bb eb ("to",Plain.plainDocument bracket)] <> + xmlify inh ts + ---------------------- + _ | (span, rest) <- spanlItems (==HeaderDash) roots + , not $ null span -> + (<| xmlify inh rest) $ + element "ul" $ + span >>= xmlify inh{inh_para=List.repeat xmlPara} + ---------------------- + _ | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots + , not $ null span -> + (<| xmlify inh rest) $ + element "ol" $ + span >>= xmlify inh{inh_para=List.repeat xmlPara} + ---------------------- + _ -> + xmlify inh l <> + xmlify inh rs + where + element :: XmlName -> XMLs -> XML + element n = tree (XmlElem n <$ cel) + {- + t@(Tree (NodePair (PairElem))) :< ts -> + case inh_para inh of + [] -> xmlify inh t <> go inh ts + _ | isTokenElem toks -> xmlify inh t <> go inh ts + tree0:inh_para -> + (case Seq.viewl toks of + EmptyL -> id + (unTree -> cell_begin -> bp) :< _ -> (tree0 bp (xmlify inh t) <|)) $ + go inh{inh_para} ts + -} instance Xmlify Root where - xmlify inh (Tree (Cell bp ep nod) ts) = + xmlify inh (Tree cel@(Cell bp ep nod) ts) = case nod of + NodeGroup -> xmlify inh ts + ---------------------- + NodePara -> + case inh_para inh of + [] -> xmlify inh ts + para:inh_para -> + Seq.singleton $ + para (() <$ cel) $ + xmlify inh{inh_para} ts + ---------------------- NodeHeader hdr -> case hdr of HeaderSection{} -> - let (attrs,body) = partitionAttributesChildren ts in + let (attrs,body) = partitionAttrs ts in let inh' = inh - { inh_tree0 = xmlTitle : List.repeat xmlPara + { inh_para = xmlTitle : List.repeat xmlPara , inh_figure = True } in Seq.singleton $ - Tree (Cell bp ep "section") $ - xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <> + element "section" $ + xmlAttrs (attrs `defaultAttr` Cell ep ep ("id",getAttrId body)) <> xmlify inh' body HeaderColon kn _wh -> - let (attrs,body) = partitionAttributesChildren ts in - let inh' = inh { inh_tree0 = + let (attrs,body) = partitionAttrs ts in + let inh' = inh { inh_para = case kn of "about" -> xmlTitle : xmlTitle : List.repeat xmlPara "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara @@ -182,24 +224,29 @@ instance Xmlify Root where _ -> [] } in case () of - _ | kn == "about" -> xmlAbout inh' nod attrs body + _ | kn == "about" -> xmlAbout inh' cel {-attrs-} body _ | inh_figure inh && not (kn`List.elem`elems) -> Seq.singleton $ - Tree (Cell bp ep "figure") $ - xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <> + element "figure" $ + xmlAttrs (setAttr (Cell ep ep ("type",kn)) attrs) <> case toList body of - [Tree0{}] -> xmlify inh'{inh_tree0 = List.repeat xmlPara} body - _ -> xmlify inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body - _ -> Seq.singleton $ x_Header inh' n - HeaderGreat n _wh -> x_Header inh' n - HeaderEqual n _wh -> x_Header inh' n - HeaderBar n _wh -> x_Header inh' n - HeaderDot _n -> Tree (cell "li") $ xmlify inh ts - HeaderDash -> Tree (cell "li") $ xmlify inh ts - HeaderDashDash -> Tree0 $ XmlComment $ cell $ + [Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body + _ -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body + _ -> + Seq.singleton $ + element (xmlLocalName kn) $ + xmlAttrs attrs <> + xmlify inh' ts + HeaderGreat n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts + HeaderEqual n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts + HeaderBar n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts + HeaderDot _n -> Seq.singleton $ element "li" $ xmlify inh ts + HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts + HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $ -- debug1_ ("TS", ts) $ -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $ - Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing + Plain.plainDocument ts + -- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing {- TreeSeq.mapAlsoNode (cell1 . unCell) @@ -208,31 +255,33 @@ instance Xmlify Root where (cell1 . unCell) (\_k' -> cell1 . unCell)) <$> ts -} - HeaderLower n as -> Tree (cell "artwork") $ xmlify inh ts HeaderBrackets ident -> let inh' = inh{inh_figure = False} in - let (attrs',body) = partitionAttributesChildren ts in - Tree (cell "reference") $ - xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <> - xmlify inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body + let (attrs,body) = partitionAttrs ts in + Seq.singleton $ + element "reference" $ + xmlAttrs (setAttr (Cell ep ep ("id",ident)) attrs) <> + xmlify inh'{inh_para = xmlTitle : xmlTitle : List.repeat xmlPara} body HeaderDotSlash p -> - Tree (cell "include") $ - xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <> + Seq.singleton $ + element "include" $ + xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <> xmlify inh ts + ---------------------- NodePair pair -> case pair of - PairBracket | to <- Plain.text def ts + PairBracket | to <- Plain.plainDocument ts , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> - Seq.singleton . - Tree (cell "rref") $ - xmlAttrs [cell ("to",TL.toStrict to)] - PairStar -> Seq.singleton . Tree (cell "b") $ xmlify inh ts - PairSlash -> Seq.singleton . Tree (cell "i") $ xmlify inh ts - PairBackquote -> Seq.singleton . Tree (cell "code") $ xmlify inh ts + Seq.singleton $ + element "rref" $ + xmlAttrs [cell ("to",to)] + PairStar -> Seq.singleton $ element "b" $ xmlify inh ts + PairSlash -> Seq.singleton $ element "i" $ xmlify inh ts + PairBackquote -> Seq.singleton $ element "code" $ xmlify inh ts PairFrenchquote -> - Seq.singleton . - Tree (cell "q") $ - xmlify inh ts + Seq.singleton $ + element "q" $ + xmlify inh ts {- case ts of (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) -> @@ -250,111 +299,77 @@ instance Xmlify Root where _ -> xmlify inh ts -} PairHash -> - Seq.singleton . - Tree (cell "ref") $ - xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)] + Seq.singleton $ + element "ref" $ + xmlAttrs [cell ("to",Plain.plainDocument ts)] PairElem name attrs -> - Seq.singleton . - Tree (cell $ xmlLocalName name) $ + Seq.singleton $ + element (xmlLocalName name) $ xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) -> cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <> xmlify inh ts _ -> - let (o,c) = pairBorders p ts in - Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell bp bp o) `unionXml` + let (open, close) = pairBorders pair ts in + Seq.singleton (Tree0 $ Cell bp bp $ XmlText open) `unionXml` xmlify inh ts `unionXml` - Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell ep ep c) + Seq.singleton (Tree0 $ Cell ep ep $ XmlText close) + ---------------------- + NodeText t -> Seq.singleton $ Tree0 $ cell $ XmlText t + ---------------------- NodeToken tok -> case tok of - TokenEscape c -> Seq.singleton $ Tree0 $ XmlPhrases $ phrasify c - TokenText t -> Seq.singleton $ Tree0 $ XmlText t - TokenTag t -> Seq.singleton $ Tree (cell "ref") $ xmlAttrs [cell ("to",t)] - TokenLink lnk -> Seq.singleton $ Tree (cell "eref") $ xmlAttrs [cell ("to",lnk)] - where - cell :: a -> Cell a - cell = Cell bp ep - x_Header :: Inh -> Text -> XML - x_Header inh' n = - Tree (cell $ xmlLocalName n) $ - xmlAttrs attrs <> - xmlify inh' ts - - - -instance Xmlify Tokens where - xmlify inh toks = - case Seq.viewl toks of - Tree (Cell bp _ep (NodePair PairParen)) paren - :< (Seq.viewl -> Tree (Cell bb eb (NodePair PairBracket)) bracket - :< ts) -> - (<| xmlify inh ts) $ - case bracket of - (toList -> [Tree0 (Cell bl el (TokenLink lnk))]) -> - Tree (Cell bp eb "eref") $ - xmlAttrs [Cell bl el ("to",lnk)] <> - xmlify inh paren - _ -> - Tree (Cell bp eb "rref") $ - xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.text def bracket)] <> - xmlify inh paren - t :< ts -> xmlify inh t `unionXml` xmlify inh ts - Seq.EmptyL -> mempty -{- -instance Xmlify Token where - xmlify inh (Tree (Cell bp ep (NodePair p)) ts) = - xmlify inh (Tree0 tok) = do + TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ TL.singleton c + TokenText t -> Seq.singleton $ Tree0 $ cell $ XmlText t + TokenTag t -> Seq.singleton $ element "ref" $ xmlAttrs [cell ("to",t)] + TokenLink lnk -> Seq.singleton $ element "eref" $ xmlAttrs [cell ("to",lnk)] + ---------------------- + NodeLower n as -> + Seq.singleton $ + element "artwork" $ + xmlify inh ts where cell :: a -> Cell a cell = Cell bp ep - {- - whites :: Pos -> Pos -> Seq XmlText - whites (Pos bLine bCol) (Pos eLine eCol) = - case bLine`compate`eLine of - LT -> verts <> - EQ -> horiz bCol eCol - GT -> - -} -instance Xmlify (Cell Phrase) where - xmlify _inh t = Seq.singleton $ Tree0 $ XmlPhrases $ Seq.singleton t --} + element :: XmlName -> XMLs -> XML + element n = tree (cell $ XmlElem n) -mimetype :: Text -> Maybe Text +-- | TODO: add more mimetypes +mimetype :: TL.Text -> Maybe TL.Text +mimetype "txt" = Just "text/plain" +mimetype "plain" = Just "text/plain" mimetype "hs" = Just "text/x-haskell" mimetype "sh" = Just "text/x-shellscript" mimetype "shell" = Just "text/x-shellscript" mimetype "shellscript" = Just "text/x-shellscript" mimetype _ = Nothing -xmlPhantom :: XmlName -> Pos -> XMLs -> XML -xmlPhantom n bp = Tree (Cell bp bp n) -xmlPara :: Pos -> XMLs -> XML -xmlPara = xmlPhantom "para" -xmlTitle :: Pos -> XMLs -> XML -xmlTitle = xmlPhantom "title" -xmlName :: Pos -> XMLs -> XML -xmlName bp (toList -> [Tree0 (XmlText (unCell -> t))]) = Tree0 (XmlAttr $ Cell bp bp ("name", t)) -xmlName bp ts = xmlPhantom "name" bp ts +xmlPara :: Cell a -> XMLs -> XML +xmlPara c = tree (XmlElem "para" <$ c) + +xmlTitle :: Cell a -> XMLs -> XML +xmlTitle c = tree (XmlElem "title" <$ c) + +xmlName :: Cell a -> XMLs -> XML +-- xmlName bp (toList -> [unTree -> unCell -> XmlText t]) = Tree0 $ Cell bp bp $ XmlAttr "name" t +xmlName c = tree (XmlElem "name" <$ c) xmlAbout :: Inh -> - Cell Header -> Seq (Cell (XmlName, Text)) -> + Cell Node -> + -- Seq (Cell (XmlName, Text)) -> Roots -> XMLs -xmlAbout inh hdr attrs body = - Seq.singleton $ - xmlHeader inh hdr attrs $ +xmlAbout inh nod body = + xmlify inh $ Tree nod $ case Seq.viewl (inh_titles inh) of - (Seq.viewl -> (posTree -> bt) :< _) :< _ -> + (unTree -> cell_begin -> bt) :< _ -> ((<$> inh_titles inh) $ \title -> Tree (Cell bt bt $ NodeHeader $ HeaderColon "title" "") $ - Seq.singleton $ Tree0 title) + Seq.singleton $ title) <> body _ -> body -xmlHeader :: Inh -> Cell Header -> Seq (Cell (XmlName, Text)) -> Roots -> XML -xmlHeader inh (Cell bp ep hdr) attrs ts = - -xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs -xmlAttrs = (Tree0 . XmlAttr <$>) +xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs +xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>) -- | Unify two 'XMLs', merging border 'XmlText's if any. unionXml :: XMLs -> XMLs -> XMLs @@ -362,70 +377,67 @@ unionXml x y = case (Seq.viewr x, Seq.viewl y) of (xs :> x0, y0 :< ys) -> case (x0,y0) of - ( Tree0 (XmlPhrases tx) - , Tree0 (XmlPhrases ty) ) -> - xs `unionXml` - Seq.singleton (Tree0 $ XmlPhrases $ tx <> ty) `unionXml` - ys - ( Tree0 (XmlText tx) - , Tree0 (XmlText ty) ) -> + ( Tree0 (Cell bx ex (XmlText tx)) + , Tree0 (Cell by ey (XmlText ty)) ) -> xs `unionXml` - Seq.singleton (Tree0 $ XmlText $ tx <> ty) `unionXml` + Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml` ys _ -> x <> y (Seq.EmptyR, _) -> y (_, Seq.EmptyL) -> x -spanlBar :: Name -> Roots -> (Roots, Roots) -spanlBar name = first unHeaderBar . spanBar +unionsXml :: Foldable f => f XMLs -> XMLs +unionsXml = foldl' unionXml mempty + +partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots) +partitionAttrs ts = (attrs,cs) + where + (as,cs) = (`Seq.partition` ts) $ \case + Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True + _ -> False + attrs = attr <$> as + attr = \case + Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a -> + Cell bp ep (xmlLocalName n, v) + where + v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a + _ -> undefined + +spanlHeaderBar :: Name -> Roots -> (Roots, Roots) +spanlHeaderBar name = first unHeaderBar . debug0 "spanBar" . spanBar + -- FIXME: use unTree where unHeaderBar :: Roots -> Roots unHeaderBar = (=<<) $ \case Tree (unCell -> NodeHeader HeaderBar{}) ts -> ts - _ -> mempty + ts -> return ts spanBar = Seq.spanl $ \case Tree (unCell -> NodeHeader (HeaderBar n _)) _ | n == name -> True + Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True _ -> False -spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots) -spanlItems liHeader ts = - let (lis, ts') = spanLIs ts in - foldl' accumLIs (mempty,ts') lis +spanlHeaderGreat :: Name -> Roots -> (Roots, Roots) +spanlHeaderGreat name = first unHeaderGreat . debug0 "spanGreat" . spanGreat + -- FIXME: use unTree where - spanLIs :: Roots -> (Roots, Roots) - spanLIs = Seq.spanl $ \case - Tree (unCell -> NodeHeader (liHeader -> True)) _ -> True - Tree (NodeToken toks) _ -> - (`any` toks) $ \case - TreeN (unCell -> NodePair (PairElem "li" _)) _ -> True - _ -> False - {- - case toList $ Seq.dropWhileR (isTokenWhite . unCell) toks of - [unCell -> TokenPair (PairElem "li" _) _] -> True - _ -> False - -} + unHeaderGreat :: Roots -> Roots + unHeaderGreat = (=<<) $ \case + Tree (unCell -> NodeHeader HeaderGreat{}) ts -> ts + ts -> return ts + spanGreat = + Seq.spanl $ \case + Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True + _ -> False + +spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots) +spanlItems liHeader = + Seq.spanl $ \(unTree -> unCell -> nod) -> + case nod of + NodeHeader (HeaderColon "li" _wh) -> True + NodeHeader hdr -> liHeader hdr + NodePair (PairElem "li" _as) -> True _ -> False - accumLIs :: (Roots,Roots) -> Root -> (Roots,Roots) - accumLIs acc@(oks,kos) t = - case t of - Tree (unCell -> NodeHeader (liHeader -> True)) _ -> (oks|>t,kos) - Tree0 toks -> - let (ok,ko) = - (`Seq.spanl` toks) $ \case - Tree (unCell -> NodePair (PairElem "li" _)) _ -> True - -- (isTokenWhite -> True) -> True -- TODO: see if this is still useful - _ -> False in - ( if null ok then oks else oks|>Tree0 (rmTokenWhite ok) - , if null ko then kos else Tree0 ko<|kos ) - _ -> acc - {- - rmTokenWhite :: Tokens -> Tokens - rmTokenWhite = - Seq.filter $ \case - (isTokenWhite -> False) -> True - _ -> True - -} spanlHeaderColon :: Name -> Roots -> (Roots, Roots) spanlHeaderColon name = @@ -440,55 +452,37 @@ spanlBrackets = Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True _ -> False -spanlTokens :: Roots -> (Seq Tokens, Roots) -spanlTokens = - first ((\case - Tree0 ts -> ts - _ -> undefined) <$>) . +spanlNodeToken :: Roots -> (Roots, Roots) +spanlNodeToken = Seq.spanl (\case - Tree0{} -> True + Tree (unCell -> NodeToken{}) _ -> True _ -> False) -getAttrId :: Roots -> Text +getAttrId :: Roots -> TL.Text getAttrId ts = - case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of - Just (Tree0 toks) -> TL.toStrict $ Plain.text def toks - _ -> "" + case Seq.viewl ts of + EmptyL -> "" + t :< _ -> Plain.plainDocument $ Seq.singleton t -setXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text)) -setXmlAttr a@(unCell -> (k, _v)) as = +setAttr :: + Cell (XmlName, TL.Text) -> + Seq (Cell (XmlName, TL.Text)) -> + Seq (Cell (XmlName, TL.Text)) +setAttr a@(unCell -> (k, _v)) as = case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of Just idx -> Seq.update idx a as Nothing -> a <| as -defXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text)) -defXmlAttr a@(unCell -> (k, _v)) as = +defaultAttr :: + Seq (Cell (XmlName, TL.Text)) -> + Cell (XmlName, TL.Text) -> + Seq (Cell (XmlName, TL.Text)) +defaultAttr as a@(unCell -> (k, _v)) = case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of Just _idx -> as Nothing -> a <| as -partitionAttributesChildren :: Roots -> (Seq (Cell (XmlName, Text)), Roots) -partitionAttributesChildren ts = (attrs,cs) - where - (as,cs) = (`Seq.partition` ts) $ \case - Tree (unCell -> NodeHeader HeaderEqual{}) _cs -> True - _ -> False - attrs = attr <$> as - attr = \case - Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a -> - Cell bp ep (xmlLocalName n, v) - where - v = TL.toStrict $ - Plain.text def{Plain.state_escape = False} $ - TreeSeq.mapAlsoNode - (cell1 . unCell) - (\_k -> fmap $ - TreeSeq.mapAlsoNode - (cell1 . unCell) - (\_k' -> cell1 . unCell)) <$> a - _ -> undefined - -elems :: Set Text +elems :: Set TL.Text elems = [ "about" , "abstract" diff --git a/Language/XML.hs b/Language/XML.hs index b781130..f9c797d 100644 --- a/Language/XML.hs +++ b/Language/XML.hs @@ -9,6 +9,7 @@ import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Int (Int) +import Data.Map.Strict (Map) import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) @@ -19,10 +20,11 @@ import Data.TreeSeq.Strict (Tree) import Prelude (error, pred, succ) import Text.Show (Show(..), showsPrec, showChar, showString) import qualified Data.List as List -import qualified Data.Text as Text +import qualified Data.Map.Strict as Map import qualified Data.Text.Lazy as TL import Language.TCT.Cell +import Language.TCT.Debug -- * Type 'XML' type XML = Tree (Cell XmlNode) @@ -31,21 +33,21 @@ type XMLs = Seq XML -- ** Type 'XmlName' data XmlName = XmlName - { xmlNamePrefix :: Text - , xmlNameSpace :: Text - , xmlNameLocal :: Text + { xmlNamePrefix :: TL.Text + , xmlNameSpace :: TL.Text + , xmlNameLocal :: TL.Text } instance Show XmlName where showsPrec _p XmlName{xmlNameSpace="", ..} = - showString (Text.unpack xmlNameLocal) + showString (TL.unpack xmlNameLocal) showsPrec _p XmlName{..} = - if Text.null xmlNameSpace - then showString (Text.unpack xmlNameLocal) + if TL.null xmlNameSpace + then showString (TL.unpack xmlNameLocal) else showChar '{' . - showString (Text.unpack xmlNameSpace) . + showString (TL.unpack xmlNameSpace) . showChar '}' . - showString (Text.unpack xmlNameLocal) + showString (TL.unpack xmlNameLocal) instance Eq XmlName where XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly instance Ord XmlName where @@ -55,10 +57,11 @@ instance IsString XmlName where fromString full@('{':rest) = case List.break (== '}') rest of (_, "") -> error ("Invalid Clark notation: " <> show full) - (ns, local) -> XmlName "" (Text.pack ns) (Text.pack $ List.drop 1 local) - fromString local = XmlName "" "" (Text.pack local) + (ns, local) -> XmlName "" (TL.pack ns) (TL.pack $ List.drop 1 local) + fromString local = XmlName "" "" (TL.pack local) +instance Pretty XmlName -xmlLocalName :: Text -> XmlName +xmlLocalName :: TL.Text -> XmlName xmlLocalName = XmlName "" "" -- ** Type 'XmlNode' @@ -68,6 +71,10 @@ data XmlNode | XmlComment TL.Text | XmlText TL.Text deriving (Eq,Ord,Show) +instance Pretty XmlNode + +-- ** Type 'XmlAttrs' +type XmlAttrs = Map XmlName (Cell TL.Text) -- * Type 'Rank' -- | nth child diff --git a/Text/Blaze/Utils.hs b/Text/Blaze/Utils.hs index 24d0f7a..2b2eb8c 100644 --- a/Text/Blaze/Utils.hs +++ b/Text/Blaze/Utils.hs @@ -100,7 +100,7 @@ instance MayAttr AttributeValue where -- | Composing state and markups. type StateMarkup st = Compose (S.State st) B.MarkupM instance Semigroup (StateMarkup st a) where - x<>y = x>>y + (<>) = (>>) instance Monoid (StateMarkup st ()) where mempty = pure () mappend = (<>) diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index 8833519..a7c2f62 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -50,7 +50,7 @@ import qualified Text.Blaze.HTML5 as Blaze.HTML5 import qualified Language.TCT as TCT import qualified Language.TCT.Write.Plain as TCT.Write.Plain import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 --- import qualified Language.TCT.Write.XML as TCT.Write.XML +import qualified Language.TCT.Write.XML as TCT.Write.XML import qualified Text.Megaparsec as P import Read @@ -86,12 +86,10 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = when (trace_TCT trace) $ do hPutStrLn stderr "### TCT ###" hPrint stderr $ Tree.Pretty tct - {- when (trace_XML trace) $ do hPutStrLn stderr "### XML ###" let xml = TCT.Write.XML.xmlDocument tct hPrint stderr $ Tree.Pretty xml - -} case format of TctFormatPlain -> TL.putStr $ -- 2.42.0 From 2478e128a8ab691f8ed5981e3f1460d06ac4b0f9 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 5 Feb 2018 23:03:05 +0100 Subject: [PATCH 13/16] Fix HeaderGreat parsing. --- Language/TCT/Debug.hs | 29 +++++ Language/TCT/Read/Token.hs | 6 +- Language/TCT/Read/Tree.hs | 28 ++-- Language/TCT/Tree.hs | 250 +++++++++++++++++++++++------------- Language/TCT/Write/HTML5.hs | 135 ++++++++++--------- Language/TCT/Write/Plain.hs | 82 ++++++++---- exe/cli/Main.hs | 2 +- 7 files changed, 345 insertions(+), 187 deletions(-) diff --git a/Language/TCT/Debug.hs b/Language/TCT/Debug.hs index d4556f0..b5195fa 100644 --- a/Language/TCT/Debug.hs +++ b/Language/TCT/Debug.hs @@ -69,6 +69,27 @@ debug2_ nf (na,a) (nb,b) r = Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ r +debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r) +debug3 nf na nb nc f a b c = + (\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $ + Trace.trace + ("[ " <> nf <> ":" + <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 + <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 + <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2 + ) f a b c + +debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r +debug3_ nf (na,a) (nb,b) (nc,c) r = + Trace.trace + ("[ " <> nf <> ":" + <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 + <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 + <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2 + ) $ + Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ + r + debugParser :: ( P.Stream s , P.ShowToken (P.Token s) @@ -101,6 +122,14 @@ debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) debug2_ _nf _a _b = id {-# INLINE debug2_ #-} +debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r) +debug3 _nf _na _nb _nc = id +{-# INLINE debug3 #-} + +debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r +debug3_ _nf _a _b _c = id +{-# INLINE debug3_ #-} + debugParser :: ( P.Stream s , P.ShowToken (P.Token s) diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index 0a8b5dc..c974eb7 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -373,14 +373,14 @@ instance TagFrom Tokens where case tagFrom $ Cell b0 e0 t of Nothing -> Nothing Just (t0,r0) -> - if TL.null (unCell r0) + if TL.null $ unCell r0 then case tagFrom ns of Just (t1@(Cell b1 _e1 _), r1) | e0 == b1 -> Just (t0<>t1, r1) - _ -> Just (t0, pure n0 `unionTokens` ns) + _ -> Just (t0, ns) else Just (t0, pure n0 `unionTokens` ns) - where n0 = (Tree0 $ NodeToken . TokenText <$> r0) + where n0 = Tree0 $ NodeToken . TokenText <$> r0 _ -> Nothing _ -> Nothing instance TagFrom (Cell TL.Text) where diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index 350b164..cca3706 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -70,13 +70,13 @@ p_CellHeader row = debugParser "CellHeader" $ do case header of HeaderSection{} -> p_CellEnd row' HeaderDash{} -> p_Row row' - HeaderDashDash{} -> p_CellText row' + HeaderDashDash{} -> p_CellRaw row' HeaderDot{} -> p_Row row' HeaderColon{} -> p_Row row' HeaderBrackets{} -> p_Row row' HeaderGreat{} -> p_Row row' - HeaderEqual{} -> p_CellEnd row' - HeaderBar{} -> p_CellEnd row' + HeaderEqual{} -> p_CellRaw row' + HeaderBar{} -> p_CellRaw row' HeaderDotSlash{} -> p_CellEnd row' -- HeaderLower{} -> undefined -- NOTE: handled in 'p_CellLower' -- TODO: move to a NodeLower @@ -146,14 +146,20 @@ p_CellLower row = debugParser "CellLower" $ do >> P.tokens (==) indent >> go (l:ls)) -p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row -p_CellText row = debugParser "CellText" $ do +p_CellText1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row +p_CellText1 row = debugParser "CellText" $ do P.skipMany $ P.char ' ' n <- p_Cell $ NodeText <$> p_Line1 return $ Tree0 n : row -p_CellSpaces :: Row -> Parser e s Row -p_CellSpaces row = debugParser "CellSpaces" $ do +p_CellRaw :: P.Tokens s ~ TL.Text => Row -> Parser e s Row +p_CellRaw row = debugParser "CellRaw" $ do + P.skipMany $ P.char ' ' + n <- p_Cell $ NodeText <$> p_Line + return $ Tree0 n : row + +p_CellSpaces1 :: Row -> Parser e s Row +p_CellSpaces1 row = debugParser "CellSpaces" $ do P.skipSome $ P.char ' ' pos <- p_Position return $ Tree0 (Cell pos pos $ NodeText "") : row @@ -161,8 +167,8 @@ p_CellSpaces row = debugParser "CellSpaces" $ do p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellEnd row = debugParser "CellEnd" $ P.try (p_CellLower row) <|> - P.try (p_CellText row) <|> - p_CellSpaces row <|> + P.try (p_CellText1 row) <|> + p_CellSpaces1 row <|> return row p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row @@ -173,9 +179,9 @@ p_Row row = debugParser "Row" $ p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows p_Rows rows = p_Row [] >>= \row -> - let rows' = rows `appendRow` List.reverse row in + let rows' = rows `mergeRow` row in (P.eof $> rows') <|> - (P.newline >> P.eof $> rows' <|> p_Rows rows') + (P.newline >> {-P.eof $> rows' <|>-} p_Rows rows') p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node)) p_Trees = collapseRows <$> p_Rows initRows diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index f100627..ae6c8a6 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -10,11 +10,10 @@ import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable(..)) +import Data.Foldable (Foldable(..), any) import Data.Function (($)) import Data.Functor ((<$>)) import Data.Int (Int) -import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ordering(..), Ord(..)) import Data.Semigroup (Semigroup(..)) @@ -130,33 +129,90 @@ initRows = [Tree0 (Cell p p NodeGroup)] -- NOTE: such that any following 'Root' -- is 'NodePara' if possible, and always a child. --- | @appendRow rows row@ appends @row@ to @rows@. +-- | @mergeRow rows row@ append @row@ into @rows@, while merging what has to be. -- --- [@rows@] parent 'Rows', from closest to farthest (non-strictly descending) --- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending) +-- * [@rows@] is old 'Rows', its |Root|s' 'cell_begin' are descending (non-strictly), +-- they MAY span over multilines, and they can be many from a single line. +-- * [@row@] is new 'Row', its |Root|s' 'cell_begin' are descending (non-strictly), +-- they MUST span only over a single and entire line. +-- +-- This is the main entry point to build 'Rows' by accumulating 'Row' into them. +mergeRow :: Rows -> Row -> Rows +mergeRow rows row = + debug2_ "mergeRow" ("news",row) ("olds",rows) $ + zipRow 0 rows $ List.reverse row + +-- | 'HeaderGreat' and 'HeaderBar' work, not on indentation, +-- but on their vertical alignment as prefixes. +-- Hence, each new 'Row' has those prefixes zipped into a single one +-- when they match and are aligned. +zipRow :: ColNum -> Rows -> Row -> Rows +zipRow col rows row = + debug3_ "zipRow" ("col",col) ("news",row) ("olds",rows) $ + case (row,rows) of + ([], _) -> rows + (_, []) -> undefined -- NOTE: cannot happen with initRows + ( _new@(Tree (Cell bn _en n) _ns):news + , _old@(Tree (Cell _bo eo _o) _os):_olds ) -> + case collapseRowsWhile isCollapsable rows of + [] -> appendRow rows row + head@(unTree -> Cell bh _eh h) : olds' -> + case (n,h) of + -- NOTE: zipping: when new is HeaderGreat, collapse last line downto col + -- then check if there is a matching HeaderGreat, + -- if so, discard new and restart with a col advanced to new's beginning + (NodeHeader hn@HeaderGreat{}, NodeHeader hh@HeaderGreat{}) + | pos_column bn == pos_column bh + , isAdjacent + , hn == hh -> discard + -- NOTE: same for HeaderBar + (NodeHeader hn@HeaderBar{}, NodeHeader hh@HeaderBar{}) + | pos_column bn == pos_column bh + , isAdjacent + , hn == hh -> discard + -- NOTE: collapsing: any other new aligned or on the right of an adjacent head + -- makes it collapse entirely + (_, NodeHeader HeaderGreat{}) + | col < pos_column bh -> collapse + -- NOTE: same for HeaderBar + (_, NodeHeader HeaderBar{}) + | col < pos_column bh -> collapse + _ -> debug "zipRow/append" $ appendRow rows row + where + discard = debug "zipRow/discard" $ zipRow (pos_column bh) rows news + collapse = debug "zipRow/collapse" $ zipRow col (collapseRoot head olds') row + isAdjacent = pos_line bn - pos_line eo <= 1 + where + isCollapsable = -- debug2 "zipRow/isCollapsable" "new" "old" $ + \_new@(unTree -> Cell bn _en _n) _old@(unTree -> Cell bo eo _o) -> + (pos_line bn - pos_line eo <= 1) && -- adjacent + col < pos_column bo -- righter than col + appendRow :: Rows -> Row -> Rows appendRow rows row = debug2_ "appendRow" ("news",row) ("olds",rows) $ case (row,rows) of - (_, []) -> undefined -- NOTE: cannot happen with initRows ([], _) -> rows - (new@(Tree (Cell bn en n) ns):news, old@(Tree (Cell bo eo o) os):olds) -> + (_, []) -> undefined -- NOTE: cannot happen with initRows + ( new@(Tree (Cell bn en n) ns):news + ,old@(Tree (Cell bo eo o) os):olds ) -> case debug0 "appendRow/colNew" (pos_column bn) `compare` debug0 "appendRow/colOld" (pos_column bo) of - -- NOTE: new is vertically lower + -- NOTE: new is on the left LT -> case (n,o) of -- NOTE: merge adjacent NodeText -- first -- second (NodeText tn, NodeText to) - | TL.null tn || TL.null to -> child - | not isNewPara && isIndented -> merge $ Tree t (os<>ns) + | TL.null tn || TL.null to + , not isVerbatim -> collapse + | isAdjacent && isIndented -> merge $ Tree t (os<>ns) where t = NodeText <$> Cell boNew eo (indent<>to) <> Cell bn en tn boNew = bo{pos_column=pos_column bn} indent = TL.replicate (int64 $ pos_column bo - pos_column bn) " " - -- | Whether the horizontal diff is made of spaces + -- | Whether the horizontal delta is made of spaces isIndented = debug0 "appendRow/isIndented" $ case olds of @@ -166,72 +222,73 @@ appendRow rows row = LT -> True EQ -> pos_column ep <= pos_column bn _ -> False - _ -> child + _ -> collapse -- NOTE: new is vertically aligned EQ -> case (n,o) of -- NOTE: preserve all NodeText "", but still split into two NodePara (NodeText tn, NodeText to) - | TL.null tn || TL.null to -> child - | not isNewPara -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) + | TL.null tn || TL.null to + , not isVerbatim -> collapse + | isAdjacent -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) -- NOTE: HeaderSection can parent Nodes at the same level (NodeHeader (HeaderSection lvlNew), _) - | Just (lvlOld, rows'@(old':olds')) <- collapseSection (pos_column bn) rows -> + | rows'@(old':olds') <- collapseRowsWhile isCollapsable rows + , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- old' -> if debug0 "appendRow/lvlNew" lvlNew > debug0 "appendRow/lvlOld" lvlOld - then -- # old + then -- # old' -- ## new - {-concat-} List.reverse row <> rows' - else -- ## old or # old - -- # new # new - {-child old'-} appendRow (appendChild old' olds') row - -- NOTE: concat everything else following a HeaderSection. + {-concat using old'-} List.reverse row <> rows' + else -- ## old' or # old' + -- # new # new + {-collapse using old'-} appendRow (collapseRoot old' olds') row + where + isCollapsable = -- debug2 "appendRow/isCollapsable" "new" "old" $ + \_new _old@(unTree -> Cell bt _et t) -> + case t of + NodeHeader HeaderSection{} -> False + _ -> pos_column bt == pos_column bn + -- NOTE: in case of alignment, HeaderSection is parent (_, NodeHeader HeaderSection{}) -> concat - {- - (NodeHeader ho@HeaderGreat{}, NodeHeader hn) | ho == hn -> - debug "appendRow/HeaderGreat" $ appendRow rows news - -} -- _ -> replace - -- NOTE: new is vertically greater + -- NOTE: new is on the right GT -> case (n,o) of + -- NOTE: only same line Root can be pushed on HeaderBar + -- DELME: (_, NodeHeader HeaderBar{}) | pos_column bn /= pos_column eo -> collapse -- NOTE: keep NodeText "" out of old NodePara - (NodeText "", NodePara) -> child + (NodeText "", NodePara) -> collapse -- NOTE: merge adjacent NodeText (NodeText tn, NodeText to) -> - case isNewPara of - _ | TL.null tn || TL.null to -> child + case isAdjacent of + _ | TL.null tn || TL.null to + , not isVerbatim -> collapse + -- old + -- new + True -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) -- old -- -- new - True -> appendRow (appendChild old olds) (shifted:news) + False -> appendRow (collapseRoot old olds) (shifted:news) where shifted = Tree (Cell bnNew en $ NodeText $ indent<>tn) (os<>ns) bnNew = bn{pos_column=pos_column bo} indent = TL.replicate (int64 $ pos_column bn - pos_column bo) " " - -- old - -- new - False -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) -- _ -> concat where - isNewPara = pos_line bn - pos_line eo > 1 - concat = debug "appendRow/concat" $ List.reverse row <> rows - merge m = debug "appendRow/merge" $ appendRow (m : olds) news - child = debug "appendRow/child" $ appendRow (appendChild old olds) row - replace = debug "appendRow/replace" $ appendRow (new : appendChild old olds) news - --- | Collapse downto any last HeaderSection, returning it and its level. -collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows) -collapseSection col = debug1 "collapseSection" "rows" go - where - go rows@(new@(unTree -> Cell bn _en n):olds) - | col == pos_column bn = - case n of - NodeHeader (HeaderSection lvl) -> return (lvl, rows) - _ -> (appendChild new <$>) <$> go olds - go _ = Nothing + isAdjacent = pos_line bn - pos_line eo <= 1 + -- | Whether a parent semantic want new to stay a NodeText + isVerbatim = any p rows + where + p (unTree -> unCell -> NodeHeader HeaderBar{}) = True + p _ = False + concat = debug "appendRow/concat" $ List.reverse row <> rows + merge m = debug "appendRow/merge" $ appendRow (m : olds) news + collapse = debug "appendRow/collapse" $ appendRow (collapseRoot old olds) row + replace = debug "appendRow/replace" $ appendRow (new : collapseRoot old olds) news -- | Like 'appendRow', but without maintaining the appending, -- hence collapsing all the 'Root's of the given 'Rows'. @@ -239,74 +296,91 @@ collapseSection col = debug1 "collapseSection" "rows" go -- NOTE: 'initRows' MUST have been the first 'Rows' -- before calling 'appendRow' on it to get the given 'Rows'. collapseRows :: Rows -> Roots -collapseRows = debug1 "collapseRows" "rows" $ \case +collapseRows rows = + case collapseRowsWhile (\_new _old -> True) rows of + [t] -> subTrees t + _ -> undefined + -- NOTE: subTrees returns the children of the updated initRows + +collapseRowsWhile :: (Root -> Root -> Bool) -> Rows -> Rows +collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case [] -> mempty - new@(Tree (Cell bn _en n) _ns):olds -> + rows@(new@(Tree (Cell bn _en n) _ns):olds) -> case olds of - [] -> subTrees new - old@(Tree (Cell bo eo o) _os):oldss -> + [] -> rows + -- + old@(Tree (Cell bo eo o) _os):oldss + | not $ test new old -> rows + | otherwise -> case debug0 "colNew" (pos_column bn) `compare` debug0 "colOld" (pos_column bo) of -- NOTE: new is vertically aligned EQ -> case (n,o) of + -- NOTE: HeaderSection can parent Nodes at the same level (NodeHeader (HeaderSection lvlNew), _) - | Just (lvlOld, old':olds') <- collapseSection (pos_column bn) olds -> - if debug0 "collapseRows/lvlNew" lvlNew - > debug0 "collapseRows/lvlOld" lvlOld - then -- # old + | old':olds' <- collapseRowsWhile isCollapsable olds + , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- old' -> + if debug0 "collapseRowsWhile/lvlNew" lvlNew + > debug0 "collapseRowsWhile/lvlOld" lvlOld + then -- # old' -- ## new - {-child new-} collapseRows $ appendChild new $ old':olds' - else -- ## old or # old - -- # new # new - {-child old'-} collapseRows $ new:appendChild old' olds' - -- NOTE: in case of alignment, HeaderSection is parent. - (_, NodeHeader HeaderSection{}) -> child + collapseRowsWhile test $ collapseRoot new $ old':olds' + else -- ## old' or # old' + -- # new # new + collapseRowsWhile test $ new:collapseRoot old' olds' + where + isCollapsable = + \_new _old@(unTree -> Cell bt _et t) -> + case t of + NodeHeader HeaderSection{} -> False + _ -> pos_column bt == pos_column bn + -- NOTE: in case of alignment, HeaderSection is parent + (_, NodeHeader HeaderSection{}) -> collapse -- NOTE: merge within old NodePara. - (_, NodePara{}) | not isNewPara -> child + (_, NodePara{}) | isAdjacent -> collapse -- - _ -> child2 - -- NOTE: new is either vertically lower or greater - _ -> child + _ -> collapse2 + -- NOTE: new is either on the left or on the right + _ -> collapse where - isNewPara = pos_line bn - pos_line eo > 1 - child, child2 :: Roots - child = debug "collapseRows/child" $ collapseRows $ appendChild new olds - child2 = debug "collapseRows/child2" $ collapseRows $ appendChild new $ appendChild old oldss + isAdjacent = pos_line bn - pos_line eo <= 1 + collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new olds + collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old oldss -- | Put a 'Root' as a child of the head 'Root'. -- --- NOTE: 'appendChild' is where 'NodePara' may be introduced. +-- NOTE: 'collapseRoot' is where 'NodePara' may be introduced. -- NOTE: any NodeText/NodeText merging must have been done before. -appendChild :: Root -> Rows -> Rows -appendChild new@(Tree (Cell bn en n) _ns) rows = - debug2_ "appendChild" ("new",Seq.singleton new) ("rows",rows) $ +collapseRoot :: Root -> Rows -> Rows +collapseRoot new@(Tree (Cell bn en n) _ns) rows = + debug2_ "collapseRoot" ("new",Seq.singleton new) ("rows",rows) $ case rows of [] -> return new old@(Tree (Cell bo eo o) os) : olds -> case (n,o) of -- NOTE: never put a NodePara directly within another - (NodePara, NodePara) -> child2 - -- NOTE: never put a child to NodeText - (_, NodeText{}) -> child2 + (NodePara, NodePara) -> collapse2 + -- NOTE: never put a collapse to NodeText, except some NodeHeader to preserve them + (_, NodeText{}) -> collapse2 -- NOTE: NodeText can begin a NodePara (NodeText tn, _) | not $ TL.null tn -> case o of -- NOTE: no NodePara within those - NodeHeader HeaderEqual{} -> child - NodeHeader HeaderBar{} -> child - NodeHeader HeaderDashDash{} -> child + NodeHeader HeaderEqual{} -> collapse + NodeHeader HeaderBar{} -> collapse + NodeHeader HeaderDashDash{} -> collapse -- NOTE: NodePara within those - NodePara | isNewPara -> para + NodePara | not isAdjacent -> para NodeHeader{} -> para NodeGroup -> para - _ -> child - _ -> child + _ -> collapse + _ -> collapse where - isNewPara = pos_line bn - pos_line eo > 1 - child = Tree (Cell bo en o) (os |> new) : olds - child2 = appendChild new $ appendChild old olds - para = Tree (Cell bn en NodePara) (return new) : rows + isAdjacent = pos_line bn - pos_line eo <= 1 + para = Tree (Cell bn en NodePara) (return new) : rows + collapse = Tree (Cell bo en o) (os |> new) : olds + collapse2 = collapseRoot new $ collapseRoot old olds -- | Return a 'Tree' from a 'Cell' node and 'subTrees', -- while adjusting the node's 'cell_end' diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index 2b8230c..e1e7b31 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -11,7 +11,6 @@ import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor.Compose (Compose(..)) -import Data.Int (Int) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..), Ordering(..)) @@ -30,7 +29,7 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA import Language.TCT -import Language.TCT.Debug +-- import Language.TCT.Debug import Language.TCT.Utils import Text.Blaze.Utils import qualified Language.TCT.Write.Plain as Plain @@ -78,17 +77,17 @@ html5 = Compose . return . H.toMarkup -- ** Type 'State' data State = State - { state_pos :: Pos - , state_indent :: Int - , state_italic :: Bool - } deriving (Eq, Show) + { state_pos :: Pos + , state_indent :: Html5 + , state_italic :: Bool + } -- deriving (Eq, Show) instance Default State where def = State - { state_pos = pos1 - , state_indent = 1 - , state_italic = False + { state_pos = pos1 + , state_indent = "" + , state_italic = False } -instance Pretty State +-- instance Pretty State -- * Class 'Html5ify' class Html5ify a where @@ -98,14 +97,11 @@ instance Html5ify () where instance Html5ify Char where html5ify = \case '\n' -> do - (indent, lnum) <- - liftStateMarkup $ do - s@State{state_pos=Pos line _col, state_indent} <- S.get - S.put $ s{state_pos=Pos (line + 1) state_indent} - return (state_indent, line + 1) + s@State{state_pos=Pos line _col, ..} <- liftStateMarkup S.get + liftStateMarkup $ S.put s{state_pos=Pos (line + 1) 1} html5 '\n' - H.a ! HA.id ("line-"<>attrify lnum) $$ return () - html5 $ List.replicate (indent - 1) ' ' + H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return () + state_indent c -> do liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + 1)} @@ -120,7 +116,7 @@ instance Html5ify TL.Text where case TL.uncons ts of Nothing -> do liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} -> - s{state_pos=Pos line (col + int (TL.length h))} + s{state_pos=Pos line $ col + int (TL.length h)} html5 h Just (_n,ts') -> do html5 h @@ -130,18 +126,22 @@ instance Html5ify TL.Text where html5ify ts' instance Html5ify Pos where html5ify new@(Pos lineNew colNew) = do - old@(Pos lineOld colOld) <- - liftStateMarkup $ do - s <- S.get - S.put s{state_pos=new} - return $ state_pos s + s@State + { state_pos=old@(Pos lineOld colOld) + , state_indent + } <- liftStateMarkup S.get case lineOld`compare`lineNew of LT -> do forM_ [lineOld+1..lineNew] $ \lnum -> do html5 '\n' H.a ! HA.id ("line-"<>attrify lnum) $$ return () - html5 $ List.replicate (colNew - 1) ' ' + liftStateMarkup $ S.put s{state_pos=Pos lineNew 1} + state_indent + Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos + html5 $ List.replicate (colNew - colMid) ' ' + liftStateMarkup $ S.put s{state_pos=new} EQ | colOld <= colNew -> do + liftStateMarkup $ S.put s{state_pos=new} html5 $ List.replicate (colNew - colOld) ' ' _ -> error $ "html5ify: non-ascending Pos:" <> "\n old: " <> show old @@ -154,34 +154,19 @@ instance Html5ify Root where case nod of NodeGroup -> html5ify ts ---------------------- - NodeToken t -> html5ify t - ---------------------- - NodePara -> do - ind <- - liftStateMarkup $ do - s <- S.get - S.put $ s{state_indent = pos_column bp} - return $ state_indent s - r <- html5ify ts - liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind} - return r - ---------------------- - NodeText t -> do - ind <- - liftStateMarkup $ do - s <- S.get - S.put $ s{state_indent = pos_column bp} - return $ state_indent s - r <- html5ify t - liftStateMarkup $ S.modify' $ \s -> s{state_indent=ind} - return r + NodeLower name attrs -> do + H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do + H.span ! HA.class_ "header-mark" $$ html5ify '<' + H.span ! HA.class_ "header-name" $$ html5ify name + html5ify attrs + html5ify ts ---------------------- NodeHeader hdr -> case hdr of + HeaderGreat n wh -> html5HeaderRepeated "" "" n wh ">" "" "great" + HeaderBar n wh -> html5HeaderRepeated "" "" n wh "|" "" "bar" HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon" - HeaderGreat n wh -> html5Header "" "" n wh ">" "" "great" HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal" - HeaderBar n wh -> html5Header "" "" n wh "|" "" "bar" HeaderDot n -> html5Header "" "" n "" "." "" "dot" HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash" HeaderDash -> html5Header "" "" "" "" "-" " " "dash" @@ -209,8 +194,8 @@ instance Html5ify Root where h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n) h _ = undefined where - html5Header :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5 - html5Header markBegin whmb name whn markEnd whme cl = do + html5Head :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5 + html5Head markBegin whmb name whn markEnd whme cl = do H.span ! HA.class_ (mconcat $ ["header header-",cl] <> if TL.null name then [] else [" header-name-",attrify name]) $$ do when (markBegin/="") $ @@ -222,8 +207,49 @@ instance Html5ify Root where when (markEnd/="") $ H.span ! HA.class_ "header-mark" $$ html5ify markEnd html5ify whme - H.span ! HA.class_ "header-value" $$ - html5ify ts + html5Header markBegin whmb name whn markEnd whme cl = do + html5Head markBegin whmb name whn markEnd whme cl + H.span ! HA.class_ "header-value" $$ + html5ify ts + html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5 + html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do + State{state_indent} <- liftStateMarkup S.get + liftStateMarkup $ S.modify' $ \s -> + s{ state_indent = do + state_indent + Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos + html5ify $ List.replicate (pos_column bp - colMid) ' ' + html5Head markBegin whmb name whn markEnd whme cl + } + r <- html5Header markBegin whmb name whn markEnd whme cl + liftStateMarkup $ S.modify' $ \s -> s{state_indent} + return r + ---------------------- + NodeText t -> do + State{state_indent} <- liftStateMarkup S.get + liftStateMarkup $ S.modify' $ \s -> + s{ state_indent = do + state_indent + Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos + html5ify $ List.replicate (pos_column bp - colMid) ' ' + } + r <- html5ify t + liftStateMarkup $ S.modify' $ \s -> s{state_indent} + return r + ---------------------- + NodePara -> do + State{state_indent} <- liftStateMarkup S.get + liftStateMarkup $ S.modify' $ \s -> + s{ state_indent = do + state_indent + Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos + html5ify $ List.replicate (pos_column bp - colMid) ' ' + } + r <- html5ify ts + liftStateMarkup $ S.modify' $ \s -> s{state_indent} + return r + ---------------------- + NodeToken t -> html5ify t <> html5ify ts ---------------------- NodePair pair -> case pair of @@ -264,13 +290,6 @@ instance Html5ify Root where liftStateMarkup $ S.modify' $ \s -> s{state_italic} return r _ -> h - ---------------------- - NodeLower name attrs -> do - H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do - H.span ! HA.class_ "header-mark" $$ html5ify '<' - H.span ! HA.class_ "header-name" $$ html5ify name - html5ify attrs - html5ify ts instance Html5ify Token where html5ify tok = case tok of diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 0d85cac..a4316fd 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -31,6 +31,7 @@ import qualified Data.Sequence as Seq import Language.TCT import Language.TCT.Utils +-- import Language.TCT.Debug -- * Type 'Plain' type Plain = S.State State TLB.Builder @@ -59,14 +60,15 @@ data State = State { state_escape :: Bool -- FIXME: useful? , state_pos :: Pos - , state_indent :: Int + , state_indent :: TL.Text , state_unindent :: Int + -- ^ useful to shift everything to the left } deriving (Eq, Show) instance Default State where def = State { state_escape = True , state_pos = pos1 - , state_indent = 1 + , state_indent = "" , state_unindent = 0 } @@ -92,10 +94,9 @@ instance Plainify Char where plainify = \case '\n' -> do S.modify' $ \s@State{state_pos=Pos line _col, state_indent} -> - s{state_pos=Pos (line + 1) state_indent} + s{state_pos=Pos (line + 1) $ int $ TL.length state_indent + 1} State{..} <- S.get - let indent = state_indent - 1 - state_unindent - return $ TLB.singleton '\n' <> fromString (List.replicate indent ' ') + return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent c -> do S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + 1)} @@ -122,18 +123,17 @@ instance Plainify Pos where plainify new@(Pos lineNew colNew) = do State { state_pos=old@(Pos lineOld colOld) - , state_unindent + , state_indent } <- S.get S.modify' $ \s -> s{state_pos=new} - return $ - case lineOld`compare`lineNew of - LT -> - fromString (List.replicate (lineNew - lineOld) '\n') <> - fromString (List.replicate indent ' ') - where indent = colNew - 1 - state_unindent - EQ | colOld <= colNew -> - fromString (List.replicate indent ' ') - where indent = (colNew - colOld) - state_unindent + return $ TLB.fromLazyText $ + case lineNew`compare`lineOld of + GT -> lines <> state_indent <> hspaces + where + lines = TL.replicate (int64 $ lineNew - lineOld) "\n" + hspaces = TL.replicate (int64 (colNew - 1) - TL.length state_indent) " " + EQ | colNew >= colOld -> + TL.replicate (int64 $ colNew - colOld) " " _ -> error $ "plainify: non-ascending Pos:" <> "\n old: " <> show old <> "\n new: " <> show new @@ -143,26 +143,56 @@ instance Plainify Root where plainify (Tree (Cell bp _ep nod) ts) = plainify bp <> case nod of - NodePara -> do - State{..} <- S.get - S.modify' $ \s -> s{state_indent = pos_column bp} - r <- plainify ts - S.modify' $ \s -> s{state_indent} - return r NodeGroup -> plainify ts - NodeHeader h -> plainify h <> plainify ts - NodeToken t -> plainify t + -- + NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts + -- + NodeHeader hdr -> + case hdr of + HeaderGreat{} -> repeatHeader + HeaderBar{} -> repeatHeader + _ -> plainify hdr <> plainify ts + where + repeatHeader = do + State{..} <- S.get + h <- plainify hdr + S.modify' $ \s -> s{state_indent = + state_indent <> + TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " <> + TLB.toLazyText h + } + r <- plainify ts + S.modify' $ \s -> s{state_indent} + return $ h <> r + -- NodeText t -> do State{..} <- S.get - S.modify' $ \s -> s{state_indent = pos_column bp} + S.modify' $ \s -> s{state_indent = + state_indent <> + TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " + } r <- plainify t S.modify' $ \s -> s{state_indent} return r + {- + NodeText t -> plainify t + -} + -- + NodePara -> do + State{..} <- S.get + S.modify' $ \s -> s{state_indent = + state_indent <> + TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " + } + r <- plainify ts + S.modify' $ \s -> s{state_indent} + return r + -- + NodeToken t -> plainify t <> plainify ts + -- NodePair p -> plainify o <> plainify ts <> plainify c where (o,c) = pairBorders p ts - NodeLower n as -> - "<" <> plainify n <> plainify as <> plainify ts instance Plainify Header where plainify hdr = case hdr of diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index a7c2f62..ee6f3a9 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -92,7 +92,7 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = hPrint stderr $ Tree.Pretty xml case format of TctFormatPlain -> - TL.putStr $ + TL.putStrLn $ TCT.Write.Plain.plainDocument tct TctFormatHTML5 -> Blaze.renderMarkupToByteStringIO BS.putStr $ -- 2.42.0 From f4e41ec871c2c4d264fe4bc399507799ce4e5efd Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 7 Feb 2018 04:29:24 +0100 Subject: [PATCH 14/16] Fix writing TCT to XML. --- Language/TCT/Cell.hs | 2 +- Language/TCT/Read/Tree.hs | 5 +- Language/TCT/Tree.hs | 124 +++++----- Language/TCT/Write/HTML5.hs | 1 + Language/TCT/Write/Plain.hs | 54 ++--- Language/TCT/Write/XML.hs | 435 +++++++++++++++++------------------- 6 files changed, 299 insertions(+), 322 deletions(-) diff --git a/Language/TCT/Cell.hs b/Language/TCT/Cell.hs index c5292b4..7009351 100644 --- a/Language/TCT/Cell.hs +++ b/Language/TCT/Cell.hs @@ -24,7 +24,7 @@ data Pos = Pos { pos_line :: {-# UNPACK #-} !LineNum , pos_column :: {-# UNPACK #-} !ColNum - } deriving (Eq) + } deriving (Eq, Ord) instance Semigroup Pos where Pos lx cx <> Pos ly cy = Pos (lx+ly) (cx+cy) diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index cca3706..712b247 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -78,9 +78,6 @@ p_CellHeader row = debugParser "CellHeader" $ do HeaderEqual{} -> p_CellRaw row' HeaderBar{} -> p_CellRaw row' HeaderDotSlash{} -> p_CellEnd row' - -- HeaderLower{} -> undefined -- NOTE: handled in 'p_CellLower' - -- TODO: move to a NodeLower - -- HeaderPara -> undefined -- NOTE: only introduced later in 'appendRow' p_Name :: P.Tokens s ~ TL.Text => Parser e s Name p_Name = p_AlphaNums @@ -181,7 +178,7 @@ p_Rows rows = p_Row [] >>= \row -> let rows' = rows `mergeRow` row in (P.eof $> rows') <|> - (P.newline >> {-P.eof $> rows' <|>-} p_Rows rows') + (P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows') p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node)) p_Trees = collapseRows <$> p_Rows initRows diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index ae6c8a6..0aaa969 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -17,7 +17,7 @@ import Data.Int (Int) import Data.Monoid (Monoid(..)) import Data.Ord (Ordering(..), Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.Sequence ((|>), ViewR(..)) +import Data.Sequence ((|>)) import Data.TreeSeq.Strict (Tree(..), Trees) import Prelude (undefined, Num(..)) import System.FilePath (FilePath) @@ -33,7 +33,13 @@ import Language.TCT.Debug -- * Type 'Root' -- | A single 'Tree' to rule all the 'Node's --- simplifies the navigation and transformations. +-- simplifies greatly the navigation and transformations, +-- especially because the later XML or DTC output +-- are themselves a single tree-like data structure. +-- +-- Also, having a single 'Tree' is easier to merge +-- XML coming from the first parsing phase (eg. @('NodeHeader' ('HeaderEqual' "li" ""))@), +-- and XML coming from the second parsing phase (eg. @NodePair (PairElem "li" [])@). -- -- For error reporting, each 'Node' is annotated with a 'Cell' -- spanning over all its content (sub-'Trees' included). @@ -120,7 +126,7 @@ type Row = [Root] -- (hence to which the next line can append to). type Rows = [Root] --- | Having an initial 'Root' simplifies 'appendRow': +-- | Having an initial 'Root' simplifies 'mergeRowIndent': -- one can always put the last 'Root' as a child to a previous one. -- This 'Root' just has to be discarded by 'collapseRows'. initRows :: Rows @@ -140,22 +146,24 @@ initRows = [Tree0 (Cell p p NodeGroup)] mergeRow :: Rows -> Row -> Rows mergeRow rows row = debug2_ "mergeRow" ("news",row) ("olds",rows) $ - zipRow 0 rows $ List.reverse row + mergeRowPrefix 0 rows $ List.reverse row --- | 'HeaderGreat' and 'HeaderBar' work, not on indentation, +-- | Merge by considering matching prefixes. +-- +-- 'HeaderGreat' and 'HeaderBar' work, not on indentation, -- but on their vertical alignment as prefixes. -- Hence, each new 'Row' has those prefixes zipped into a single one --- when they match and are aligned. -zipRow :: ColNum -> Rows -> Row -> Rows -zipRow col rows row = - debug3_ "zipRow" ("col",col) ("news",row) ("olds",rows) $ +-- when they match, are aligned and adjacent. +mergeRowPrefix :: ColNum -> Rows -> Row -> Rows +mergeRowPrefix col rows row = + debug3_ "mergeRowPrefix" ("col",col) ("news",row) ("olds",rows) $ case (row,rows) of ([], _) -> rows (_, []) -> undefined -- NOTE: cannot happen with initRows ( _new@(Tree (Cell bn _en n) _ns):news , _old@(Tree (Cell _bo eo _o) _os):_olds ) -> case collapseRowsWhile isCollapsable rows of - [] -> appendRow rows row + [] -> mergeRowIndent rows row head@(unTree -> Cell bh _eh h) : olds' -> case (n,h) of -- NOTE: zipping: when new is HeaderGreat, collapse last line downto col @@ -177,27 +185,28 @@ zipRow col rows row = -- NOTE: same for HeaderBar (_, NodeHeader HeaderBar{}) | col < pos_column bh -> collapse - _ -> debug "zipRow/append" $ appendRow rows row + _ -> debug "mergeRowPrefix/indent" $ mergeRowIndent rows row where - discard = debug "zipRow/discard" $ zipRow (pos_column bh) rows news - collapse = debug "zipRow/collapse" $ zipRow col (collapseRoot head olds') row isAdjacent = pos_line bn - pos_line eo <= 1 + discard = debug "mergeRowPrefix/discard" $ mergeRowPrefix (pos_column bh) rows news + collapse = debug "mergeRowPrefix/collapse" $ mergeRowPrefix col (collapseRoot head olds') row where - isCollapsable = -- debug2 "zipRow/isCollapsable" "new" "old" $ + isCollapsable = -- debug2 "mergeRowPrefix/isCollapsable" "new" "old" $ \_new@(unTree -> Cell bn _en _n) _old@(unTree -> Cell bo eo _o) -> (pos_line bn - pos_line eo <= 1) && -- adjacent col < pos_column bo -- righter than col -appendRow :: Rows -> Row -> Rows -appendRow rows row = - debug2_ "appendRow" ("news",row) ("olds",rows) $ +-- | Merge by considering indentation. +mergeRowIndent :: Rows -> Row -> Rows +mergeRowIndent rows row = + debug2_ "mergeRowIndent" ("news",row) ("olds",rows) $ case (row,rows) of ([], _) -> rows (_, []) -> undefined -- NOTE: cannot happen with initRows ( new@(Tree (Cell bn en n) ns):news ,old@(Tree (Cell bo eo o) os):olds ) -> - case debug0 "appendRow/colNew" (pos_column bn) `compare` - debug0 "appendRow/colOld" (pos_column bo) of + case debug0 "mergeRowIndent/colNew" (pos_column bn) `compare` + debug0 "mergeRowIndent/colOld" (pos_column bo) of -- NOTE: new is on the left LT -> case (n,o) of @@ -214,7 +223,7 @@ appendRow rows row = indent = TL.replicate (int64 $ pos_column bo - pos_column bn) " " -- | Whether the horizontal delta is made of spaces isIndented = - debug0 "appendRow/isIndented" $ + debug0 "mergeRowIndent/isIndented" $ case olds of [] -> True (unTree -> cell_end -> ep) : _ -> @@ -233,18 +242,18 @@ appendRow rows row = | isAdjacent -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) -- NOTE: HeaderSection can parent Nodes at the same level (NodeHeader (HeaderSection lvlNew), _) - | rows'@(old':olds') <- collapseRowsWhile isCollapsable rows - , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- old' -> - if debug0 "appendRow/lvlNew" lvlNew - > debug0 "appendRow/lvlOld" lvlOld - then -- # old' + | rows'@(sec:olds') <- collapseRowsWhile isCollapsable rows + , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- sec -> + if debug0 "mergeRowIndent/lvlNew" lvlNew + > debug0 "mergeRowIndent/lvlOld" lvlOld + then -- # sec -- ## new - {-concat using old'-} List.reverse row <> rows' - else -- ## old' or # old' + {-concat using sec-} List.reverse row <> rows' + else -- ## sec or # sec -- # new # new - {-collapse using old'-} appendRow (collapseRoot old' olds') row + {-collapse using sec-} mergeRowIndent (collapseRoot sec olds') row where - isCollapsable = -- debug2 "appendRow/isCollapsable" "new" "old" $ + isCollapsable = -- debug2 "mergeRowIndent/isCollapsable" "new" "old" $ \_new _old@(unTree -> Cell bt _et t) -> case t of NodeHeader HeaderSection{} -> False @@ -271,7 +280,7 @@ appendRow rows row = -- old -- -- new - False -> appendRow (collapseRoot old olds) (shifted:news) + False -> mergeRowIndent (collapseRoot old olds) (shifted:news) where shifted = Tree (Cell bnNew en $ NodeText $ indent<>tn) (os<>ns) bnNew = bn{pos_column=pos_column bo} @@ -285,16 +294,16 @@ appendRow rows row = where p (unTree -> unCell -> NodeHeader HeaderBar{}) = True p _ = False - concat = debug "appendRow/concat" $ List.reverse row <> rows - merge m = debug "appendRow/merge" $ appendRow (m : olds) news - collapse = debug "appendRow/collapse" $ appendRow (collapseRoot old olds) row - replace = debug "appendRow/replace" $ appendRow (new : collapseRoot old olds) news + concat = debug "mergeRowIndent/concat" $ List.reverse row <> rows + merge m = debug "mergeRowIndent/merge" $ mergeRowIndent (m : olds) news + collapse = debug "mergeRowIndent/collapse" $ mergeRowIndent (collapseRoot old olds) row + replace = debug "mergeRowIndent/replace" $ mergeRowIndent (new : collapseRoot old olds) news --- | Like 'appendRow', but without maintaining the appending, +-- | Like 'mergeRowIndent', but without maintaining the appending, -- hence collapsing all the 'Root's of the given 'Rows'. -- -- NOTE: 'initRows' MUST have been the first 'Rows' --- before calling 'appendRow' on it to get the given 'Rows'. +-- before calling 'mergeRowIndent' on it to get the given 'Rows'. collapseRows :: Rows -> Roots collapseRows rows = case collapseRowsWhile (\_new _old -> True) rows of @@ -305,11 +314,10 @@ collapseRows rows = collapseRowsWhile :: (Root -> Root -> Bool) -> Rows -> Rows collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case [] -> mempty - rows@(new@(Tree (Cell bn _en n) _ns):olds) -> - case olds of + rows@(new@(Tree (Cell bn _en n) _ns):news) -> + case news of [] -> rows - -- - old@(Tree (Cell bo eo o) _os):oldss + old@(Tree (Cell bo eo o) _os):olds | not $ test new old -> rows | otherwise -> case debug0 "colNew" (pos_column bn) `compare` @@ -319,16 +327,16 @@ collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case case (n,o) of -- NOTE: HeaderSection can parent Nodes at the same level (NodeHeader (HeaderSection lvlNew), _) - | old':olds' <- collapseRowsWhile isCollapsable olds - , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- old' -> + | sec:olds' <- collapseRowsWhile isCollapsable news + , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- sec -> if debug0 "collapseRowsWhile/lvlNew" lvlNew > debug0 "collapseRowsWhile/lvlOld" lvlOld - then -- # old' + then -- # sec -- ## new - collapseRowsWhile test $ collapseRoot new $ old':olds' - else -- ## old' or # old' + collapseRowsWhile test $ collapseRoot new $ sec:olds' + else -- ## sec or # sec -- # new # new - collapseRowsWhile test $ new:collapseRoot old' olds' + collapseRowsWhile test $ new:collapseRoot sec olds' where isCollapsable = \_new _old@(unTree -> Cell bt _et t) -> @@ -345,8 +353,8 @@ collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case _ -> collapse where isAdjacent = pos_line bn - pos_line eo <= 1 - collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new olds - collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old oldss + collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new news + collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old olds -- | Put a 'Root' as a child of the head 'Root'. -- @@ -359,9 +367,7 @@ collapseRoot new@(Tree (Cell bn en n) _ns) rows = [] -> return new old@(Tree (Cell bo eo o) os) : olds -> case (n,o) of - -- NOTE: never put a NodePara directly within another - (NodePara, NodePara) -> collapse2 - -- NOTE: never put a collapse to NodeText, except some NodeHeader to preserve them + -- NOTE: never put a child into NodeText (_, NodeText{}) -> collapse2 -- NOTE: NodeText can begin a NodePara (NodeText tn, _) | not $ TL.null tn -> @@ -375,19 +381,15 @@ collapseRoot new@(Tree (Cell bn en n) _ns) rows = NodeHeader{} -> para NodeGroup -> para _ -> collapse + -- NOTE: amongst remaining nodes, only adjacent ones may enter an old NodePara. + -- Note that since a NodePara is never adjacent to another, + -- it is not nested within into another. + -- Note that an adjacent HeaderSection can enter a NodePara. + (_, NodePara) | isAdjacent -> collapse + | otherwise -> collapse2 _ -> collapse where isAdjacent = pos_line bn - pos_line eo <= 1 para = Tree (Cell bn en NodePara) (return new) : rows collapse = Tree (Cell bo en o) (os |> new) : olds collapse2 = collapseRoot new $ collapseRoot old olds - --- | Return a 'Tree' from a 'Cell' node and 'subTrees', --- while adjusting the node's 'cell_end' --- with the last 'Tree' of the 'subTrees'. -tree :: Cell a -> Trees (Cell a) -> Tree (Cell a) -tree (Cell bp ep a) ts = Tree (Cell bp ep' a) ts - where - ep' = case Seq.viewr ts of - EmptyR -> ep - _ :> (unTree -> cell_end -> p) -> p diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index e1e7b31..ce3bdc5 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -152,6 +152,7 @@ instance Html5ify Root where html5ify (Tree (Cell bp _ep nod) ts) = do html5ify bp case nod of + ---------------------- NodeGroup -> html5ify ts ---------------------- NodeLower name attrs -> do diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index a4316fd..5dcecce 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -60,27 +60,32 @@ data State = State { state_escape :: Bool -- FIXME: useful? , state_pos :: Pos + -- ^ current position, + -- always in sync annotated 'Pos' of the input, + -- not with the output (whose colmuns may be shifted left by 'state_unindent') , state_indent :: TL.Text + -- ^ indentation, which contain horizontal spaces, + -- but also any repeated prefix introduced by 'HeaderBar' or 'HeaderGreat' , state_unindent :: Int - -- ^ useful to shift everything to the left + -- ^ initial 'pos_column' set by 'setStart', + -- useful to shift everything to the left } deriving (Eq, Show) instance Default State where def = State { state_escape = True , state_pos = pos1 , state_indent = "" - , state_unindent = 0 + , state_unindent = 1 } -- | Set the starting 'Pos' of given 'State' -- by using the first 'cell_begin'. setStart :: Roots -> State -> State setStart ts st = st - { state_unindent = pos_column - 1 - , state_pos = pos1{pos_line} + { state_pos = pos + , state_unindent = pos_column pos } - where - Pos{..} = + where pos = case Seq.viewl ts of EmptyL -> pos1 Tree Cell{cell_begin} _ :< _ -> cell_begin @@ -93,8 +98,8 @@ instance Plainify () where instance Plainify Char where plainify = \case '\n' -> do - S.modify' $ \s@State{state_pos=Pos line _col, state_indent} -> - s{state_pos=Pos (line + 1) $ int $ TL.length state_indent + 1} + S.modify' $ \s@State{state_pos=Pos line _col, state_indent, state_unindent} -> + s{state_pos=Pos (line + 1) $ state_unindent + int (TL.length state_indent)} State{..} <- S.get return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent c -> do @@ -111,7 +116,7 @@ instance Plainify TL.Text where case TL.uncons ts of Nothing -> do S.modify' $ \s@State{state_pos=Pos line col} -> - s{state_pos=Pos line (col + int (TL.length h))} + s{state_pos=Pos line $ col + int (TL.length h)} return $ TLB.fromLazyText h Just (_n,ts') -> return (TLB.fromLazyText h) <> @@ -124,6 +129,7 @@ instance Plainify Pos where State { state_pos=old@(Pos lineOld colOld) , state_indent + , state_unindent } <- S.get S.modify' $ \s -> s{state_pos=new} return $ TLB.fromLazyText $ @@ -131,7 +137,7 @@ instance Plainify Pos where GT -> lines <> state_indent <> hspaces where lines = TL.replicate (int64 $ lineNew - lineOld) "\n" - hspaces = TL.replicate (int64 (colNew - 1) - TL.length state_indent) " " + hspaces = TL.replicate (int64 (colNew - state_unindent) - TL.length state_indent) " " EQ | colNew >= colOld -> TL.replicate (int64 $ colNew - colOld) " " _ -> error $ "plainify: non-ascending Pos:" @@ -143,53 +149,51 @@ instance Plainify Root where plainify (Tree (Cell bp _ep nod) ts) = plainify bp <> case nod of + ---------------------- NodeGroup -> plainify ts - -- + ---------------------- NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts - -- + ---------------------- NodeHeader hdr -> case hdr of - HeaderGreat{} -> repeatHeader - HeaderBar{} -> repeatHeader + HeaderGreat{} -> plainHeaderRepeated + HeaderBar{} -> plainHeaderRepeated _ -> plainify hdr <> plainify ts where - repeatHeader = do + plainHeaderRepeated = do State{..} <- S.get h <- plainify hdr S.modify' $ \s -> s{state_indent = state_indent <> - TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " <> + TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <> TLB.toLazyText h } r <- plainify ts S.modify' $ \s -> s{state_indent} return $ h <> r - -- + ---------------------- NodeText t -> do State{..} <- S.get S.modify' $ \s -> s{state_indent = state_indent <> - TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " + TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " } r <- plainify t S.modify' $ \s -> s{state_indent} return r - {- - NodeText t -> plainify t - -} - -- + ---------------------- NodePara -> do State{..} <- S.get S.modify' $ \s -> s{state_indent = state_indent <> - TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " + TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " } r <- plainify ts S.modify' $ \s -> s{state_indent} return r - -- + ---------------------- NodeToken t -> plainify t <> plainify ts - -- + ---------------------- NodePair p -> plainify o <> plainify ts <> plainify c where (o,c) = pairBorders p ts diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 2abdc89..c3f02cd 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -6,15 +6,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Write.XML where -import Control.Arrow (first) -import Control.Monad (Monad(..), (=<<)) +import Control.Monad (Monad(..)) import Data.Bool import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Function (($), (.), id) +import Data.Function (($), (.)) import Data.Functor ((<$>), (<$)) -import Data.Maybe (Maybe(..), maybe, fromMaybe) +import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|)) @@ -31,31 +30,39 @@ import qualified System.FilePath as FP import Text.Blaze.XML () import Language.TCT hiding (Parser) -import Language.TCT.Debug +-- import Language.TCT.Debug import Language.XML +-- | Main entry point +-- +-- NOTE: 'XmlNode' are still annotated with 'Cell', +-- but nothing is done to preserve any ordering amongst them, +-- because 'Node's sometimes need to be reordered +-- (eg. about/title may have a title from the section before, +-- hence outside of about). +-- Still holding: @'cell_begin' < 'cell_end'@ and 'Cell' nesting. xmlDocument :: Roots -> XMLs -xmlDocument trees = +xmlDocument doc = -- (`S.evalState` def) $ - case Seq.viewl trees of - Tree (unCell -> NodeHeader HeaderSection{}) vs :< ts -> - case spanlNodeToken vs of - (titles@(Seq.viewl -> (unTree -> cell_begin -> bp) :< _), vs') -> - let vs'' = - case Seq.findIndexL - (\case - Tree (unCell -> NodeHeader (HeaderColon "about" _)) _ -> True - _ -> False) vs' of - Nothing -> Tree (Cell bp bp $ NodeHeader $ HeaderColon "about" "") mempty <| vs' - Just{} -> vs' in + case Seq.viewl doc of + Tree (unCell -> NodeHeader HeaderSection{}) body :< foot -> + case Seq.viewl body of + title@(unTree -> Cell bt et NodePara{}) :< content -> xmlify def - { inh_titles = titles + { inh_titles = return title , inh_figure = True - , inh_para = List.repeat xmlPara - } vs'' <> - xmlify def ts - _ -> xmlify def trees - _ -> xmlify def trees + } contentWithAbout <> + xmlify def foot + where + contentWithAbout = + case Seq.findIndexL isAbout content of + Nothing -> Tree (Cell bt et $ NodeHeader $ HeaderColon "about" "") mempty <| content + Just{} -> content + isAbout = \case + (unTree -> unCell -> NodeHeader (HeaderColon "about" _wh)) -> True + _ -> False + _ -> xmlify def doc + _ -> xmlify def doc {- -- * Type 'Xmls' @@ -88,20 +95,19 @@ data Inh instance Default Inh where def = Inh { inh_figure = False - , inh_para = [] + , inh_para = List.repeat xmlPara , inh_titles = mempty } -{- -newtype Merge a = Merge a - deriving (Functor) -instance Semigroup (Merge Roots) where - (<>) = unionTokens -instance Monad (Merge Roots) where - return = Merge - Merge m >>= f = - foldMap nn --} +-- ** 'inh_para' +xmlPara :: Cell a -> XMLs -> XML +xmlPara c = Tree (XmlElem "para" <$ c) + +xmlTitle :: Cell a -> XMLs -> XML +xmlTitle c = Tree (XmlElem "title" <$ c) + +xmlName :: Cell a -> XMLs -> XML +xmlName c = Tree (XmlElem "name" <$ c) -- * Class 'Xmlify' class Xmlify a where @@ -110,40 +116,43 @@ instance Xmlify Roots where xmlify inh roots = case Seq.viewl roots of EmptyL -> mempty - l@(Tree cel@(Cell bp _ep nod) ts) :< rs -> - case nod of - NodeHeader (HeaderBar n _wh) - | (span, rest) <- spanlHeaderBar n roots -> - let (attrs,body) = partitionAttrs span in - (<| xmlify inh rest) $ - element "artwork" $ - xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <> - xmlify inh{inh_para=[]} body - ---------------------- - NodeHeader (HeaderGreat n _wh) - | (span, rest) <- spanlHeaderGreat n roots -> - let (attrs,body) = partitionAttrs span in - (<| xmlify inh rest) $ - element "artwork" $ - xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <> - xmlify inh{inh_para=[]} (debug0 "body" body) + r@(Tree cr@(Cell _br _er nr) ts) :< rs -> + case nr of ---------------------- + -- NOTE: HeaderColon becomes parent + -- of any continuous following-sibling HeaderBar or HeaderGreat NodeHeader (HeaderColon n _wh) - | (span, rest) <- spanlHeaderColon n rs + | (span, rest) <- spanlHeaderColon rs , not $ null span -> - xmlify inh $ Tree cel (ts<>span) <| rest + xmlify inh $ Tree cr (ts<>span) <| rest + where + spanlHeaderColon :: Roots -> (Roots, Roots) + spanlHeaderColon = + Seq.spanl $ \case + Tree (unCell -> NodeHeader (HeaderBar m _)) _ -> m == n + Tree (unCell -> NodeHeader (HeaderGreat m _)) _ -> m == n + _ -> False ---------------------- + -- NOTE: gather HeaderBrackets NodeHeader HeaderBrackets{} | (span,rest) <- spanlBrackets roots , not (null span) -> (<| xmlify inh rest) $ element "references" $ - xmlify inh span + span >>= xmlify inh + where + spanlBrackets :: Roots -> (Roots, Roots) + spanlBrackets = + Seq.spanl $ \case + Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True + _ -> False ---------------------- + -- NOTE: merge adjacent NodeText-s, shouldn't be needed, but just in case. NodeText x | Tree (cy@(unCell -> NodeText y)) ys :< rs' <- Seq.viewl rs -> - xmlify inh $ Tree (NodeText <$> (x <$ cel) <> (y <$ cy)) (ts <> ys) <| rs' + xmlify inh $ Tree (NodeText <$> (x <$ cr) <> (y <$ cy)) (ts <> ys) <| rs' ---------------------- + -- NOTE: detect [some text](http://some.url) or [SomeRef] NodePair PairParen | Tree (Cell bb eb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs -> (<| xmlify inh rs') $ @@ -157,24 +166,36 @@ instance Xmlify Roots where xmlAttrs [Cell bb eb ("to",Plain.plainDocument bracket)] <> xmlify inh ts ---------------------- + -- NOTE: gather HeaderDash _ | (span, rest) <- spanlItems (==HeaderDash) roots , not $ null span -> (<| xmlify inh rest) $ element "ul" $ span >>= xmlify inh{inh_para=List.repeat xmlPara} ---------------------- - _ | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots + -- NOTE: gather HeaderDot + | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots , not $ null span -> (<| xmlify inh rest) $ element "ol" $ span >>= xmlify inh{inh_para=List.repeat xmlPara} + where + spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots) + spanlItems liHeader = + Seq.spanl $ \(unTree -> unCell -> nod) -> + case nod of + NodeHeader (HeaderColon "li" _wh) -> True + NodeHeader hdr -> liHeader hdr + NodePair (PairElem "li" _as) -> True + _ -> False ---------------------- + -- NOTE: context-free Root _ -> - xmlify inh l <> + xmlify inh r <> xmlify inh rs where element :: XmlName -> XMLs -> XML - element n = tree (XmlElem n <$ cel) + element n = Tree (XmlElem n <$ cr) {- t@(Tree (NodePair (PairElem))) :< ts -> case inh_para inh of @@ -201,47 +222,75 @@ instance Xmlify Root where ---------------------- NodeHeader hdr -> case hdr of + -- HeaderSection{} -> let (attrs,body) = partitionAttrs ts in - let inh' = inh - { inh_para = xmlTitle : List.repeat xmlPara - , inh_figure = True - } in Seq.singleton $ element "section" $ xmlAttrs (attrs `defaultAttr` Cell ep ep ("id",getAttrId body)) <> xmlify inh' body - HeaderColon kn _wh -> + where + inh' = inh + { inh_para = xmlTitle : List.repeat xmlPara + , inh_figure = True + } + -- + HeaderColon n _wh -> let (attrs,body) = partitionAttrs ts in - let inh' = inh { inh_para = - case kn of - "about" -> xmlTitle : xmlTitle : List.repeat xmlPara - "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara - "serie" -> List.repeat xmlName - "author" -> List.repeat xmlName - "editor" -> List.repeat xmlName - "org" -> List.repeat xmlName - _ -> [] - } in - case () of - _ | kn == "about" -> xmlAbout inh' cel {-attrs-} body - _ | inh_figure inh && not (kn`List.elem`elems) -> + case n of + -- NOTE: insert titles into . + "about" -> + Seq.singleton $ + element "about" $ + (inh_titles inh >>= xmlify inh') <> + xmlAttrs attrs <> + xmlify inh body + -- NOTE: in
mode, unreserved nodes become
+ _ | inh_figure inh && not (n`List.elem`elems) -> Seq.singleton $ element "figure" $ - xmlAttrs (setAttr (Cell ep ep ("type",kn)) attrs) <> + xmlAttrs (setAttr (Cell ep ep ("type",n)) attrs) <> case toList body of [Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body _ -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body + -- NOTE: reserved nodes _ -> Seq.singleton $ - element (xmlLocalName kn) $ + element (xmlLocalName n) $ xmlAttrs attrs <> xmlify inh' ts - HeaderGreat n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts + where + inh' = inh + { inh_para = + case n of + "about" -> xmlTitle : List.repeat xmlPara + "reference" -> xmlTitle : List.repeat xmlPara + "serie" -> List.repeat xmlName + "author" -> List.repeat xmlName + "editor" -> List.repeat xmlName + "org" -> List.repeat xmlName + _ -> [] + } + ---------------------- + HeaderBar n _wh -> + Seq.singleton $ + element "artwork" $ + xmlAttrs (Seq.singleton $ Cell bp bp ("type", if TL.null n then "txt" else n)) <> + xmlify inh{inh_para=[]} ts + ---------------------- + HeaderGreat n _wh -> + Seq.singleton $ + let (attrs,body) = partitionAttrs ts in + element "artwork" $ + xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", if TL.null n then "quote" else n)) <> + xmlify inh{inh_para=[]} body + -- HeaderEqual n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts - HeaderBar n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts + -- HeaderDot _n -> Seq.singleton $ element "li" $ xmlify inh ts + -- HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts + -- HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $ -- debug1_ ("TS", ts) $ -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $ @@ -255,13 +304,16 @@ instance Xmlify Root where (cell1 . unCell) (\_k' -> cell1 . unCell)) <$> ts -} + -- HeaderBrackets ident -> - let inh' = inh{inh_figure = False} in let (attrs,body) = partitionAttrs ts in Seq.singleton $ element "reference" $ xmlAttrs (setAttr (Cell ep ep ("id",ident)) attrs) <> xmlify inh'{inh_para = xmlTitle : xmlTitle : List.repeat xmlPara} body + where + inh' = inh{inh_figure = False} + -- HeaderDotSlash p -> Seq.singleton $ element "include" $ @@ -297,7 +349,7 @@ instance Xmlify Root where xmlify inh $ rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r))) _ -> xmlify inh ts - -} + -} PairHash -> Seq.singleton $ element "ref" $ @@ -331,157 +383,13 @@ instance Xmlify Root where cell :: a -> Cell a cell = Cell bp ep element :: XmlName -> XMLs -> XML - element n = tree (cell $ XmlElem n) - --- | TODO: add more mimetypes -mimetype :: TL.Text -> Maybe TL.Text -mimetype "txt" = Just "text/plain" -mimetype "plain" = Just "text/plain" -mimetype "hs" = Just "text/x-haskell" -mimetype "sh" = Just "text/x-shellscript" -mimetype "shell" = Just "text/x-shellscript" -mimetype "shellscript" = Just "text/x-shellscript" -mimetype _ = Nothing - -xmlPara :: Cell a -> XMLs -> XML -xmlPara c = tree (XmlElem "para" <$ c) - -xmlTitle :: Cell a -> XMLs -> XML -xmlTitle c = tree (XmlElem "title" <$ c) - -xmlName :: Cell a -> XMLs -> XML --- xmlName bp (toList -> [unTree -> unCell -> XmlText t]) = Tree0 $ Cell bp bp $ XmlAttr "name" t -xmlName c = tree (XmlElem "name" <$ c) - -xmlAbout :: - Inh -> - Cell Node -> - -- Seq (Cell (XmlName, Text)) -> - Roots -> XMLs -xmlAbout inh nod body = - xmlify inh $ Tree nod $ - case Seq.viewl (inh_titles inh) of - (unTree -> cell_begin -> bt) :< _ -> - ((<$> inh_titles inh) $ \title -> - Tree (Cell bt bt $ NodeHeader $ HeaderColon "title" "") $ - Seq.singleton $ title) - <> body - _ -> body - -xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs -xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>) - --- | Unify two 'XMLs', merging border 'XmlText's if any. -unionXml :: XMLs -> XMLs -> XMLs -unionXml x y = - case (Seq.viewr x, Seq.viewl y) of - (xs :> x0, y0 :< ys) -> - case (x0,y0) of - ( Tree0 (Cell bx ex (XmlText tx)) - , Tree0 (Cell by ey (XmlText ty)) ) -> - xs `unionXml` - Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml` - ys - _ -> x <> y - (Seq.EmptyR, _) -> y - (_, Seq.EmptyL) -> x - -unionsXml :: Foldable f => f XMLs -> XMLs -unionsXml = foldl' unionXml mempty - -partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots) -partitionAttrs ts = (attrs,cs) - where - (as,cs) = (`Seq.partition` ts) $ \case - Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True - _ -> False - attrs = attr <$> as - attr = \case - Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a -> - Cell bp ep (xmlLocalName n, v) - where - v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a - _ -> undefined - -spanlHeaderBar :: Name -> Roots -> (Roots, Roots) -spanlHeaderBar name = first unHeaderBar . debug0 "spanBar" . spanBar - -- FIXME: use unTree - where - unHeaderBar :: Roots -> Roots - unHeaderBar = (=<<) $ \case - Tree (unCell -> NodeHeader HeaderBar{}) ts -> ts - ts -> return ts - spanBar = - Seq.spanl $ \case - Tree (unCell -> NodeHeader (HeaderBar n _)) _ | n == name -> True - Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True - _ -> False - -spanlHeaderGreat :: Name -> Roots -> (Roots, Roots) -spanlHeaderGreat name = first unHeaderGreat . debug0 "spanGreat" . spanGreat - -- FIXME: use unTree - where - unHeaderGreat :: Roots -> Roots - unHeaderGreat = (=<<) $ \case - Tree (unCell -> NodeHeader HeaderGreat{}) ts -> ts - ts -> return ts - spanGreat = - Seq.spanl $ \case - Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True - _ -> False - -spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots) -spanlItems liHeader = - Seq.spanl $ \(unTree -> unCell -> nod) -> - case nod of - NodeHeader (HeaderColon "li" _wh) -> True - NodeHeader hdr -> liHeader hdr - NodePair (PairElem "li" _as) -> True - _ -> False - -spanlHeaderColon :: Name -> Roots -> (Roots, Roots) -spanlHeaderColon name = - Seq.spanl $ \case - Tree (unCell -> NodeHeader (HeaderBar n _)) _ -> n == name - Tree (unCell -> NodeHeader (HeaderGreat n _)) _ -> n == name - _ -> False + element n = Tree (cell $ XmlElem n) +instance Xmlify (Seq (Cell (XmlName,TL.Text))) where + xmlify _inh = xmlAttrs -spanlBrackets :: Roots -> (Roots, Roots) -spanlBrackets = - Seq.spanl $ \case - Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True - _ -> False - -spanlNodeToken :: Roots -> (Roots, Roots) -spanlNodeToken = - Seq.spanl (\case - Tree (unCell -> NodeToken{}) _ -> True - _ -> False) - -getAttrId :: Roots -> TL.Text -getAttrId ts = - case Seq.viewl ts of - EmptyL -> "" - t :< _ -> Plain.plainDocument $ Seq.singleton t - -setAttr :: - Cell (XmlName, TL.Text) -> - Seq (Cell (XmlName, TL.Text)) -> - Seq (Cell (XmlName, TL.Text)) -setAttr a@(unCell -> (k, _v)) as = - case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of - Just idx -> Seq.update idx a as - Nothing -> a <| as - -defaultAttr :: - Seq (Cell (XmlName, TL.Text)) -> - Cell (XmlName, TL.Text) -> - Seq (Cell (XmlName, TL.Text)) -defaultAttr as a@(unCell -> (k, _v)) = - case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of - Just _idx -> as - Nothing -> a <| as +-- * Elements +-- | Reserved elements' name elems :: Set TL.Text elems = [ "about" @@ -574,3 +482,68 @@ elems = , "xml" , "zipcode" ] + +-- * Attributes + +-- | Convenient alias, forcing the types +xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs +xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>) + +-- | Extract attributes +partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots) +partitionAttrs ts = (attrs,cs) + where + (as,cs) = (`Seq.partition` ts) $ \case + Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True + _ -> False + attrs = attr <$> as + attr = \case + Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a -> + Cell bp ep (xmlLocalName n, v) + where + v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a + _ -> undefined + +getAttrId :: Roots -> TL.Text +getAttrId ts = + case Seq.viewl ts of + EmptyL -> "" + t :< _ -> Plain.plainDocument $ Seq.singleton t + +setAttr :: + Cell (XmlName, TL.Text) -> + Seq (Cell (XmlName, TL.Text)) -> + Seq (Cell (XmlName, TL.Text)) +setAttr a@(unCell -> (k, _v)) as = + case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of + Just idx -> Seq.update idx a as + Nothing -> a <| as + +defaultAttr :: + Seq (Cell (XmlName, TL.Text)) -> + Cell (XmlName, TL.Text) -> + Seq (Cell (XmlName, TL.Text)) +defaultAttr as a@(unCell -> (k, _v)) = + case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of + Just _idx -> as + Nothing -> a <| as + +-- * Text + +-- | Unify two 'XMLs', merging border 'XmlText's if any. +unionXml :: XMLs -> XMLs -> XMLs +unionXml x y = + case (Seq.viewr x, Seq.viewl y) of + (xs :> x0, y0 :< ys) -> + case (x0,y0) of + ( Tree0 (Cell bx ex (XmlText tx)) + , Tree0 (Cell by ey (XmlText ty)) ) -> + xs `unionXml` + Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml` + ys + _ -> x <> y + (Seq.EmptyR, _) -> y + (_, Seq.EmptyL) -> x + +unionsXml :: Foldable f => f XMLs -> XMLs +unionsXml = foldl' unionXml mempty -- 2.42.0 From 7ae7146ee69a660b57df24d67ae9829cee6f8c07 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 9 Feb 2018 03:28:55 +0100 Subject: [PATCH 15/16] Fix parsing HeaderSection. --- Language/TCT/Debug.hs | 4 ++ Language/TCT/Tree.hs | 130 +++++++++++++++++++++++--------------- Language/TCT/Write/XML.hs | 64 +++++++++++++------ 3 files changed, 130 insertions(+), 68 deletions(-) diff --git a/Language/TCT/Debug.hs b/Language/TCT/Debug.hs index b5195fa..b4d81c1 100644 --- a/Language/TCT/Debug.hs +++ b/Language/TCT/Debug.hs @@ -114,6 +114,10 @@ debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r) debug1 _nf _na = id {-# INLINE debug1 #-} +debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r +debug1_ _nf _na = id +{-# INLINE debug1_ #-} + debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r) debug2 _nf _na _nb = id {-# INLINE debug2 #-} diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index 0aaa969..9a16a89 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -145,7 +145,7 @@ initRows = [Tree0 (Cell p p NodeGroup)] -- This is the main entry point to build 'Rows' by accumulating 'Row' into them. mergeRow :: Rows -> Row -> Rows mergeRow rows row = - debug2_ "mergeRow" ("news",row) ("olds",rows) $ + debug2_ "mergeRow" ("news",List.reverse row) ("olds",rows) $ mergeRowPrefix 0 rows $ List.reverse row -- | Merge by considering matching prefixes. @@ -164,20 +164,21 @@ mergeRowPrefix col rows row = , _old@(Tree (Cell _bo eo _o) _os):_olds ) -> case collapseRowsWhile isCollapsable rows of [] -> mergeRowIndent rows row - head@(unTree -> Cell bh _eh h) : olds' -> + head@(unTree -> ch@(Cell bh _eh h)) : olds' -> case (n,h) of -- NOTE: zipping: when new is HeaderGreat, collapse last line downto col -- then check if there is a matching HeaderGreat, -- if so, discard new and restart with a col advanced to new's beginning - (NodeHeader hn@HeaderGreat{}, NodeHeader hh@HeaderGreat{}) + (NodeHeader HeaderGreat{}, NodeHeader HeaderGreat{}) + | isAdjacent && isMatching ch -> discard + {- | pos_column bn == pos_column bh , isAdjacent - , hn == hh -> discard + , hn == hh + -} -- NOTE: same for HeaderBar - (NodeHeader hn@HeaderBar{}, NodeHeader hh@HeaderBar{}) - | pos_column bn == pos_column bh - , isAdjacent - , hn == hh -> discard + (NodeHeader HeaderBar{}, NodeHeader HeaderBar{}) + | isAdjacent && isMatching ch -> discard -- NOTE: collapsing: any other new aligned or on the right of an adjacent head -- makes it collapse entirely (_, NodeHeader HeaderGreat{}) @@ -190,11 +191,15 @@ mergeRowPrefix col rows row = isAdjacent = pos_line bn - pos_line eo <= 1 discard = debug "mergeRowPrefix/discard" $ mergeRowPrefix (pos_column bh) rows news collapse = debug "mergeRowPrefix/collapse" $ mergeRowPrefix col (collapseRoot head olds') row - where - isCollapsable = -- debug2 "mergeRowPrefix/isCollapsable" "new" "old" $ - \_new@(unTree -> Cell bn _en _n) _old@(unTree -> Cell bo eo _o) -> - (pos_line bn - pos_line eo <= 1) && -- adjacent - col < pos_column bo -- righter than col + where + isMatching (Cell bh _eh h) = + pos_column bn == pos_column bh && + n == h + isCollapsable = debug2 "mergeRowPrefix/isCollapsable" "new" "old" $ + \_t0@(unTree -> c0@(Cell b0 _e0 _n0)) _t1@(unTree -> Cell b1 e1 _n1) -> + not (isMatching c0) && + (pos_line b0 - pos_line e1 <= 1) && -- adjacent + col < pos_column b1 -- righter than col -- | Merge by considering indentation. mergeRowIndent :: Rows -> Row -> Rows @@ -241,23 +246,27 @@ mergeRowIndent rows row = , not isVerbatim -> collapse | isAdjacent -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns) -- NOTE: HeaderSection can parent Nodes at the same level - (NodeHeader (HeaderSection lvlNew), _) - | rows'@(sec:olds') <- collapseRowsWhile isCollapsable rows - , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- sec -> + (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) -> if debug0 "mergeRowIndent/lvlNew" lvlNew > debug0 "mergeRowIndent/lvlOld" lvlOld - then -- # sec - -- ## new - {-concat using sec-} List.reverse row <> rows' - else -- ## sec or # sec - -- # new # new - {-collapse using sec-} mergeRowIndent (collapseRoot sec olds') row + -- # old + -- ## new + then concat + -- ## old or # old + -- # new # new + else collapse + -- NOTE: old is no HeaderSection, then collapse to any older and loop + (NodeHeader HeaderSection{}, _) + -- | rows'@(sec:olds') <- collapseSection (pos_column bn) rows + | rows'@(sec:_) <- collapseRowsWhile isCollapsable rows + , (unTree -> unCell -> NodeHeader HeaderSection{}) <- sec -> + mergeRowIndent rows' row where - isCollapsable = -- debug2 "mergeRowIndent/isCollapsable" "new" "old" $ - \_new _old@(unTree -> Cell bt _et t) -> - case t of + isCollapsable = debug2 "mergeRowIndent/isCollapsable" "new" "old" $ + \_t0@(unTree -> Cell b0 _e0 n0) _t1 -> + case n0 of NodeHeader HeaderSection{} -> False - _ -> pos_column bt == pos_column bn + _ -> pos_column bn == pos_column b0 -- NOTE: in case of alignment, HeaderSection is parent (_, NodeHeader HeaderSection{}) -> concat -- @@ -306,11 +315,23 @@ mergeRowIndent rows row = -- before calling 'mergeRowIndent' on it to get the given 'Rows'. collapseRows :: Rows -> Roots collapseRows rows = + debug1_ "collapseRows" ("rows",rows) $ case collapseRowsWhile (\_new _old -> True) rows of [t] -> subTrees t _ -> undefined -- NOTE: subTrees returns the children of the updated initRows +-- | Collapse downto any last HeaderSection, returning it and its level. +collapseSection :: ColNum -> Rows -> Rows +collapseSection col = debug1 "collapseSection" "rows" go + where + go rows@(new@(unTree -> Cell bn _en n):olds) + | col <= pos_column bn = + case n of + NodeHeader HeaderSection{} -> rows + _ -> collapseSection col $ collapseRoot new $ go olds + go _ = mempty + collapseRowsWhile :: (Root -> Root -> Bool) -> Rows -> Rows collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case [] -> mempty @@ -320,41 +341,46 @@ collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case old@(Tree (Cell bo eo o) _os):olds | not $ test new old -> rows | otherwise -> - case debug0 "colNew" (pos_column bn) `compare` - debug0 "colOld" (pos_column bo) of + case debug0 "collapseRowsWhile/colNew" (pos_column bn) `compare` + debug0 "collapseRowsWhile/colOld" (pos_column bo) of -- NOTE: new is vertically aligned EQ -> case (n,o) of -- NOTE: HeaderSection can parent Nodes at the same level - (NodeHeader (HeaderSection lvlNew), _) - | sec:olds' <- collapseRowsWhile isCollapsable news - , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- sec -> + (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) -> if debug0 "collapseRowsWhile/lvlNew" lvlNew > debug0 "collapseRowsWhile/lvlOld" lvlOld - then -- # sec - -- ## new - collapseRowsWhile test $ collapseRoot new $ sec:olds' - else -- ## sec or # sec - -- # new # new - collapseRowsWhile test $ new:collapseRoot sec olds' + -- # old + -- ## new + then collapse + -- ## old or # old + -- # new # new + else + debug "collapseRowsWhile/replace" $ + collapseRowsWhile test $ (new:) $ collapseRoot old olds + -- NOTE: old is no HeaderSection, then collapse to any older and loop + (NodeHeader HeaderSection{}, _) + | news'@(sec:_) <- debug0 "collapseRowsWhile/section" $ collapseRowsWhile isCollapsable news + , (unTree -> unCell -> NodeHeader HeaderSection{}) <- sec -> + collapseRowsWhile test news' where - isCollapsable = - \_new _old@(unTree -> Cell bt _et t) -> - case t of + isCollapsable = debug2 "collapseRowsWhile/isCollapsable" "new" "old" $ + \_t0@(unTree -> Cell b0 _e0 n0) _t1 -> + case n0 of NodeHeader HeaderSection{} -> False - _ -> pos_column bt == pos_column bn + _ -> pos_column bn == pos_column b0 -- NOTE: in case of alignment, HeaderSection is parent - (_, NodeHeader HeaderSection{}) -> collapse + (_, NodeHeader HeaderSection{}) -> debug "collapseRowsWhile/section/parent" collapse -- NOTE: merge within old NodePara. - (_, NodePara{}) | isAdjacent -> collapse + (_, NodePara) | isAdjacent -> collapse -- _ -> collapse2 -- NOTE: new is either on the left or on the right _ -> collapse where isAdjacent = pos_line bn - pos_line eo <= 1 - collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new news - collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old olds + collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new $ news + collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old $ olds -- | Put a 'Root' as a child of the head 'Root'. -- @@ -367,7 +393,7 @@ collapseRoot new@(Tree (Cell bn en n) _ns) rows = [] -> return new old@(Tree (Cell bo eo o) os) : olds -> case (n,o) of - -- NOTE: never put a child into NodeText + -- NOTE: no child into NodeText (_, NodeText{}) -> collapse2 -- NOTE: NodeText can begin a NodePara (NodeText tn, _) | not $ TL.null tn -> @@ -383,10 +409,14 @@ collapseRoot new@(Tree (Cell bn en n) _ns) rows = _ -> collapse -- NOTE: amongst remaining nodes, only adjacent ones may enter an old NodePara. -- Note that since a NodePara is never adjacent to another, - -- it is not nested within into another. - -- Note that an adjacent HeaderSection can enter a NodePara. - (_, NodePara) | isAdjacent -> collapse - | otherwise -> collapse2 + -- it is not nested within another. + (_, NodePara) + | isAdjacent -> + case n of + -- NOTE: no HeaderSection (even adjacent) within a NodePara + NodeHeader HeaderSection{} -> collapse2 + _ -> collapse + | otherwise -> collapse2 _ -> collapse where isAdjacent = pos_line bn - pos_line eo <= 1 diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index c3f02cd..5d0ece5 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -12,15 +12,16 @@ import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) -import Data.Functor ((<$>), (<$)) +import Data.Functor ((<$>), (<$), ($>)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|)) import Data.Set (Set) import Data.TreeSeq.Strict (Tree(..)) import Data.Tuple (uncurry) -import Prelude (undefined) +import Prelude (Num(..), undefined) import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Sequence as Seq @@ -30,7 +31,7 @@ import qualified System.FilePath as FP import Text.Blaze.XML () import Language.TCT hiding (Parser) --- import Language.TCT.Debug +import Language.TCT.Debug import Language.XML -- | Main entry point @@ -45,11 +46,12 @@ xmlDocument :: Roots -> XMLs xmlDocument doc = -- (`S.evalState` def) $ case Seq.viewl doc of - Tree (unCell -> NodeHeader HeaderSection{}) body :< foot -> - case Seq.viewl body of - title@(unTree -> Cell bt et NodePara{}) :< content -> + sec@(Tree (unCell -> NodeHeader HeaderSection{}) _body) :< foot -> + let (titles, content) = partitionSection sec in + case Seq.viewl titles of + (unTree -> Cell bt et _) :< _ -> xmlify def - { inh_titles = return title + { inh_titles = titles , inh_figure = True } contentWithAbout <> xmlify def foot @@ -64,6 +66,23 @@ xmlDocument doc = _ -> xmlify def doc _ -> xmlify def doc +partitionSection :: Root -> (Roots, Roots) +partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) = + case Seq.viewl body of + EmptyL -> mempty + title@(unTree -> Cell _bt et NodePara) :< rest -> + let (subtitles, content) = spanlSubtitles et rest in + (title <| (subtitles >>= subTrees), content) + where + spanlSubtitles ep ts = + case Seq.viewl ts of + sub@(unTree -> Cell bs es (NodeHeader (HeaderSection lvlSub))) :< rs + | lvlSub <= lvlPar + , pos_line bs - pos_line ep <= 1 -> + let (subs, ts') = spanlSubtitles es rs in + (sub <| subs, ts') + _ -> (mempty, ts) + {- -- * Type 'Xmls' type Xmls = S.State State XMLs @@ -208,7 +227,7 @@ instance Xmlify Roots where go inh{inh_para} ts -} instance Xmlify Root where - xmlify inh (Tree cel@(Cell bp ep nod) ts) = + xmlify inh tr@(Tree cel@(Cell bp ep nod) ts) = case nod of NodeGroup -> xmlify inh ts ---------------------- @@ -224,12 +243,23 @@ instance Xmlify Root where case hdr of -- HeaderSection{} -> - let (attrs,body) = partitionAttrs ts in Seq.singleton $ - element "section" $ - xmlAttrs (attrs `defaultAttr` Cell ep ep ("id",getAttrId body)) <> - xmlify inh' body + element "section" $ head <> xmlify inh' body where + (titles, content) = partitionSection tr + (attrs, body) = partitionAttrs content + head = + case Seq.viewl titles of + EmptyL -> mempty + title@(unTree -> ct) :< subtitles -> + xmlAttrs (attrs `defaultAttr` (ct $> ("id",getAttrId title))) <> + aliases + where + aliases = + subtitles >>= \subtitle@(unTree -> cs) -> + return $ + Tree (cs $> XmlElem "alias") $ + xmlAttrs (return $ cs $> ("id",getAttrId subtitle)) inh' = inh { inh_para = xmlTitle : List.repeat xmlPara , inh_figure = True @@ -249,7 +279,8 @@ instance Xmlify Root where _ | inh_figure inh && not (n`List.elem`elems) -> Seq.singleton $ element "figure" $ - xmlAttrs (setAttr (Cell ep ep ("type",n)) attrs) <> + -- xmlAttrs (setAttr (Cell ep ep ("type",n)) attrs) <> + xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", n)) <> case toList body of [Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body _ -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body @@ -504,11 +535,8 @@ partitionAttrs ts = (attrs,cs) v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a _ -> undefined -getAttrId :: Roots -> TL.Text -getAttrId ts = - case Seq.viewl ts of - EmptyL -> "" - t :< _ -> Plain.plainDocument $ Seq.singleton t +getAttrId :: Root -> TL.Text +getAttrId = Plain.plainDocument . Seq.singleton setAttr :: Cell (XmlName, TL.Text) -> -- 2.42.0 From 49aa8575d9d8d29553d5ba4a9e650519c74405c5 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sun, 11 Feb 2018 05:42:37 +0100 Subject: [PATCH 16/16] Add golden tests. --- Data/TreeSeq/Strict.hs | 2 - GNUmakefile | 2 +- HLint.hs | 11 +++ Language/DTC/HLint.hs | 1 + Language/DTC/Read/HLint.hs | 1 + Language/DTC/Write/HLint.hs | 1 + Language/RNC/HLint.hs | 1 + Language/TCT/Debug.hs | 59 +++++++------ Language/TCT/HLint.hs | 1 + Language/TCT/Read.hs | 7 +- Language/TCT/Read/Cell.hs | 2 - Language/TCT/Read/HLint.hs | 1 + Language/TCT/Read/Token.hs | 5 +- Language/TCT/Read/Tree.hs | 2 - Language/TCT/Tree.hs | 34 ++++---- Language/TCT/Write/HLint.hs | 1 + Language/TCT/Write/HTML5.hs | 10 +-- Language/TCT/Write/Plain.hs | 8 +- Language/TCT/Write/XML.hs | 46 +++------- Language/XML.hs | 1 - Text/Blaze/Utils.hs | 2 + exe/HLint.hs | 1 + exe/cli/HLint.hs | 1 + exe/cli/Main.hs | 6 +- hdoc.cabal | 26 +++--- stack.yaml | 4 +- test/Golden.hs | 92 ++++++++++++++++++++ test/Golden/.gitattributes | 1 + test/Golden/TCT/HeaderColon/0001.tct | 1 + test/Golden/TCT/HeaderColon/0001.tct.ast | 2 + test/Golden/TCT/HeaderColon/0001.tct.html5 | 2 + test/Golden/TCT/HeaderColon/0001.tct.xml | 2 + test/Golden/TCT/HeaderColon/0002.tct | 1 + test/Golden/TCT/HeaderColon/0002.tct.ast | 4 + test/Golden/TCT/HeaderColon/0002.tct.html5 | 2 + test/Golden/TCT/HeaderColon/0002.tct.xml | 4 + test/Golden/TCT/HeaderColon/0003.tct | 1 + test/Golden/TCT/HeaderColon/0003.tct.ast | 2 + test/Golden/TCT/HeaderColon/0003.tct.html5 | 2 + test/Golden/TCT/HeaderColon/0003.tct.xml | 2 + test/Golden/TCT/HeaderColon/0004.tct | 2 + test/Golden/TCT/HeaderColon/0004.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0004.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0004.tct.xml | 8 ++ test/Golden/TCT/HeaderColon/0005.tct | 2 + test/Golden/TCT/HeaderColon/0005.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0005.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0005.tct.xml | 6 ++ test/Golden/TCT/HeaderColon/0006.tct | 2 + test/Golden/TCT/HeaderColon/0006.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0006.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0006.tct.xml | 6 ++ test/Golden/TCT/HeaderColon/0007.tct | 2 + test/Golden/TCT/HeaderColon/0007.tct.ast | 6 ++ test/Golden/TCT/HeaderColon/0007.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0007.tct.xml | 4 + test/Golden/TCT/HeaderColon/0008.tct | 2 + test/Golden/TCT/HeaderColon/0008.tct.ast | 6 ++ test/Golden/TCT/HeaderColon/0008.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0008.tct.xml | 4 + test/Golden/TCT/HeaderColon/0009.tct | 3 + test/Golden/TCT/HeaderColon/0009.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0009.tct.html5 | 4 + test/Golden/TCT/HeaderColon/0009.tct.xml | 8 ++ test/Golden/TCT/HeaderColon/0010.tct | 3 + test/Golden/TCT/HeaderColon/0010.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0010.tct.html5 | 4 + test/Golden/TCT/HeaderColon/0010.tct.xml | 6 ++ test/Golden/TCT/HeaderColon/0011.tct | 3 + test/Golden/TCT/HeaderColon/0011.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0011.tct.html5 | 4 + test/Golden/TCT/HeaderColon/0011.tct.xml | 6 ++ test/Golden/TCT/HeaderColon/0012.tct | 3 + test/Golden/TCT/HeaderColon/0012.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0012.tct.html5 | 4 + test/Golden/TCT/HeaderColon/0012.tct.xml | 6 ++ test/Golden/TCT/HeaderColon/0013.tct | 3 + test/Golden/TCT/HeaderColon/0013.tct.ast | 9 ++ test/Golden/TCT/HeaderColon/0013.tct.html5 | 4 + test/Golden/TCT/HeaderColon/0013.tct.xml | 6 ++ test/Golden/TCT/HeaderColon/0014.tct | 2 + test/Golden/TCT/HeaderColon/0014.tct.ast | 3 + test/Golden/TCT/HeaderColon/0014.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0014.tct.xml | 4 + test/Golden/TCT/HeaderColon/0015.tct | 2 + test/Golden/TCT/HeaderColon/0015.tct.ast | 4 + test/Golden/TCT/HeaderColon/0015.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0015.tct.xml | 4 + test/Golden/TCT/HeaderColon/0016.tct | 2 + test/Golden/TCT/HeaderColon/0016.tct.ast | 4 + test/Golden/TCT/HeaderColon/0016.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0016.tct.xml | 4 + test/Golden/TCT/HeaderColon/0017.tct | 2 + test/Golden/TCT/HeaderColon/0017.tct.ast | 4 + test/Golden/TCT/HeaderColon/0017.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0017.tct.xml | 4 + test/Golden/TCT/HeaderColon/0018.tct | 2 + test/Golden/TCT/HeaderColon/0018.tct.ast | 4 + test/Golden/TCT/HeaderColon/0018.tct.html5 | 3 + test/Golden/TCT/HeaderColon/0018.tct.xml | 4 + test/Golden/TCT/HeaderColon/0019.tct | 1 + test/Golden/TCT/HeaderColon/0019.tct.ast | 4 + test/Golden/TCT/HeaderColon/0019.tct.html5 | 2 + test/Golden/TCT/HeaderColon/0019.tct.xml | 4 + test/Golden/TCT/HeaderColon/0020.tct | 1 + test/Golden/TCT/HeaderColon/0020.tct.ast | 4 + test/Golden/TCT/HeaderColon/0020.tct.html5 | 2 + test/Golden/TCT/HeaderColon/0020.tct.xml | 4 + test/Golden/TCT/HeaderGreat/0001.tct | 2 + test/Golden/TCT/HeaderGreat/0001.tct.ast | 6 ++ test/Golden/TCT/HeaderGreat/0001.tct.html5 | 3 + test/Golden/TCT/HeaderGreat/0001.tct.xml | 6 ++ test/Golden/TCT/HeaderGreat/0002.tct | 3 + test/Golden/TCT/HeaderGreat/0002.tct.ast | 6 ++ test/Golden/TCT/HeaderGreat/0002.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0002.tct.xml | 6 ++ test/Golden/TCT/HeaderGreat/0003.tct | 3 + test/Golden/TCT/HeaderGreat/0003.tct.ast | 8 ++ test/Golden/TCT/HeaderGreat/0003.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0003.tct.xml | 10 +++ test/Golden/TCT/HeaderGreat/0004.tct | 3 + test/Golden/TCT/HeaderGreat/0004.tct.ast | 8 ++ test/Golden/TCT/HeaderGreat/0004.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0004.tct.xml | 10 +++ test/Golden/TCT/HeaderGreat/0005.tct | 3 + test/Golden/TCT/HeaderGreat/0005.tct.ast | 10 +++ test/Golden/TCT/HeaderGreat/0005.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0005.tct.xml | 14 +++ test/Golden/TCT/HeaderGreat/0006.tct | 3 + test/Golden/TCT/HeaderGreat/0006.tct.ast | 16 ++++ test/Golden/TCT/HeaderGreat/0006.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0006.tct.xml | 18 ++++ test/Golden/TCT/HeaderGreat/0007.tct | 3 + test/Golden/TCT/HeaderGreat/0007.tct.ast | 16 ++++ test/Golden/TCT/HeaderGreat/0007.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0007.tct.xml | 18 ++++ test/Golden/TCT/HeaderGreat/0008.tct | 3 + test/Golden/TCT/HeaderGreat/0008.tct.ast | 16 ++++ test/Golden/TCT/HeaderGreat/0008.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0008.tct.xml | 18 ++++ test/Golden/TCT/HeaderGreat/0009.tct | 4 + test/Golden/TCT/HeaderGreat/0009.tct.ast | 11 +++ test/Golden/TCT/HeaderGreat/0009.tct.html5 | 5 ++ test/Golden/TCT/HeaderGreat/0009.tct.xml | 12 +++ test/Golden/TCT/HeaderGreat/0010.tct | 4 + test/Golden/TCT/HeaderGreat/0010.tct.ast | 11 +++ test/Golden/TCT/HeaderGreat/0010.tct.html5 | 5 ++ test/Golden/TCT/HeaderGreat/0010.tct.xml | 12 +++ test/Golden/TCT/HeaderGreat/0011.tct | 3 + test/Golden/TCT/HeaderGreat/0011.tct.ast | 14 +++ test/Golden/TCT/HeaderGreat/0011.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0011.tct.xml | 16 ++++ test/Golden/TCT/HeaderGreat/0012.tct | 3 + test/Golden/TCT/HeaderGreat/0012.tct.ast | 10 +++ test/Golden/TCT/HeaderGreat/0012.tct.html5 | 4 + test/Golden/TCT/HeaderGreat/0012.tct.xml | 12 +++ test/Golden/TCT/HeaderGreat/0013.tct | 2 + test/Golden/TCT/HeaderGreat/0013.tct.ast | 6 ++ test/Golden/TCT/HeaderGreat/0013.tct.html5 | 3 + test/Golden/TCT/HeaderGreat/0013.tct.xml | 6 ++ test/Golden/TCT/HeaderGreat/0014.tct | 2 + test/Golden/TCT/HeaderGreat/0014.tct.ast | 11 +++ test/Golden/TCT/HeaderGreat/0014.tct.html5 | 3 + test/Golden/TCT/HeaderGreat/0014.tct.xml | 12 +++ test/Golden/TCT/HeaderGreat/0015.tct | 2 + test/Golden/TCT/HeaderGreat/0015.tct.ast | 15 ++++ test/Golden/TCT/HeaderGreat/0015.tct.html5 | 3 + test/Golden/TCT/HeaderGreat/0015.tct.xml | 20 +++++ test/Golden/TCT/HeaderSection/0000.tct | 3 + test/Golden/TCT/HeaderSection/0000.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0000.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0000.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0001.tct | 3 + test/Golden/TCT/HeaderSection/0001.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0001.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0001.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0002.tct | 3 + test/Golden/TCT/HeaderSection/0002.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0002.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0002.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0003.tct | 3 + test/Golden/TCT/HeaderSection/0003.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0003.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0003.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0004.tct | 3 + test/Golden/TCT/HeaderSection/0004.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0004.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0004.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0005.tct | 3 + test/Golden/TCT/HeaderSection/0005.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0005.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0005.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0006.tct | 3 + test/Golden/TCT/HeaderSection/0006.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0006.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0006.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0007.tct | 3 + test/Golden/TCT/HeaderSection/0007.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0007.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0007.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0008.tct | 3 + test/Golden/TCT/HeaderSection/0008.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0008.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0008.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0009.tct | 3 + test/Golden/TCT/HeaderSection/0009.tct.ast | 16 ++++ test/Golden/TCT/HeaderSection/0009.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0009.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0010.tct | 6 ++ test/Golden/TCT/HeaderSection/0010.tct.ast | 31 +++++++ test/Golden/TCT/HeaderSection/0010.tct.html5 | 7 ++ test/Golden/TCT/HeaderSection/0010.tct.xml | 26 ++++++ test/Golden/TCT/HeaderSection/0011.tct | 2 + test/Golden/TCT/HeaderSection/0011.tct.ast | 9 ++ test/Golden/TCT/HeaderSection/0011.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0011.tct.xml | 8 ++ test/Golden/TCT/HeaderSection/0012.tct | 2 + test/Golden/TCT/HeaderSection/0012.tct.ast | 9 ++ test/Golden/TCT/HeaderSection/0012.tct.html5 | 3 + test/Golden/TCT/HeaderSection/0012.tct.xml | 10 +++ test/Golden/TCT/HeaderSection/0013.tct | 3 + test/Golden/TCT/HeaderSection/0013.tct.ast | 14 +++ test/Golden/TCT/HeaderSection/0013.tct.html5 | 4 + test/Golden/TCT/HeaderSection/0013.tct.xml | 14 +++ test/Golden/TCT/HeaderSection/0014.tct | 5 ++ test/Golden/TCT/HeaderSection/0014.tct.ast | 22 +++++ test/Golden/TCT/HeaderSection/0014.tct.html5 | 6 ++ test/Golden/TCT/HeaderSection/0014.tct.xml | 22 +++++ test/HLint.hs | 1 + test/Main.hs | 15 ++++ 230 files changed, 1577 insertions(+), 115 deletions(-) create mode 100644 HLint.hs create mode 120000 Language/DTC/HLint.hs create mode 120000 Language/DTC/Read/HLint.hs create mode 120000 Language/DTC/Write/HLint.hs create mode 120000 Language/RNC/HLint.hs create mode 120000 Language/TCT/HLint.hs create mode 120000 Language/TCT/Read/HLint.hs create mode 120000 Language/TCT/Write/HLint.hs create mode 120000 exe/HLint.hs create mode 120000 exe/cli/HLint.hs create mode 100644 test/Golden.hs create mode 100644 test/Golden/.gitattributes create mode 100644 test/Golden/TCT/HeaderColon/0001.tct create mode 100644 test/Golden/TCT/HeaderColon/0001.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0001.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0001.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0002.tct create mode 100644 test/Golden/TCT/HeaderColon/0002.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0002.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0002.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0003.tct create mode 100644 test/Golden/TCT/HeaderColon/0003.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0003.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0003.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0004.tct create mode 100644 test/Golden/TCT/HeaderColon/0004.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0004.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0004.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0005.tct create mode 100644 test/Golden/TCT/HeaderColon/0005.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0005.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0005.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0006.tct create mode 100644 test/Golden/TCT/HeaderColon/0006.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0006.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0006.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0007.tct create mode 100644 test/Golden/TCT/HeaderColon/0007.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0007.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0007.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0008.tct create mode 100644 test/Golden/TCT/HeaderColon/0008.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0008.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0008.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0009.tct create mode 100644 test/Golden/TCT/HeaderColon/0009.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0009.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0009.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0010.tct create mode 100644 test/Golden/TCT/HeaderColon/0010.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0010.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0010.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0011.tct create mode 100644 test/Golden/TCT/HeaderColon/0011.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0011.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0011.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0012.tct create mode 100644 test/Golden/TCT/HeaderColon/0012.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0012.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0012.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0013.tct create mode 100644 test/Golden/TCT/HeaderColon/0013.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0013.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0013.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0014.tct create mode 100644 test/Golden/TCT/HeaderColon/0014.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0014.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0014.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0015.tct create mode 100644 test/Golden/TCT/HeaderColon/0015.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0015.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0015.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0016.tct create mode 100644 test/Golden/TCT/HeaderColon/0016.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0016.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0016.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0017.tct create mode 100644 test/Golden/TCT/HeaderColon/0017.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0017.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0017.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0018.tct create mode 100644 test/Golden/TCT/HeaderColon/0018.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0018.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0018.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0019.tct create mode 100644 test/Golden/TCT/HeaderColon/0019.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0019.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0019.tct.xml create mode 100644 test/Golden/TCT/HeaderColon/0020.tct create mode 100644 test/Golden/TCT/HeaderColon/0020.tct.ast create mode 100644 test/Golden/TCT/HeaderColon/0020.tct.html5 create mode 100644 test/Golden/TCT/HeaderColon/0020.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0001.tct create mode 100644 test/Golden/TCT/HeaderGreat/0001.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0001.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0001.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0002.tct create mode 100644 test/Golden/TCT/HeaderGreat/0002.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0002.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0002.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0003.tct create mode 100644 test/Golden/TCT/HeaderGreat/0003.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0003.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0003.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0004.tct create mode 100644 test/Golden/TCT/HeaderGreat/0004.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0004.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0004.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0005.tct create mode 100644 test/Golden/TCT/HeaderGreat/0005.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0005.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0005.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0006.tct create mode 100644 test/Golden/TCT/HeaderGreat/0006.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0006.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0006.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0007.tct create mode 100644 test/Golden/TCT/HeaderGreat/0007.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0007.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0007.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0008.tct create mode 100644 test/Golden/TCT/HeaderGreat/0008.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0008.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0008.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0009.tct create mode 100644 test/Golden/TCT/HeaderGreat/0009.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0009.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0009.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0010.tct create mode 100644 test/Golden/TCT/HeaderGreat/0010.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0010.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0010.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0011.tct create mode 100644 test/Golden/TCT/HeaderGreat/0011.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0011.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0011.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0012.tct create mode 100644 test/Golden/TCT/HeaderGreat/0012.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0012.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0012.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0013.tct create mode 100644 test/Golden/TCT/HeaderGreat/0013.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0013.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0013.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0014.tct create mode 100644 test/Golden/TCT/HeaderGreat/0014.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0014.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0014.tct.xml create mode 100644 test/Golden/TCT/HeaderGreat/0015.tct create mode 100644 test/Golden/TCT/HeaderGreat/0015.tct.ast create mode 100644 test/Golden/TCT/HeaderGreat/0015.tct.html5 create mode 100644 test/Golden/TCT/HeaderGreat/0015.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0000.tct create mode 100644 test/Golden/TCT/HeaderSection/0000.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0000.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0000.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0001.tct create mode 100644 test/Golden/TCT/HeaderSection/0001.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0001.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0001.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0002.tct create mode 100644 test/Golden/TCT/HeaderSection/0002.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0002.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0002.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0003.tct create mode 100644 test/Golden/TCT/HeaderSection/0003.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0003.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0003.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0004.tct create mode 100644 test/Golden/TCT/HeaderSection/0004.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0004.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0004.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0005.tct create mode 100644 test/Golden/TCT/HeaderSection/0005.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0005.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0005.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0006.tct create mode 100644 test/Golden/TCT/HeaderSection/0006.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0006.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0006.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0007.tct create mode 100644 test/Golden/TCT/HeaderSection/0007.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0007.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0007.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0008.tct create mode 100644 test/Golden/TCT/HeaderSection/0008.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0008.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0008.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0009.tct create mode 100644 test/Golden/TCT/HeaderSection/0009.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0009.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0009.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0010.tct create mode 100644 test/Golden/TCT/HeaderSection/0010.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0010.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0010.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0011.tct create mode 100644 test/Golden/TCT/HeaderSection/0011.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0011.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0011.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0012.tct create mode 100644 test/Golden/TCT/HeaderSection/0012.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0012.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0012.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0013.tct create mode 100644 test/Golden/TCT/HeaderSection/0013.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0013.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0013.tct.xml create mode 100644 test/Golden/TCT/HeaderSection/0014.tct create mode 100644 test/Golden/TCT/HeaderSection/0014.tct.ast create mode 100644 test/Golden/TCT/HeaderSection/0014.tct.html5 create mode 100644 test/Golden/TCT/HeaderSection/0014.tct.xml create mode 120000 test/HLint.hs create mode 100644 test/Main.hs diff --git a/Data/TreeSeq/Strict.hs b/Data/TreeSeq/Strict.hs index f454ec8..f724efc 100644 --- a/Data/TreeSeq/Strict.hs +++ b/Data/TreeSeq/Strict.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Data.TreeSeq.Strict where @@ -8,7 +7,6 @@ import Control.Monad (Monad(..)) import Data.Bool import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) -import Data.Foldable (foldr) import Data.Function (($), (.)) import Data.Functor (Functor(..), (<$>)) import Data.Monoid (Monoid(..)) diff --git a/GNUmakefile b/GNUmakefile index dabdab4..52d7256 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -33,7 +33,7 @@ doc: %.html/view: %.html sensible-browser $*.html -HLint.hs: $(shell find . -name '*.hs') +HLint.hs: $(shell find . -name '*.hs' -not -name 'HLint.hs') sed -i -e '/^-- BEGIN: generated hints/,/^-- END: Generated by hlint/d' HLint.hs echo '-- BEGIN: generated hints' >> HLint.hs hlint --find . | grep '^'infix | sort -u >> HLint.hs diff --git a/HLint.hs b/HLint.hs new file mode 100644 index 0000000..960eaed --- /dev/null +++ b/HLint.hs @@ -0,0 +1,11 @@ +import "hint" HLint.HLint +ignore "Move brackets to avoid $" +ignore "Reduce duplication" +ignore "Redundant $" +ignore "Redundant do" +ignore "Use camelCase" +ignore "Use import/export shortcut" +ignore "Use list literal" +ignore "Use list literal pattern" +-- BEGIN: generated hints +-- END: generated hints diff --git a/Language/DTC/HLint.hs b/Language/DTC/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/DTC/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/DTC/Read/HLint.hs b/Language/DTC/Read/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/DTC/Read/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/DTC/Write/HLint.hs b/Language/DTC/Write/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/DTC/Write/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/RNC/HLint.hs b/Language/RNC/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/RNC/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/TCT/Debug.hs b/Language/TCT/Debug.hs index b4d81c1..df0b2fd 100644 --- a/Language/TCT/Debug.hs +++ b/Language/TCT/Debug.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} @@ -10,8 +9,9 @@ module Language.TCT.Debug where import Control.Monad (Monad(..), mapM) import Data.Bool +import Data.Eq (Eq(..)) import Data.Foldable (toList, null) -import Data.Function (($), (.)) +import Data.Function (($), (.), id) import Data.Int (Int) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) @@ -26,68 +26,68 @@ import Text.Show (Show(..)) import qualified Control.Monad.Trans.Reader as R import qualified Data.List as List import qualified Data.Text.Lazy as TL +import qualified Debug.Trace as Trace import qualified Text.Megaparsec as P -- * Debug #if DEBUG -import qualified Debug.Trace as Trace debug :: String -> a -> a debug = Trace.trace debug0 :: Pretty a => String -> a -> a -debug0 m a = Trace.trace (m <> ": " <> R.runReader (pretty a) 2) a +debug0 m a = Trace.trace (m <> ": " <> runPretty 2 a) a debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r) debug1 nf na f a = - (\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $ - (Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) f) + (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $ + Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) f a debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r debug1_ nf (na,a) r = - Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) $ - Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ + Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) $ + Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $ r debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r) debug2 nf na nb f a b = - (\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $ + (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $ Trace.trace ("[ " <> nf <> ":" - <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 - <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 + <> "\n " <> na <> " = " <> runPretty 2 a + <> "\n " <> nb <> " = " <> runPretty 2 b ) f a b debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r debug2_ nf (na,a) (nb,b) r = Trace.trace ("[ " <> nf <> ":" - <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 - <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 + <> "\n " <> na <> " = " <> runPretty 2 a + <> "\n " <> nb <> " = " <> runPretty 2 b ) $ - Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ + Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $ r debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r) debug3 nf na nb nc f a b c = - (\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $ + (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $ Trace.trace ("[ " <> nf <> ":" - <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 - <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 - <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2 + <> "\n " <> na <> " = " <> runPretty 2 a + <> "\n " <> nb <> " = " <> runPretty 2 b + <> "\n " <> nc <> " = " <> runPretty 2 c ) f a b c debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r debug3_ nf (na,a) (nb,b) (nc,c) r = Trace.trace ("[ " <> nf <> ":" - <> "\n " <> na <> " = " <> R.runReader (pretty a) 2 - <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2 - <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2 + <> "\n " <> na <> " = " <> runPretty 2 a + <> "\n " <> nb <> " = " <> runPretty 2 b + <> "\n " <> nc <> " = " <> runPretty 2 c ) $ - Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $ + Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $ r debugParser :: @@ -100,7 +100,6 @@ debugParser :: String -> P.Parsec e s a -> P.Parsec e s a debugParser = P.dbg #else -import Data.Function (id) debug :: String -> a -> a debug _m = id @@ -151,17 +150,23 @@ class Pretty a where pretty :: a -> R.Reader Int String default pretty :: Show a => a -> R.Reader Int String pretty = return . show + +runPretty :: Pretty a => Int -> a -> String +runPretty i a = pretty a `R.runReader` i + instance Pretty Bool instance Pretty Int instance Pretty Text instance Pretty TL.Text +instance Pretty P.Pos instance (Pretty a, Pretty b) => Pretty (a,b) where pretty (a,b) = do i <- R.ask a' <- R.local (+2) $ pretty a b' <- R.local (+2) $ pretty b return $ - "\n" <> List.replicate i ' ' <> "( " <> a' <> + (if i == 0 then "" else "\n") <> + List.replicate i ' ' <> "( " <> a' <> "\n" <> List.replicate i ' ' <> ", " <> b' <> "\n" <> List.replicate i ' ' <> ") " instance Pretty a => Pretty [a] where @@ -170,7 +175,8 @@ instance Pretty a => Pretty [a] where i <- R.ask s <- R.local (+2) $ mapM pretty as return $ - "\n" <> List.replicate i ' ' <> "[ " <> + (if i == 0 then "" else "\n") <> + List.replicate i ' ' <> "[ " <> List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> "\n" <> List.replicate i ' ' <> "] " instance Pretty a => Pretty (NonEmpty a) where @@ -183,7 +189,8 @@ instance Pretty a => Pretty (Seq a) where i <- R.ask s <- R.local (+2) $ mapM pretty as return $ - "\n" <> List.replicate i ' ' <> "[ " <> + (if i == 0 then "" else "\n") <> + List.replicate i ' ' <> "[ " <> List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <> "\n" <> List.replicate i ' ' <> "] " instance Pretty a => Pretty (Maybe a) where diff --git a/Language/TCT/HLint.hs b/Language/TCT/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/TCT/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs index 23061c1..d3e3e48 100644 --- a/Language/TCT/Read.hs +++ b/Language/TCT/Read.hs @@ -26,12 +26,12 @@ import Language.TCT.Read.Tree import Language.TCT.Read.Token -- | Parsing is done in two phases: --- +-- -- 1. indentation-sensitive parsing on 'TL.Text' -- 2. Pair-sensitive parsing on some 'NodeText's resulting of 1. readTrees :: FilePath -> TL.Text -> - Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) (Trees (Cell Node)) + Either ErrorRead (Trees (Cell Node)) readTrees inp txt = do trs <- P.runParser (p_Trees <* P.eof) inp txt traverse (go NodeGroup) $ debug0 "readTrees" trs @@ -62,3 +62,6 @@ readTrees inp txt = do NodeGroup -> parent NodePara -> parent _ -> nod + +-- * Type 'ErrorRead' +type ErrorRead = P.ParseError (P.Token TL.Text) (P.ErrorFancy Void) diff --git a/Language/TCT/Read/Cell.hs b/Language/TCT/Read/Cell.hs index 6dbe56d..602d7ce 100644 --- a/Language/TCT/Read/Cell.hs +++ b/Language/TCT/Read/Cell.hs @@ -26,8 +26,6 @@ import qualified Text.Megaparsec as P import Language.TCT.Cell import Language.TCT.Debug -instance Pretty P.Pos - -- * Type 'Parser' -- | Convenient alias. type Parser e s a = diff --git a/Language/TCT/Read/HLint.hs b/Language/TCT/Read/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/TCT/Read/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/TCT/Read/Token.hs b/Language/TCT/Read/Token.hs index c974eb7..bca94f9 100644 --- a/Language/TCT/Read/Token.hs +++ b/Language/TCT/Read/Token.hs @@ -4,7 +4,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Read.Token where @@ -132,7 +131,7 @@ appendLexeme lex acc = -- debug2 "appendLexeme" "lex" "acc" $ \lex acc -> LexemePairOpen ps -> foldl' open acc ps where -- NOTE: insert an empty node to encode , not - open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendPairsText` Cell ep ep "" + open a p@(Cell _bp ep PairElem{}) = openPair a p `appendPairsText` Cell ep ep "" open a p = openPair a p LexemePairClose ps -> foldl' closePair acc ps LexemePairAny ps -> foldl' openPair acc ps @@ -387,7 +386,7 @@ instance TagFrom (Cell TL.Text) where tagFrom (Cell bp ep t) | (w,r) <- TL.span isTagChar t , not $ TL.null w - , ew <- pos_column bp + sum (Text.length <$> (TL.toChunks w)) = + , ew <- pos_column bp + sum (Text.length <$> TL.toChunks w) = Just ( Cell bp bp{pos_column=ew} w , Cell bp{pos_column=ew} ep r ) diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs index 712b247..af83f33 100644 --- a/Language/TCT/Read/Tree.hs +++ b/Language/TCT/Read/Tree.hs @@ -2,9 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module Language.TCT.Read.Tree where import Control.Applicative (Applicative(..), Alternative(..)) diff --git a/Language/TCT/Tree.hs b/Language/TCT/Tree.hs index 9a16a89..558c866 100644 --- a/Language/TCT/Tree.hs +++ b/Language/TCT/Tree.hs @@ -87,19 +87,19 @@ type LevelSection = Int -- * Type 'Pair' data Pair - = PairElem !ElemName !ElemAttrs -- ^ @value@ - | PairHash -- ^ @#value#@ - | PairStar -- ^ @*value*@ - | PairSlash -- ^ @/value/@ + = PairElem !ElemName !ElemAttrs -- ^ @\text\@ + | PairHash -- ^ @\#text#@ + | PairStar -- ^ @*text*@ + | PairSlash -- ^ @/text/@ | PairUnderscore -- ^ @_value_@ - | PairDash -- ^ @-value-@ - | PairBackquote -- ^ @`value`@ - | PairSinglequote -- ^ @'value'@ - | PairDoublequote -- ^ @"value"@ - | PairFrenchquote -- ^ @«value»@ - | PairParen -- ^ @(value)@ - | PairBrace -- ^ @{value}@ - | PairBracket -- ^ @[value]@ + | PairDash -- ^ @-text-@ + | PairBackquote -- ^ @`text`@ + | PairSinglequote -- ^ @'text'@ + | PairDoublequote -- ^ @"text"@ + | PairFrenchquote -- ^ @«text»@ + | PairParen -- ^ @(text)@ + | PairBrace -- ^ @{text}@ + | PairBracket -- ^ @[text]@ deriving (Eq,Ord,Show) instance Pretty Pair @@ -231,7 +231,7 @@ mergeRowIndent rows row = debug0 "mergeRowIndent/isIndented" $ case olds of [] -> True - (unTree -> cell_end -> ep) : _ -> + (unTree -> (cell_end -> ep)) : _ -> case pos_line ep `compare` pos_line bo of LT -> True EQ -> pos_column ep <= pos_column bn @@ -257,9 +257,8 @@ mergeRowIndent rows row = else collapse -- NOTE: old is no HeaderSection, then collapse to any older and loop (NodeHeader HeaderSection{}, _) - -- | rows'@(sec:olds') <- collapseSection (pos_column bn) rows | rows'@(sec:_) <- collapseRowsWhile isCollapsable rows - , (unTree -> unCell -> NodeHeader HeaderSection{}) <- sec -> + , (unTree -> (unCell -> NodeHeader HeaderSection{})) <- sec -> mergeRowIndent rows' row where isCollapsable = debug2 "mergeRowIndent/isCollapsable" "new" "old" $ @@ -301,7 +300,7 @@ mergeRowIndent rows row = -- | Whether a parent semantic want new to stay a NodeText isVerbatim = any p rows where - p (unTree -> unCell -> NodeHeader HeaderBar{}) = True + p (unTree -> (unCell -> NodeHeader HeaderBar{})) = True p _ = False concat = debug "mergeRowIndent/concat" $ List.reverse row <> rows merge m = debug "mergeRowIndent/merge" $ mergeRowIndent (m : olds) news @@ -361,7 +360,7 @@ collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case -- NOTE: old is no HeaderSection, then collapse to any older and loop (NodeHeader HeaderSection{}, _) | news'@(sec:_) <- debug0 "collapseRowsWhile/section" $ collapseRowsWhile isCollapsable news - , (unTree -> unCell -> NodeHeader HeaderSection{}) <- sec -> + , (unTree -> (unCell -> NodeHeader HeaderSection{})) <- sec -> collapseRowsWhile test news' where isCollapsable = debug2 "collapseRowsWhile/isCollapsable" "new" "old" $ @@ -385,6 +384,7 @@ collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case -- | Put a 'Root' as a child of the head 'Root'. -- -- NOTE: 'collapseRoot' is where 'NodePara' may be introduced. +-- -- NOTE: any NodeText/NodeText merging must have been done before. collapseRoot :: Root -> Rows -> Rows collapseRoot new@(Tree (Cell bn en n) _ns) rows = diff --git a/Language/TCT/Write/HLint.hs b/Language/TCT/Write/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/TCT/Write/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs index ce3bdc5..204f1c9 100644 --- a/Language/TCT/Write/HTML5.hs +++ b/Language/TCT/Write/HTML5.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} module Language.TCT.Write.HTML5 where -import Control.Monad (Monad(..), forM_, mapM_, when) +import Control.Monad (Monad(..), forM_, mapM_, when, unless) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) @@ -34,8 +34,8 @@ import Language.TCT.Utils import Text.Blaze.Utils import qualified Language.TCT.Write.Plain as Plain -html5Document :: Trees (Cell Node) -> Html -html5Document body = do +document :: Trees (Cell Node) -> Html +document body = do H.docType H.html $ do H.head $ do @@ -52,7 +52,7 @@ html5Document body = do runStateMarkup def $ html5ify body H.body $ do - H.a ! HA.id ("line-1") $ return () + H.a ! HA.id "line-1" $ return () html5Body titleFrom :: Roots -> Maybe Root @@ -257,7 +257,7 @@ instance Html5ify Root where PairElem name attrs -> do H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do H.span ! HA.class_ "pair-open" $$ o - when (not $ null ts) $ do + unless (null ts) $ do H.span ! HA.class_ "pair-content" $$ html5ify ts H.span ! HA.class_ "pair-close" $$ c where diff --git a/Language/TCT/Write/Plain.hs b/Language/TCT/Write/Plain.hs index 5dcecce..1dd4f08 100644 --- a/Language/TCT/Write/Plain.hs +++ b/Language/TCT/Write/Plain.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.TCT.Write.Plain where @@ -20,7 +19,6 @@ import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..)) import Data.String (String, IsString(..)) -import Data.Tuple (fst) import Prelude (Num(..), error) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S @@ -47,13 +45,13 @@ instance Monoid Plain where mappend = (<>) runPlain :: Plain -> State -> TL.Text -runPlain p s = TLB.toLazyText $ fst $ S.runState p s +runPlain p s = TLB.toLazyText $ S.evalState p s text :: Plainify a => State -> a -> TL.Text text s a = runPlain (plainify a) s -plainDocument :: Roots -> TL.Text -plainDocument doc = text (setStart doc def) doc +document :: Roots -> TL.Text +document doc = text (setStart doc def) doc -- ** Type 'State' data State diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs index 5d0ece5..8c2b57d 100644 --- a/Language/TCT/Write/XML.hs +++ b/Language/TCT/Write/XML.hs @@ -29,10 +29,10 @@ import qualified Data.Text.Lazy as TL import qualified Language.TCT.Write.Plain as Plain import qualified System.FilePath as FP -import Text.Blaze.XML () +-- import Language.TCT.Debug import Language.TCT hiding (Parser) -import Language.TCT.Debug import Language.XML +import Text.Blaze.XML () -- | Main entry point -- @@ -42,8 +42,8 @@ import Language.XML -- (eg. about/title may have a title from the section before, -- hence outside of about). -- Still holding: @'cell_begin' < 'cell_end'@ and 'Cell' nesting. -xmlDocument :: Roots -> XMLs -xmlDocument doc = +document :: Roots -> XMLs +document doc = -- (`S.evalState` def) $ case Seq.viewl doc of sec@(Tree (unCell -> NodeHeader HeaderSection{}) _body) :< foot -> @@ -61,7 +61,7 @@ xmlDocument doc = Nothing -> Tree (Cell bt et $ NodeHeader $ HeaderColon "about" "") mempty <| content Just{} -> content isAbout = \case - (unTree -> unCell -> NodeHeader (HeaderColon "about" _wh)) -> True + (unTree -> (unCell -> NodeHeader (HeaderColon "about" _wh))) -> True _ -> False _ -> xmlify def doc _ -> xmlify def doc @@ -82,27 +82,7 @@ partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) = let (subs, ts') = spanlSubtitles es rs in (sub <| subs, ts') _ -> (mempty, ts) - -{- --- * Type 'Xmls' -type Xmls = S.State State XMLs -type Xml = S.State State XML -instance Semigroup Xmls where - (<>) = liftA2 (<>) -instance Monoid Xmls where - mempty = return mempty - mappend = (<>) - --- * Type 'State' -data State - = State - { state_pos :: Pos - } -instance Default State where - def = State - { state_pos = pos1 - } --} +partitionSection _ = mempty -- * Type 'Inh' data Inh @@ -182,7 +162,7 @@ instance Xmlify Roots where xmlify inh ts _ -> element "rref" $ - xmlAttrs [Cell bb eb ("to",Plain.plainDocument bracket)] <> + xmlAttrs [Cell bb eb ("to",Plain.document bracket)] <> xmlify inh ts ---------------------- -- NOTE: gather HeaderDash @@ -201,7 +181,7 @@ instance Xmlify Roots where where spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots) spanlItems liHeader = - Seq.spanl $ \(unTree -> unCell -> nod) -> + Seq.spanl $ \(unTree -> (unCell -> nod)) -> case nod of NodeHeader (HeaderColon "li" _wh) -> True NodeHeader hdr -> liHeader hdr @@ -276,7 +256,7 @@ instance Xmlify Root where xmlAttrs attrs <> xmlify inh body -- NOTE: in
mode, unreserved nodes become
- _ | inh_figure inh && not (n`List.elem`elems) -> + _ | inh_figure inh && n`List.notElem`elems -> Seq.singleton $ element "figure" $ -- xmlAttrs (setAttr (Cell ep ep ("type",n)) attrs) <> @@ -325,7 +305,7 @@ instance Xmlify Root where HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $ -- debug1_ ("TS", ts) $ -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $ - Plain.plainDocument ts + Plain.document ts -- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing {- TreeSeq.mapAlsoNode @@ -353,7 +333,7 @@ instance Xmlify Root where ---------------------- NodePair pair -> case pair of - PairBracket | to <- Plain.plainDocument ts + PairBracket | to <- Plain.document ts , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to -> Seq.singleton $ element "rref" $ @@ -384,7 +364,7 @@ instance Xmlify Root where PairHash -> Seq.singleton $ element "ref" $ - xmlAttrs [cell ("to",Plain.plainDocument ts)] + xmlAttrs [cell ("to",Plain.document ts)] PairElem name attrs -> Seq.singleton $ element (xmlLocalName name) $ @@ -536,7 +516,7 @@ partitionAttrs ts = (attrs,cs) _ -> undefined getAttrId :: Root -> TL.Text -getAttrId = Plain.plainDocument . Seq.singleton +getAttrId = Plain.document . Seq.singleton setAttr :: Cell (XmlName, TL.Text) -> diff --git a/Language/XML.hs b/Language/XML.hs index f9c797d..6d6d01e 100644 --- a/Language/XML.hs +++ b/Language/XML.hs @@ -20,7 +20,6 @@ import Data.TreeSeq.Strict (Tree) import Prelude (error, pred, succ) import Text.Show (Show(..), showsPrec, showChar, showString) import qualified Data.List as List -import qualified Data.Map.Strict as Map import qualified Data.Text.Lazy as TL import Language.TCT.Cell diff --git a/Text/Blaze/Utils.hs b/Text/Blaze/Utils.hs index 2b2eb8c..04eca30 100644 --- a/Text/Blaze/Utils.hs +++ b/Text/Blaze/Utils.hs @@ -59,8 +59,10 @@ whenText :: Applicative m => Text -> (Text -> m ()) -> m () whenText "" _f = pure () whenText t f = f t +{- instance Semigroup H.AttributeValue where (<>) = mappend +-} instance IsList H.AttributeValue where type Item AttributeValue = AttributeValue fromList = mconcat . List.intersperse " " diff --git a/exe/HLint.hs b/exe/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/exe/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/exe/cli/HLint.hs b/exe/cli/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/exe/cli/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/exe/cli/Main.hs b/exe/cli/Main.hs index ee6f3a9..64aa5cb 100644 --- a/exe/cli/Main.hs +++ b/exe/cli/Main.hs @@ -88,15 +88,15 @@ mainWithCommand (CommandTCT ArgsTCT{..}) = hPrint stderr $ Tree.Pretty tct when (trace_XML trace) $ do hPutStrLn stderr "### XML ###" - let xml = TCT.Write.XML.xmlDocument tct + let xml = TCT.Write.XML.document tct hPrint stderr $ Tree.Pretty xml case format of TctFormatPlain -> TL.putStrLn $ - TCT.Write.Plain.plainDocument tct + TCT.Write.Plain.document tct TctFormatHTML5 -> Blaze.renderMarkupToByteStringIO BS.putStr $ - TCT.Write.HTML5.html5Document tct + TCT.Write.HTML5.document tct {- mainWithCommand (CommandDTC ArgsDTC{..}) = readFile input $ \_fp txt -> diff --git a/hdoc.cabal b/hdoc.cabal index a39fd4d..bcbb974 100644 --- a/hdoc.cabal +++ b/hdoc.cabal @@ -15,8 +15,8 @@ maintainer: Julien Moutinho name: hdoc stability: experimental synopsis: Library and tools for technical and convivial documents -tested-with: GHC==8.0.2 -version: 1.0.0.20170828 +tested-with: GHC==8.2.2 +version: 1.0.0.20180211 Source-Repository head location: git://git.autogeree.net/hdoc @@ -59,7 +59,8 @@ Library Language.TCT.Debug Language.TCT.Write.HTML5 Language.TCT.Write.Plain - -- Language.TCT.Write.XML + Language.TCT.Write.XML + Language.TCT.Utils Language.XML Text.Blaze.DTC Text.Blaze.DTC.Attributes @@ -78,7 +79,7 @@ Library -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-warn-tabs - -- -fhide-source-paths + -fhide-source-paths if flag(debug) cpp-options: -DDEBUG if flag(prof) @@ -117,21 +118,26 @@ Test-Suite hdoc-test -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-warn-tabs - -- -fhide-source-paths + -fhide-source-paths hs-source-dirs: test main-is: Main.hs other-modules: - HUnit + Golden + -- HUnit -- QuickCheck - Types build-depends: base >= 4.6 && < 5 + , blaze-markup + , blaze-html + , bytestring , containers >= 0.5 && < 0.6 , deepseq + , filepath , hdoc -- , QuickCheck >= 2.0 , tasty >= 0.11 - , tasty-hunit + -- , tasty-hunit + , tasty-golden -- , tasty-quickcheck , text , transformers >= 0.4 && < 0.6 @@ -163,7 +169,7 @@ Executable hdoc -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-warn-tabs - -- -fhide-source-paths + -fhide-source-paths if flag(debug) cpp-options: -DDEBUG if flag(prof) @@ -175,7 +181,7 @@ Executable hdoc Read build-depends: base >= 4.6 && < 5 - , ansi-terminal >= 0.4 && < 0.7 + , ansi-terminal >= 0.4 && < 0.8 , blaze-markup , blaze-html , bytestring diff --git a/stack.yaml b/stack.yaml index 6e65a76..1adfccd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,3 @@ -resolver: lts-9.14 +resolver: lts-10.5 packages: - '.' -- location: '/home/julm/src/megaparsec' - extra-dep: true diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 index 0000000..48374d8 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,92 @@ +module Golden where + +-- import qualified System.FilePath as Path +-- import qualified Text.Blaze.Utils as Blaze +import Control.Monad (Monad(..)) +import Data.Either (Either(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String) +import System.IO (IO) +import Text.Show (Show(..)) +import qualified Data.ByteString.Lazy as BS +import qualified Data.List as List +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.TreeSeq.Strict as TreeSeq +import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze + +import Test.Tasty +import Test.Tasty.Golden + +import qualified Language.TCT as TCT +import qualified Language.TCT.Debug as TCT +import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5 +import qualified Language.TCT.Write.Plain as TCT.Write.Plain +import qualified Language.TCT.Write.XML as TCT.Write.XML + +diff :: String -> String -> [String] +diff ref new = ["diff", "-u", ref, new] + +readAST :: String -> IO (Either TCT.ErrorRead TCT.Roots) +readAST inputFile = do + inp <- BS.readFile inputFile + return $ TCT.readTrees inputFile $ TL.decodeUtf8 inp + +unLeft :: Show err => Either err BS.ByteString -> IO BS.ByteString +unLeft = \case + Left err -> return $ TL.encodeUtf8 $ TL.pack $ show err + Right a -> return a + +goldensIO :: IO TestTree +goldensIO = do + inputFiles <- List.sort <$> findByExtension [".tct"] "test/Golden" + return $ + testGroup "TCT" + [ testGroup "AST" + [ goldenVsStringDiff inputFile diff (inputFile <> ".ast") $ + (>>= unLeft) $ + readAST inputFile >>= \ast -> + return $ + TL.encodeUtf8 + . TL.pack + . TCT.runPretty 0 + <$> ast + | inputFile <- inputFiles + ] + , testGroup "Plain" + [ goldenVsStringDiff inputFile diff inputFile $ + (>>= unLeft) $ + readAST inputFile >>= \ast -> + return $ + TL.encodeUtf8 + . (<> TL.singleton '\n') + . TCT.Write.Plain.document + <$> ast + | inputFile <- inputFiles + ] + , testGroup "HTML5" + [ goldenVsStringDiff inputFile diff (inputFile <> ".html5") $ + (>>= unLeft) $ + readAST inputFile >>= \ast -> + return $ + Blaze.renderHtml + . TCT.Write.HTML5.document + <$> ast + | inputFile <- inputFiles + ] + , testGroup "XML" + [ goldenVsStringDiff inputFile diff (inputFile <> ".xml") $ + (>>= unLeft) $ + readAST inputFile >>= \ast -> + return $ + TL.encodeUtf8 + . TL.pack + . show + . TreeSeq.Pretty + . TCT.Write.XML.document + <$> ast + | inputFile <- inputFiles + ] + ] diff --git a/test/Golden/.gitattributes b/test/Golden/.gitattributes new file mode 100644 index 0000000..c5e7bbf --- /dev/null +++ b/test/Golden/.gitattributes @@ -0,0 +1 @@ +*.ast -text diff --git a/test/Golden/TCT/HeaderColon/0001.tct b/test/Golden/TCT/HeaderColon/0001.tct new file mode 100644 index 0000000..0facc06 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0001.tct @@ -0,0 +1 @@ +colon1: diff --git a/test/Golden/TCT/HeaderColon/0001.tct.ast b/test/Golden/TCT/HeaderColon/0001.tct.ast new file mode 100644 index 0000000..7fceb5e --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0001.tct.ast @@ -0,0 +1,2 @@ +[ Tree (Cell 1:1 1:8 (NodeHeader (HeaderColon "colon1" ""))) [] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0001.tct.html5 b/test/Golden/TCT/HeaderColon/0001.tct.html5 new file mode 100644 index 0000000..9d0b361 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0001.tct.html5 @@ -0,0 +1,2 @@ + +colon1: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0001.tct.xml b/test/Golden/TCT/HeaderColon/0001.tct.xml new file mode 100644 index 0000000..9c500ca --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0001.tct.xml @@ -0,0 +1,2 @@ +Cell 1:1 1:8 (XmlElem colon1) + diff --git a/test/Golden/TCT/HeaderColon/0002.tct b/test/Golden/TCT/HeaderColon/0002.tct new file mode 100644 index 0000000..2477f10 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0002.tct @@ -0,0 +1 @@ +colon1: diff --git a/test/Golden/TCT/HeaderColon/0002.tct.ast b/test/Golden/TCT/HeaderColon/0002.tct.ast new file mode 100644 index 0000000..50195a5 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0002.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 1:9 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:9 (NodeText "")) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0002.tct.html5 b/test/Golden/TCT/HeaderColon/0002.tct.html5 new file mode 100644 index 0000000..5b58502 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0002.tct.html5 @@ -0,0 +1,2 @@ + +colon1: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0002.tct.xml b/test/Golden/TCT/HeaderColon/0002.tct.xml new file mode 100644 index 0000000..6a0b792 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0002.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 1:9 (XmlElem colon1) +| +`- Cell 1:9 1:9 (XmlText "") + diff --git a/test/Golden/TCT/HeaderColon/0003.tct b/test/Golden/TCT/HeaderColon/0003.tct new file mode 100644 index 0000000..2271c76 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0003.tct @@ -0,0 +1 @@ +colon1 : diff --git a/test/Golden/TCT/HeaderColon/0003.tct.ast b/test/Golden/TCT/HeaderColon/0003.tct.ast new file mode 100644 index 0000000..f092ff7 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0003.tct.ast @@ -0,0 +1,2 @@ +[ Tree (Cell 1:1 1:9 (NodeHeader (HeaderColon "colon1" " "))) [] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0003.tct.html5 b/test/Golden/TCT/HeaderColon/0003.tct.html5 new file mode 100644 index 0000000..f81e0dc --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0003.tct.html5 @@ -0,0 +1,2 @@ + +colon1 : \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0003.tct.xml b/test/Golden/TCT/HeaderColon/0003.tct.xml new file mode 100644 index 0000000..6c077a6 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0003.tct.xml @@ -0,0 +1,2 @@ +Cell 1:1 1:9 (XmlElem colon1) + diff --git a/test/Golden/TCT/HeaderColon/0004.tct b/test/Golden/TCT/HeaderColon/0004.tct new file mode 100644 index 0000000..57370ef --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0004.tct @@ -0,0 +1,2 @@ +colon1: text0 +text1 diff --git a/test/Golden/TCT/HeaderColon/0004.tct.ast b/test/Golden/TCT/HeaderColon/0004.tct.ast new file mode 100644 index 0000000..94c262c --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0004.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 1:14 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + ] +, Tree (Cell 2:1 2:6 NodePara) + [ Tree (Cell 2:1 2:6 (NodeToken (TokenText "text1"))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0004.tct.html5 b/test/Golden/TCT/HeaderColon/0004.tct.html5 new file mode 100644 index 0000000..d7ff018 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0004.tct.html5 @@ -0,0 +1,3 @@ + +colon1: text0 +text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0004.tct.xml b/test/Golden/TCT/HeaderColon/0004.tct.xml new file mode 100644 index 0000000..92a4893 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0004.tct.xml @@ -0,0 +1,8 @@ +Cell 1:1 1:14 (XmlElem colon1) +| +`- Cell 1:9 1:14 (XmlText "text0") + +Cell 2:1 2:6 (XmlElem para) +| +`- Cell 2:1 2:6 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0005.tct b/test/Golden/TCT/HeaderColon/0005.tct new file mode 100644 index 0000000..4c90a18 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0005.tct @@ -0,0 +1,2 @@ +colon1: text0 + text1 diff --git a/test/Golden/TCT/HeaderColon/0005.tct.ast b/test/Golden/TCT/HeaderColon/0005.tct.ast new file mode 100644 index 0000000..116e7e7 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0005.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 2:7 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + , Tree (Cell 2:2 2:7 NodePara) + [ Tree (Cell 2:2 2:7 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0005.tct.html5 b/test/Golden/TCT/HeaderColon/0005.tct.html5 new file mode 100644 index 0000000..6794d60 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0005.tct.html5 @@ -0,0 +1,3 @@ + +colon1: text0 + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0005.tct.xml b/test/Golden/TCT/HeaderColon/0005.tct.xml new file mode 100644 index 0000000..aef12e3 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0005.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 2:7 (XmlElem colon1) +| ++- Cell 1:9 1:14 (XmlText "text0") +| +`- Cell 2:2 2:7 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0006.tct b/test/Golden/TCT/HeaderColon/0006.tct new file mode 100644 index 0000000..8dd4bc1 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0006.tct @@ -0,0 +1,2 @@ +colon1: text0 + text1 diff --git a/test/Golden/TCT/HeaderColon/0006.tct.ast b/test/Golden/TCT/HeaderColon/0006.tct.ast new file mode 100644 index 0000000..356e083 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0006.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 2:12 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + , Tree (Cell 2:7 2:12 NodePara) + [ Tree (Cell 2:7 2:12 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0006.tct.html5 b/test/Golden/TCT/HeaderColon/0006.tct.html5 new file mode 100644 index 0000000..b9d0037 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0006.tct.html5 @@ -0,0 +1,3 @@ + +colon1: text0 + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0006.tct.xml b/test/Golden/TCT/HeaderColon/0006.tct.xml new file mode 100644 index 0000000..838c160 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0006.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 2:12 (XmlElem colon1) +| ++- Cell 1:9 1:14 (XmlText "text0") +| +`- Cell 2:7 2:12 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0007.tct b/test/Golden/TCT/HeaderColon/0007.tct new file mode 100644 index 0000000..147a910 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0007.tct @@ -0,0 +1,2 @@ +colon1: text0 + text1 diff --git a/test/Golden/TCT/HeaderColon/0007.tct.ast b/test/Golden/TCT/HeaderColon/0007.tct.ast new file mode 100644 index 0000000..6fad764 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0007.tct.ast @@ -0,0 +1,6 @@ +[ Tree (Cell 1:1 2:13 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:8 2:13 NodePara) + [ Tree (Cell 1:8 2:13 (NodeToken (TokenText " text0\ntext1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0007.tct.html5 b/test/Golden/TCT/HeaderColon/0007.tct.html5 new file mode 100644 index 0000000..bba5b43 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0007.tct.html5 @@ -0,0 +1,3 @@ + +colon1: text0 + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0007.tct.xml b/test/Golden/TCT/HeaderColon/0007.tct.xml new file mode 100644 index 0000000..fcd1ba9 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0007.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 2:13 (XmlElem colon1) +| +`- Cell 1:8 2:13 (XmlText " text0\ntext1") + diff --git a/test/Golden/TCT/HeaderColon/0008.tct b/test/Golden/TCT/HeaderColon/0008.tct new file mode 100644 index 0000000..6587586 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0008.tct @@ -0,0 +1,2 @@ +colon1: text0 + text1 diff --git a/test/Golden/TCT/HeaderColon/0008.tct.ast b/test/Golden/TCT/HeaderColon/0008.tct.ast new file mode 100644 index 0000000..5b81ab5 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0008.tct.ast @@ -0,0 +1,6 @@ +[ Tree (Cell 1:1 2:14 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 2:14 NodePara) + [ Tree (Cell 1:9 2:14 (NodeToken (TokenText "text0\ntext1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0008.tct.html5 b/test/Golden/TCT/HeaderColon/0008.tct.html5 new file mode 100644 index 0000000..b5298c5 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0008.tct.html5 @@ -0,0 +1,3 @@ + +colon1: text0 + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0008.tct.xml b/test/Golden/TCT/HeaderColon/0008.tct.xml new file mode 100644 index 0000000..4e6e441 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0008.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 2:14 (XmlElem colon1) +| +`- Cell 1:9 2:14 (XmlText "text0\ntext1") + diff --git a/test/Golden/TCT/HeaderColon/0009.tct b/test/Golden/TCT/HeaderColon/0009.tct new file mode 100644 index 0000000..25a663c --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0009.tct @@ -0,0 +1,3 @@ +colon1: text0 + +text1 diff --git a/test/Golden/TCT/HeaderColon/0009.tct.ast b/test/Golden/TCT/HeaderColon/0009.tct.ast new file mode 100644 index 0000000..6472a5a --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0009.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 1:14 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + ] +, Tree (Cell 3:1 3:6 NodePara) + [ Tree (Cell 3:1 3:6 (NodeToken (TokenText "text1"))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0009.tct.html5 b/test/Golden/TCT/HeaderColon/0009.tct.html5 new file mode 100644 index 0000000..e98db71 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0009.tct.html5 @@ -0,0 +1,4 @@ + +colon1: text0 + +text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0009.tct.xml b/test/Golden/TCT/HeaderColon/0009.tct.xml new file mode 100644 index 0000000..b6520e0 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0009.tct.xml @@ -0,0 +1,8 @@ +Cell 1:1 1:14 (XmlElem colon1) +| +`- Cell 1:9 1:14 (XmlText "text0") + +Cell 3:1 3:6 (XmlElem para) +| +`- Cell 3:1 3:6 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0010.tct b/test/Golden/TCT/HeaderColon/0010.tct new file mode 100644 index 0000000..154bfe2 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0010.tct @@ -0,0 +1,3 @@ +colon1: text0 + + text1 diff --git a/test/Golden/TCT/HeaderColon/0010.tct.ast b/test/Golden/TCT/HeaderColon/0010.tct.ast new file mode 100644 index 0000000..a6a47e8 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0010.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 3:7 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + , Tree (Cell 3:2 3:7 NodePara) + [ Tree (Cell 3:2 3:7 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0010.tct.html5 b/test/Golden/TCT/HeaderColon/0010.tct.html5 new file mode 100644 index 0000000..89e6a68 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0010.tct.html5 @@ -0,0 +1,4 @@ + +colon1: text0 + + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0010.tct.xml b/test/Golden/TCT/HeaderColon/0010.tct.xml new file mode 100644 index 0000000..62a4ca3 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0010.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 3:7 (XmlElem colon1) +| ++- Cell 1:9 1:14 (XmlText "text0") +| +`- Cell 3:2 3:7 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0011.tct b/test/Golden/TCT/HeaderColon/0011.tct new file mode 100644 index 0000000..a5612de --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0011.tct @@ -0,0 +1,3 @@ +colon1: text0 + + text1 diff --git a/test/Golden/TCT/HeaderColon/0011.tct.ast b/test/Golden/TCT/HeaderColon/0011.tct.ast new file mode 100644 index 0000000..7b6d5ce --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0011.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 3:12 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + , Tree (Cell 3:7 3:12 NodePara) + [ Tree (Cell 3:7 3:12 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0011.tct.html5 b/test/Golden/TCT/HeaderColon/0011.tct.html5 new file mode 100644 index 0000000..c925518 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0011.tct.html5 @@ -0,0 +1,4 @@ + +colon1: text0 + + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0011.tct.xml b/test/Golden/TCT/HeaderColon/0011.tct.xml new file mode 100644 index 0000000..26512c0 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0011.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 3:12 (XmlElem colon1) +| ++- Cell 1:9 1:14 (XmlText "text0") +| +`- Cell 3:7 3:12 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0012.tct b/test/Golden/TCT/HeaderColon/0012.tct new file mode 100644 index 0000000..b83436a --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0012.tct @@ -0,0 +1,3 @@ +colon1: text0 + + text1 diff --git a/test/Golden/TCT/HeaderColon/0012.tct.ast b/test/Golden/TCT/HeaderColon/0012.tct.ast new file mode 100644 index 0000000..d14f2b6 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0012.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 3:13 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + , Tree (Cell 3:8 3:13 NodePara) + [ Tree (Cell 3:8 3:13 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0012.tct.html5 b/test/Golden/TCT/HeaderColon/0012.tct.html5 new file mode 100644 index 0000000..82e09da --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0012.tct.html5 @@ -0,0 +1,4 @@ + +colon1: text0 + + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0012.tct.xml b/test/Golden/TCT/HeaderColon/0012.tct.xml new file mode 100644 index 0000000..8ac02ff --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0012.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 3:13 (XmlElem colon1) +| ++- Cell 1:9 1:14 (XmlText "text0") +| +`- Cell 3:8 3:13 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0013.tct b/test/Golden/TCT/HeaderColon/0013.tct new file mode 100644 index 0000000..c4c3e88 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0013.tct @@ -0,0 +1,3 @@ +colon1: text0 + + text1 diff --git a/test/Golden/TCT/HeaderColon/0013.tct.ast b/test/Golden/TCT/HeaderColon/0013.tct.ast new file mode 100644 index 0000000..321c099 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0013.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 3:14 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text0"))) [] + ] + , Tree (Cell 3:9 3:14 NodePara) + [ Tree (Cell 3:9 3:14 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0013.tct.html5 b/test/Golden/TCT/HeaderColon/0013.tct.html5 new file mode 100644 index 0000000..82973b1 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0013.tct.html5 @@ -0,0 +1,4 @@ + +colon1: text0 + + text1 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0013.tct.xml b/test/Golden/TCT/HeaderColon/0013.tct.xml new file mode 100644 index 0000000..72ee646 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0013.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 3:14 (XmlElem colon1) +| ++- Cell 1:9 1:14 (XmlText "text0") +| +`- Cell 3:9 3:14 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderColon/0014.tct b/test/Golden/TCT/HeaderColon/0014.tct new file mode 100644 index 0000000..6395c12 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0014.tct @@ -0,0 +1,2 @@ +colon1: +colon2: diff --git a/test/Golden/TCT/HeaderColon/0014.tct.ast b/test/Golden/TCT/HeaderColon/0014.tct.ast new file mode 100644 index 0000000..18047e4 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0014.tct.ast @@ -0,0 +1,3 @@ +[ Tree (Cell 1:1 1:8 (NodeHeader (HeaderColon "colon1" ""))) [] +, Tree (Cell 2:1 2:8 (NodeHeader (HeaderColon "colon2" ""))) [] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0014.tct.html5 b/test/Golden/TCT/HeaderColon/0014.tct.html5 new file mode 100644 index 0000000..15def23 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0014.tct.html5 @@ -0,0 +1,3 @@ + +colon1: +colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0014.tct.xml b/test/Golden/TCT/HeaderColon/0014.tct.xml new file mode 100644 index 0000000..2076c5a --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0014.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 1:8 (XmlElem colon1) + +Cell 2:1 2:8 (XmlElem colon2) + diff --git a/test/Golden/TCT/HeaderColon/0015.tct b/test/Golden/TCT/HeaderColon/0015.tct new file mode 100644 index 0000000..e5365ea --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0015.tct @@ -0,0 +1,2 @@ +colon1: + colon2: diff --git a/test/Golden/TCT/HeaderColon/0015.tct.ast b/test/Golden/TCT/HeaderColon/0015.tct.ast new file mode 100644 index 0000000..2fee897 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0015.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 2:9 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 2:2 2:9 (NodeHeader (HeaderColon "colon2" ""))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0015.tct.html5 b/test/Golden/TCT/HeaderColon/0015.tct.html5 new file mode 100644 index 0000000..1821f0b --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0015.tct.html5 @@ -0,0 +1,3 @@ + +colon1: + colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0015.tct.xml b/test/Golden/TCT/HeaderColon/0015.tct.xml new file mode 100644 index 0000000..6e8ed24 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0015.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 2:9 (XmlElem colon1) +| +`- Cell 2:2 2:9 (XmlElem colon2) + diff --git a/test/Golden/TCT/HeaderColon/0016.tct b/test/Golden/TCT/HeaderColon/0016.tct new file mode 100644 index 0000000..fb00d9f --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0016.tct @@ -0,0 +1,2 @@ +colon1: + colon2: diff --git a/test/Golden/TCT/HeaderColon/0016.tct.ast b/test/Golden/TCT/HeaderColon/0016.tct.ast new file mode 100644 index 0000000..2112137 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0016.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 2:14 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 2:7 2:14 (NodeHeader (HeaderColon "colon2" ""))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0016.tct.html5 b/test/Golden/TCT/HeaderColon/0016.tct.html5 new file mode 100644 index 0000000..5880145 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0016.tct.html5 @@ -0,0 +1,3 @@ + +colon1: + colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0016.tct.xml b/test/Golden/TCT/HeaderColon/0016.tct.xml new file mode 100644 index 0000000..224da00 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0016.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 2:14 (XmlElem colon1) +| +`- Cell 2:7 2:14 (XmlElem colon2) + diff --git a/test/Golden/TCT/HeaderColon/0017.tct b/test/Golden/TCT/HeaderColon/0017.tct new file mode 100644 index 0000000..a87795e --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0017.tct @@ -0,0 +1,2 @@ +colon1: + colon2: diff --git a/test/Golden/TCT/HeaderColon/0017.tct.ast b/test/Golden/TCT/HeaderColon/0017.tct.ast new file mode 100644 index 0000000..a4ee69f --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0017.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 2:15 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 2:8 2:15 (NodeHeader (HeaderColon "colon2" ""))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0017.tct.html5 b/test/Golden/TCT/HeaderColon/0017.tct.html5 new file mode 100644 index 0000000..4aaa082 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0017.tct.html5 @@ -0,0 +1,3 @@ + +colon1: + colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0017.tct.xml b/test/Golden/TCT/HeaderColon/0017.tct.xml new file mode 100644 index 0000000..7e0946e --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0017.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 2:15 (XmlElem colon1) +| +`- Cell 2:8 2:15 (XmlElem colon2) + diff --git a/test/Golden/TCT/HeaderColon/0018.tct b/test/Golden/TCT/HeaderColon/0018.tct new file mode 100644 index 0000000..1307da8 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0018.tct @@ -0,0 +1,2 @@ +colon1: + colon2: diff --git a/test/Golden/TCT/HeaderColon/0018.tct.ast b/test/Golden/TCT/HeaderColon/0018.tct.ast new file mode 100644 index 0000000..c2923cd --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0018.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 2:16 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 2:9 2:16 (NodeHeader (HeaderColon "colon2" ""))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0018.tct.html5 b/test/Golden/TCT/HeaderColon/0018.tct.html5 new file mode 100644 index 0000000..0a04a8a --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0018.tct.html5 @@ -0,0 +1,3 @@ + +colon1: + colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0018.tct.xml b/test/Golden/TCT/HeaderColon/0018.tct.xml new file mode 100644 index 0000000..08a502d --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0018.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 2:16 (XmlElem colon1) +| +`- Cell 2:9 2:16 (XmlElem colon2) + diff --git a/test/Golden/TCT/HeaderColon/0019.tct b/test/Golden/TCT/HeaderColon/0019.tct new file mode 100644 index 0000000..3bb88b4 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0019.tct @@ -0,0 +1 @@ +colon1:colon2: diff --git a/test/Golden/TCT/HeaderColon/0019.tct.ast b/test/Golden/TCT/HeaderColon/0019.tct.ast new file mode 100644 index 0000000..ac4d12b --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0019.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 1:15 NodePara) + [ Tree (Cell 1:1 1:15 (NodeToken (TokenText "colon1:colon2:"))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0019.tct.html5 b/test/Golden/TCT/HeaderColon/0019.tct.html5 new file mode 100644 index 0000000..fe4f61b --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0019.tct.html5 @@ -0,0 +1,2 @@ + +colon1:colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0019.tct.xml b/test/Golden/TCT/HeaderColon/0019.tct.xml new file mode 100644 index 0000000..20f4e4c --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0019.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 1:15 (XmlElem para) +| +`- Cell 1:1 1:15 (XmlText "colon1:colon2:") + diff --git a/test/Golden/TCT/HeaderColon/0020.tct b/test/Golden/TCT/HeaderColon/0020.tct new file mode 100644 index 0000000..8ec483d --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0020.tct @@ -0,0 +1 @@ +colon1: colon2: diff --git a/test/Golden/TCT/HeaderColon/0020.tct.ast b/test/Golden/TCT/HeaderColon/0020.tct.ast new file mode 100644 index 0000000..e7d2445 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0020.tct.ast @@ -0,0 +1,4 @@ +[ Tree (Cell 1:1 1:16 (NodeHeader (HeaderColon "colon1" ""))) + [ Tree (Cell 1:9 1:16 (NodeHeader (HeaderColon "colon2" ""))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0020.tct.html5 b/test/Golden/TCT/HeaderColon/0020.tct.html5 new file mode 100644 index 0000000..2c10e2f --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0020.tct.html5 @@ -0,0 +1,2 @@ + +colon1: colon2: \ No newline at end of file diff --git a/test/Golden/TCT/HeaderColon/0020.tct.xml b/test/Golden/TCT/HeaderColon/0020.tct.xml new file mode 100644 index 0000000..83e7f01 --- /dev/null +++ b/test/Golden/TCT/HeaderColon/0020.tct.xml @@ -0,0 +1,4 @@ +Cell 1:1 1:16 (XmlElem colon1) +| +`- Cell 1:9 1:16 (XmlElem colon2) + diff --git a/test/Golden/TCT/HeaderGreat/0001.tct b/test/Golden/TCT/HeaderGreat/0001.tct new file mode 100644 index 0000000..79dbe2f --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0001.tct @@ -0,0 +1,2 @@ +> text1 +> text2 diff --git a/test/Golden/TCT/HeaderGreat/0001.tct.ast b/test/Golden/TCT/HeaderGreat/0001.tct.ast new file mode 100644 index 0000000..db22e58 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0001.tct.ast @@ -0,0 +1,6 @@ +[ Tree (Cell 1:1 2:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 2:8 NodePara) + [ Tree (Cell 1:3 2:8 (NodeToken (TokenText "text1\ntext2"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0001.tct.html5 b/test/Golden/TCT/HeaderGreat/0001.tct.html5 new file mode 100644 index 0000000..e1e14dd --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0001.tct.html5 @@ -0,0 +1,3 @@ + +> text1 +> text2 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0001.tct.xml b/test/Golden/TCT/HeaderGreat/0001.tct.xml new file mode 100644 index 0000000..5636880 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0001.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 2:8 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 2:8 (XmlText "text1\ntext2") + diff --git a/test/Golden/TCT/HeaderGreat/0002.tct b/test/Golden/TCT/HeaderGreat/0002.tct new file mode 100644 index 0000000..2e42fc5 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0002.tct @@ -0,0 +1,3 @@ +> text1 +> text2 +> text3 diff --git a/test/Golden/TCT/HeaderGreat/0002.tct.ast b/test/Golden/TCT/HeaderGreat/0002.tct.ast new file mode 100644 index 0000000..2670e1f --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0002.tct.ast @@ -0,0 +1,6 @@ +[ Tree (Cell 1:1 3:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 3:8 NodePara) + [ Tree (Cell 1:3 3:8 (NodeToken (TokenText "text1\ntext2\ntext3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0002.tct.html5 b/test/Golden/TCT/HeaderGreat/0002.tct.html5 new file mode 100644 index 0000000..9a700f7 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0002.tct.html5 @@ -0,0 +1,4 @@ + +> text1 +> text2 +> text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0002.tct.xml b/test/Golden/TCT/HeaderGreat/0002.tct.xml new file mode 100644 index 0000000..865b3f8 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0002.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 3:8 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 3:8 (XmlText "text1\ntext2\ntext3") + diff --git a/test/Golden/TCT/HeaderGreat/0003.tct b/test/Golden/TCT/HeaderGreat/0003.tct new file mode 100644 index 0000000..2aa3b5d --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0003.tct @@ -0,0 +1,3 @@ +>> text1 +>> text2 +>> text3 diff --git a/test/Golden/TCT/HeaderGreat/0003.tct.ast b/test/Golden/TCT/HeaderGreat/0003.tct.ast new file mode 100644 index 0000000..bb6e970 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0003.tct.ast @@ -0,0 +1,8 @@ +[ Tree (Cell 1:1 3:9 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:2 3:9 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:4 3:9 NodePara) + [ Tree (Cell 1:4 3:9 (NodeToken (TokenText "text1\ntext2\ntext3"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0003.tct.html5 b/test/Golden/TCT/HeaderGreat/0003.tct.html5 new file mode 100644 index 0000000..db87e01 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0003.tct.html5 @@ -0,0 +1,4 @@ + +>> text1 +>> text2 +>> text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0003.tct.xml b/test/Golden/TCT/HeaderGreat/0003.tct.xml new file mode 100644 index 0000000..b2eeae7 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0003.tct.xml @@ -0,0 +1,10 @@ +Cell 1:1 3:9 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:2 3:9 (XmlElem artwork) + | + +- Cell 1:2 1:2 (XmlAttr type "quote") + | + `- Cell 1:4 3:9 (XmlText "text1\ntext2\ntext3") + diff --git a/test/Golden/TCT/HeaderGreat/0004.tct b/test/Golden/TCT/HeaderGreat/0004.tct new file mode 100644 index 0000000..808ce57 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0004.tct @@ -0,0 +1,3 @@ +> > text1 +> > text2 +> > text3 diff --git a/test/Golden/TCT/HeaderGreat/0004.tct.ast b/test/Golden/TCT/HeaderGreat/0004.tct.ast new file mode 100644 index 0000000..3b4a88d --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0004.tct.ast @@ -0,0 +1,8 @@ +[ Tree (Cell 1:1 3:10 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 3:10 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:5 3:10 NodePara) + [ Tree (Cell 1:5 3:10 (NodeToken (TokenText "text1\ntext2\ntext3"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0004.tct.html5 b/test/Golden/TCT/HeaderGreat/0004.tct.html5 new file mode 100644 index 0000000..f29e4f1 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0004.tct.html5 @@ -0,0 +1,4 @@ + +> > text1 +> > text2 +> > text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0004.tct.xml b/test/Golden/TCT/HeaderGreat/0004.tct.xml new file mode 100644 index 0000000..7b24dc7 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0004.tct.xml @@ -0,0 +1,10 @@ +Cell 1:1 3:10 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 3:10 (XmlElem artwork) + | + +- Cell 1:3 1:3 (XmlAttr type "quote") + | + `- Cell 1:5 3:10 (XmlText "text1\ntext2\ntext3") + diff --git a/test/Golden/TCT/HeaderGreat/0005.tct b/test/Golden/TCT/HeaderGreat/0005.tct new file mode 100644 index 0000000..4e00c2a --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0005.tct @@ -0,0 +1,3 @@ +> > > text1 +> > > text2 +> > > text3 diff --git a/test/Golden/TCT/HeaderGreat/0005.tct.ast b/test/Golden/TCT/HeaderGreat/0005.tct.ast new file mode 100644 index 0000000..a966a20 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0005.tct.ast @@ -0,0 +1,10 @@ +[ Tree (Cell 1:1 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:5 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:7 3:12 NodePara) + [ Tree (Cell 1:7 3:12 (NodeToken (TokenText "text1\ntext2\ntext3"))) [] + ] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0005.tct.html5 b/test/Golden/TCT/HeaderGreat/0005.tct.html5 new file mode 100644 index 0000000..1a28f7e --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0005.tct.html5 @@ -0,0 +1,4 @@ + +> > > text1 +> > > text2 +> > > text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0005.tct.xml b/test/Golden/TCT/HeaderGreat/0005.tct.xml new file mode 100644 index 0000000..6cd1cad --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0005.tct.xml @@ -0,0 +1,14 @@ +Cell 1:1 3:12 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 3:12 (XmlElem artwork) + | + +- Cell 1:3 1:3 (XmlAttr type "quote") + | + `- Cell 1:5 3:12 (XmlElem artwork) + | + +- Cell 1:5 1:5 (XmlAttr type "quote") + | + `- Cell 1:7 3:12 (XmlText "text1\ntext2\ntext3") + diff --git a/test/Golden/TCT/HeaderGreat/0006.tct b/test/Golden/TCT/HeaderGreat/0006.tct new file mode 100644 index 0000000..bd96c41 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0006.tct @@ -0,0 +1,3 @@ +> text1 +> > text2 +> > > text3 diff --git a/test/Golden/TCT/HeaderGreat/0006.tct.ast b/test/Golden/TCT/HeaderGreat/0006.tct.ast new file mode 100644 index 0000000..aa34b4b --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0006.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 3:12 NodePara) + [ Tree (Cell 1:3 1:8 (NodeToken (TokenText "text1"))) [] + , Tree (Cell 2:3 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 2:5 3:12 NodePara) + [ Tree (Cell 2:5 2:10 (NodeToken (TokenText "text2"))) [] + , Tree (Cell 3:5 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 3:7 3:12 NodePara) + [ Tree (Cell 3:7 3:12 (NodeToken (TokenText "text3"))) [] + ] + ] + ] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0006.tct.html5 b/test/Golden/TCT/HeaderGreat/0006.tct.html5 new file mode 100644 index 0000000..22ef6ec --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0006.tct.html5 @@ -0,0 +1,4 @@ + +> text1 +> > text2 +> > > text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0006.tct.xml b/test/Golden/TCT/HeaderGreat/0006.tct.xml new file mode 100644 index 0000000..b00dc52 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0006.tct.xml @@ -0,0 +1,18 @@ +Cell 1:1 3:12 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| ++- Cell 1:3 1:8 (XmlText "text1") +| +`- Cell 2:3 3:12 (XmlElem artwork) + | + +- Cell 2:3 2:3 (XmlAttr type "quote") + | + +- Cell 2:5 2:10 (XmlText "text2") + | + `- Cell 3:5 3:12 (XmlElem artwork) + | + +- Cell 3:5 3:5 (XmlAttr type "quote") + | + `- Cell 3:7 3:12 (XmlText "text3") + diff --git a/test/Golden/TCT/HeaderGreat/0007.tct b/test/Golden/TCT/HeaderGreat/0007.tct new file mode 100644 index 0000000..aa717fc --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0007.tct @@ -0,0 +1,3 @@ +> > > text1 +> > text2 +> text3 diff --git a/test/Golden/TCT/HeaderGreat/0007.tct.ast b/test/Golden/TCT/HeaderGreat/0007.tct.ast new file mode 100644 index 0000000..b397a9e --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0007.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 2:10 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:5 1:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:7 1:12 NodePara) + [ Tree (Cell 1:7 1:12 (NodeToken (TokenText "text1"))) [] + ] + ] + , Tree (Cell 2:5 2:10 NodePara) + [ Tree (Cell 2:5 2:10 (NodeToken (TokenText "text2"))) [] + ] + ] + , Tree (Cell 3:3 3:8 NodePara) + [ Tree (Cell 3:3 3:8 (NodeToken (TokenText "text3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0007.tct.html5 b/test/Golden/TCT/HeaderGreat/0007.tct.html5 new file mode 100644 index 0000000..10a75cf --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0007.tct.html5 @@ -0,0 +1,4 @@ + +> > > text1 +> > text2 +> text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0007.tct.xml b/test/Golden/TCT/HeaderGreat/0007.tct.xml new file mode 100644 index 0000000..d39e8b9 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0007.tct.xml @@ -0,0 +1,18 @@ +Cell 1:1 3:8 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| ++- Cell 1:3 2:10 (XmlElem artwork) +| | +| +- Cell 1:3 1:3 (XmlAttr type "quote") +| | +| +- Cell 1:5 1:12 (XmlElem artwork) +| | | +| | +- Cell 1:5 1:5 (XmlAttr type "quote") +| | | +| | `- Cell 1:7 1:12 (XmlText "text1") +| | +| `- Cell 2:5 2:10 (XmlText "text2") +| +`- Cell 3:3 3:8 (XmlText "text3") + diff --git a/test/Golden/TCT/HeaderGreat/0008.tct b/test/Golden/TCT/HeaderGreat/0008.tct new file mode 100644 index 0000000..09f2fc6 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0008.tct @@ -0,0 +1,3 @@ +> > text1 +> > > text2 +> > text3 diff --git a/test/Golden/TCT/HeaderGreat/0008.tct.ast b/test/Golden/TCT/HeaderGreat/0008.tct.ast new file mode 100644 index 0000000..9c23b0c --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0008.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 3:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:7 1:12 NodePara) + [ Tree (Cell 1:7 1:12 (NodeToken (TokenText "text1"))) [] + ] + , Tree (Cell 2:5 2:12 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 2:7 2:12 NodePara) + [ Tree (Cell 2:7 2:12 (NodeToken (TokenText "text2"))) [] + ] + ] + , Tree (Cell 3:7 3:12 NodePara) + [ Tree (Cell 3:7 3:12 (NodeToken (TokenText "text3"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0008.tct.html5 b/test/Golden/TCT/HeaderGreat/0008.tct.html5 new file mode 100644 index 0000000..1f6dc58 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0008.tct.html5 @@ -0,0 +1,4 @@ + +> > text1 +> > > text2 +> > text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0008.tct.xml b/test/Golden/TCT/HeaderGreat/0008.tct.xml new file mode 100644 index 0000000..5e5b6ff --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0008.tct.xml @@ -0,0 +1,18 @@ +Cell 1:1 3:12 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 3:12 (XmlElem artwork) + | + +- Cell 1:3 1:3 (XmlAttr type "quote") + | + +- Cell 1:7 1:12 (XmlText "text1") + | + +- Cell 2:5 2:12 (XmlElem artwork) + | | + | +- Cell 2:5 2:5 (XmlAttr type "quote") + | | + | `- Cell 2:7 2:12 (XmlText "text2") + | + `- Cell 3:7 3:12 (XmlText "text3") + diff --git a/test/Golden/TCT/HeaderGreat/0009.tct b/test/Golden/TCT/HeaderGreat/0009.tct new file mode 100644 index 0000000..4f4ccd5 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0009.tct @@ -0,0 +1,4 @@ +> text1 + +> text2 +> text3 diff --git a/test/Golden/TCT/HeaderGreat/0009.tct.ast b/test/Golden/TCT/HeaderGreat/0009.tct.ast new file mode 100644 index 0000000..ece8482 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0009.tct.ast @@ -0,0 +1,11 @@ +[ Tree (Cell 1:1 1:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 1:8 NodePara) + [ Tree (Cell 1:3 1:8 (NodeToken (TokenText "text1"))) [] + ] + ] +, Tree (Cell 3:1 4:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 3:3 4:8 NodePara) + [ Tree (Cell 3:3 4:8 (NodeToken (TokenText "text2\ntext3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0009.tct.html5 b/test/Golden/TCT/HeaderGreat/0009.tct.html5 new file mode 100644 index 0000000..2659c95 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0009.tct.html5 @@ -0,0 +1,5 @@ + +> text1 + +> text2 +> text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0009.tct.xml b/test/Golden/TCT/HeaderGreat/0009.tct.xml new file mode 100644 index 0000000..76b8595 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0009.tct.xml @@ -0,0 +1,12 @@ +Cell 1:1 1:8 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 1:8 (XmlText "text1") + +Cell 3:1 4:8 (XmlElem artwork) +| ++- Cell 3:1 3:1 (XmlAttr type "quote") +| +`- Cell 3:3 4:8 (XmlText "text2\ntext3") + diff --git a/test/Golden/TCT/HeaderGreat/0010.tct b/test/Golden/TCT/HeaderGreat/0010.tct new file mode 100644 index 0000000..75ce2ea --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0010.tct @@ -0,0 +1,4 @@ +> text1 +> text2 + +> text3 diff --git a/test/Golden/TCT/HeaderGreat/0010.tct.ast b/test/Golden/TCT/HeaderGreat/0010.tct.ast new file mode 100644 index 0000000..58c4d8a --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0010.tct.ast @@ -0,0 +1,11 @@ +[ Tree (Cell 1:1 2:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 2:8 NodePara) + [ Tree (Cell 1:3 2:8 (NodeToken (TokenText "text1\ntext2"))) [] + ] + ] +, Tree (Cell 4:1 4:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 4:3 4:8 NodePara) + [ Tree (Cell 4:3 4:8 (NodeToken (TokenText "text3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0010.tct.html5 b/test/Golden/TCT/HeaderGreat/0010.tct.html5 new file mode 100644 index 0000000..f5f0ba2 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0010.tct.html5 @@ -0,0 +1,5 @@ + +> text1 +> text2 + +> text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0010.tct.xml b/test/Golden/TCT/HeaderGreat/0010.tct.xml new file mode 100644 index 0000000..9745d96 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0010.tct.xml @@ -0,0 +1,12 @@ +Cell 1:1 2:8 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 2:8 (XmlText "text1\ntext2") + +Cell 4:1 4:8 (XmlElem artwork) +| ++- Cell 4:1 4:1 (XmlAttr type "quote") +| +`- Cell 4:3 4:8 (XmlText "text3") + diff --git a/test/Golden/TCT/HeaderGreat/0011.tct b/test/Golden/TCT/HeaderGreat/0011.tct new file mode 100644 index 0000000..9cbd55f --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0011.tct @@ -0,0 +1,3 @@ +> text1 +text2 +> text3 diff --git a/test/Golden/TCT/HeaderGreat/0011.tct.ast b/test/Golden/TCT/HeaderGreat/0011.tct.ast new file mode 100644 index 0000000..6dad53a --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0011.tct.ast @@ -0,0 +1,14 @@ +[ Tree (Cell 1:1 1:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 1:3 1:8 NodePara) + [ Tree (Cell 1:3 1:8 (NodeToken (TokenText "text1"))) [] + ] + ] +, Tree (Cell 2:1 3:8 NodePara) + [ Tree (Cell 2:1 2:6 (NodeToken (TokenText "text2"))) [] + , Tree (Cell 3:1 3:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 3:3 3:8 NodePara) + [ Tree (Cell 3:3 3:8 (NodeToken (TokenText "text3"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0011.tct.html5 b/test/Golden/TCT/HeaderGreat/0011.tct.html5 new file mode 100644 index 0000000..56a4390 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0011.tct.html5 @@ -0,0 +1,4 @@ + +> text1 +text2 +> text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0011.tct.xml b/test/Golden/TCT/HeaderGreat/0011.tct.xml new file mode 100644 index 0000000..f288718 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0011.tct.xml @@ -0,0 +1,16 @@ +Cell 1:1 1:8 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "quote") +| +`- Cell 1:3 1:8 (XmlText "text1") + +Cell 2:1 3:8 (XmlElem para) +| ++- Cell 2:1 2:6 (XmlText "text2") +| +`- Cell 3:1 3:8 (XmlElem artwork) + | + +- Cell 3:1 3:1 (XmlAttr type "quote") + | + `- Cell 3:3 3:8 (XmlText "text3") + diff --git a/test/Golden/TCT/HeaderGreat/0012.tct b/test/Golden/TCT/HeaderGreat/0012.tct new file mode 100644 index 0000000..ec1c7e1 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0012.tct @@ -0,0 +1,3 @@ +text1 +> text2 +text3 diff --git a/test/Golden/TCT/HeaderGreat/0012.tct.ast b/test/Golden/TCT/HeaderGreat/0012.tct.ast new file mode 100644 index 0000000..4eb6a3e --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0012.tct.ast @@ -0,0 +1,10 @@ +[ Tree (Cell 1:1 3:6 NodePara) + [ Tree (Cell 1:1 1:6 (NodeToken (TokenText "text1"))) [] + , Tree (Cell 2:1 2:8 (NodeHeader (HeaderGreat "" ""))) + [ Tree (Cell 2:3 2:8 NodePara) + [ Tree (Cell 2:3 2:8 (NodeToken (TokenText "text2"))) [] + ] + ] + , Tree (Cell 3:1 3:6 (NodeToken (TokenText "text3"))) [] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0012.tct.html5 b/test/Golden/TCT/HeaderGreat/0012.tct.html5 new file mode 100644 index 0000000..bbb59e7 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0012.tct.html5 @@ -0,0 +1,4 @@ + +text1 +> text2 +text3 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0012.tct.xml b/test/Golden/TCT/HeaderGreat/0012.tct.xml new file mode 100644 index 0000000..28a4f83 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0012.tct.xml @@ -0,0 +1,12 @@ +Cell 1:1 3:6 (XmlElem para) +| ++- Cell 1:1 1:6 (XmlText "text1") +| ++- Cell 2:1 2:8 (XmlElem artwork) +| | +| +- Cell 2:1 2:1 (XmlAttr type "quote") +| | +| `- Cell 2:3 2:8 (XmlText "text2") +| +`- Cell 3:1 3:6 (XmlText "text3") + diff --git a/test/Golden/TCT/HeaderGreat/0013.tct b/test/Golden/TCT/HeaderGreat/0013.tct new file mode 100644 index 0000000..6be61e3 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0013.tct @@ -0,0 +1,2 @@ +great1> text1 +great1> text2 diff --git a/test/Golden/TCT/HeaderGreat/0013.tct.ast b/test/Golden/TCT/HeaderGreat/0013.tct.ast new file mode 100644 index 0000000..24f69be --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0013.tct.ast @@ -0,0 +1,6 @@ +[ Tree (Cell 1:1 2:14 (NodeHeader (HeaderGreat "great1" ""))) + [ Tree (Cell 1:9 2:14 NodePara) + [ Tree (Cell 1:9 2:14 (NodeToken (TokenText "text1\ntext2"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0013.tct.html5 b/test/Golden/TCT/HeaderGreat/0013.tct.html5 new file mode 100644 index 0000000..e81eda7 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0013.tct.html5 @@ -0,0 +1,3 @@ + +great1> text1 +great1> text2 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0013.tct.xml b/test/Golden/TCT/HeaderGreat/0013.tct.xml new file mode 100644 index 0000000..cc0351e --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0013.tct.xml @@ -0,0 +1,6 @@ +Cell 1:1 2:14 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "great1") +| +`- Cell 1:9 2:14 (XmlText "text1\ntext2") + diff --git a/test/Golden/TCT/HeaderGreat/0014.tct b/test/Golden/TCT/HeaderGreat/0014.tct new file mode 100644 index 0000000..76f4cae --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0014.tct @@ -0,0 +1,2 @@ +great1> text1 +great2> text2 diff --git a/test/Golden/TCT/HeaderGreat/0014.tct.ast b/test/Golden/TCT/HeaderGreat/0014.tct.ast new file mode 100644 index 0000000..14c21b9 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0014.tct.ast @@ -0,0 +1,11 @@ +[ Tree (Cell 1:1 1:14 (NodeHeader (HeaderGreat "great1" ""))) + [ Tree (Cell 1:9 1:14 NodePara) + [ Tree (Cell 1:9 1:14 (NodeToken (TokenText "text1"))) [] + ] + ] +, Tree (Cell 2:1 2:14 (NodeHeader (HeaderGreat "great2" ""))) + [ Tree (Cell 2:9 2:14 NodePara) + [ Tree (Cell 2:9 2:14 (NodeToken (TokenText "text2"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0014.tct.html5 b/test/Golden/TCT/HeaderGreat/0014.tct.html5 new file mode 100644 index 0000000..bb56014 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0014.tct.html5 @@ -0,0 +1,3 @@ + +great1> text1 +great2> text2 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0014.tct.xml b/test/Golden/TCT/HeaderGreat/0014.tct.xml new file mode 100644 index 0000000..95f13f6 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0014.tct.xml @@ -0,0 +1,12 @@ +Cell 1:1 1:14 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "great1") +| +`- Cell 1:9 1:14 (XmlText "text1") + +Cell 2:1 2:14 (XmlElem artwork) +| ++- Cell 2:1 2:1 (XmlAttr type "great2") +| +`- Cell 2:9 2:14 (XmlText "text2") + diff --git a/test/Golden/TCT/HeaderGreat/0015.tct b/test/Golden/TCT/HeaderGreat/0015.tct new file mode 100644 index 0000000..30ea500 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0015.tct @@ -0,0 +1,2 @@ +great1> great2> text1 +great2> great1> text2 diff --git a/test/Golden/TCT/HeaderGreat/0015.tct.ast b/test/Golden/TCT/HeaderGreat/0015.tct.ast new file mode 100644 index 0000000..13956d4 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0015.tct.ast @@ -0,0 +1,15 @@ +[ Tree (Cell 1:1 1:22 (NodeHeader (HeaderGreat "great1" ""))) + [ Tree (Cell 1:9 1:22 (NodeHeader (HeaderGreat "great2" ""))) + [ Tree (Cell 1:17 1:22 NodePara) + [ Tree (Cell 1:17 1:22 (NodeToken (TokenText "text1"))) [] + ] + ] + ] +, Tree (Cell 2:1 2:22 (NodeHeader (HeaderGreat "great2" ""))) + [ Tree (Cell 2:9 2:22 (NodeHeader (HeaderGreat "great1" ""))) + [ Tree (Cell 2:17 2:22 NodePara) + [ Tree (Cell 2:17 2:22 (NodeToken (TokenText "text2"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0015.tct.html5 b/test/Golden/TCT/HeaderGreat/0015.tct.html5 new file mode 100644 index 0000000..a9b4951 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0015.tct.html5 @@ -0,0 +1,3 @@ + +great1> great2> text1 +great2> great1> text2 \ No newline at end of file diff --git a/test/Golden/TCT/HeaderGreat/0015.tct.xml b/test/Golden/TCT/HeaderGreat/0015.tct.xml new file mode 100644 index 0000000..8f80c11 --- /dev/null +++ b/test/Golden/TCT/HeaderGreat/0015.tct.xml @@ -0,0 +1,20 @@ +Cell 1:1 1:22 (XmlElem artwork) +| ++- Cell 1:1 1:1 (XmlAttr type "great1") +| +`- Cell 1:9 1:22 (XmlElem artwork) + | + +- Cell 1:9 1:9 (XmlAttr type "great2") + | + `- Cell 1:17 1:22 (XmlText "text1") + +Cell 2:1 2:22 (XmlElem artwork) +| ++- Cell 2:1 2:1 (XmlAttr type "great2") +| +`- Cell 2:9 2:22 (XmlElem artwork) + | + +- Cell 2:9 2:9 (XmlAttr type "great1") + | + `- Cell 2:17 2:22 (XmlText "text2") + diff --git a/test/Golden/TCT/HeaderSection/0000.tct b/test/Golden/TCT/HeaderSection/0000.tct new file mode 100644 index 0000000..d28086c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0000.tct @@ -0,0 +1,3 @@ +# sec1 +# sec2 +# sec3 diff --git a/test/Golden/TCT/HeaderSection/0000.tct.ast b/test/Golden/TCT/HeaderSection/0000.tct.ast new file mode 100644 index 0000000..ae6ba35 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0000.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 1:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + ] +, Tree (Cell 2:1 2:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:3 2:7 NodePara) + [ Tree (Cell 2:3 2:7 (NodeToken (TokenText "sec2"))) [] + ] + ] +, Tree (Cell 3:1 3:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:3 3:7 NodePara) + [ Tree (Cell 3:3 3:7 (NodeToken (TokenText "sec3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0000.tct.html5 b/test/Golden/TCT/HeaderSection/0000.tct.html5 new file mode 100644 index 0000000..7eac44c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0000.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

+
#

sec2

+
#

sec3

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0000.tct.xml b/test/Golden/TCT/HeaderSection/0000.tct.xml new file mode 100644 index 0000000..605952c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0000.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 2:7 (XmlElem section) +| +`- Cell 2:3 2:7 (XmlAttr id "sec2") + +Cell 3:1 3:7 (XmlElem section) +| +`- Cell 3:3 3:7 (XmlAttr id "sec3") + diff --git a/test/Golden/TCT/HeaderSection/0001.tct b/test/Golden/TCT/HeaderSection/0001.tct new file mode 100644 index 0000000..5c77934 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0001.tct @@ -0,0 +1,3 @@ +# sec1 +## sec2 +## sec3 diff --git a/test/Golden/TCT/HeaderSection/0001.tct.ast b/test/Golden/TCT/HeaderSection/0001.tct.ast new file mode 100644 index 0000000..5703606 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0001.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:8 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:1 2:8 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 2:4 2:8 NodePara) + [ Tree (Cell 2:4 2:8 (NodeToken (TokenText "sec2"))) [] + ] + ] + , Tree (Cell 3:1 3:8 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 3:4 3:8 NodePara) + [ Tree (Cell 3:4 3:8 (NodeToken (TokenText "sec3"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0001.tct.html5 b/test/Golden/TCT/HeaderSection/0001.tct.html5 new file mode 100644 index 0000000..127660d --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0001.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

 +
##

sec2

+
##

sec3

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0001.tct.xml b/test/Golden/TCT/HeaderSection/0001.tct.xml new file mode 100644 index 0000000..83b5c2a --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0001.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 2:8 (XmlElem section) +| +`- Cell 2:4 2:8 (XmlAttr id "sec2") + +Cell 3:1 3:8 (XmlElem section) +| +`- Cell 3:4 3:8 (XmlAttr id "sec3") + diff --git a/test/Golden/TCT/HeaderSection/0002.tct b/test/Golden/TCT/HeaderSection/0002.tct new file mode 100644 index 0000000..6a29146 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0002.tct @@ -0,0 +1,3 @@ +# sec1 + # sec11 + # sec12 diff --git a/test/Golden/TCT/HeaderSection/0002.tct.ast b/test/Golden/TCT/HeaderSection/0002.tct.ast new file mode 100644 index 0000000..a146085 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0002.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:9 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:2 2:9 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:4 2:9 NodePara) + [ Tree (Cell 2:4 2:9 (NodeToken (TokenText "sec11"))) [] + ] + ] + , Tree (Cell 3:2 3:9 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:4 3:9 NodePara) + [ Tree (Cell 3:4 3:9 (NodeToken (TokenText "sec12"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0002.tct.html5 b/test/Golden/TCT/HeaderSection/0002.tct.html5 new file mode 100644 index 0000000..578a478 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0002.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

 +
#

sec11

+
#

sec12

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0002.tct.xml b/test/Golden/TCT/HeaderSection/0002.tct.xml new file mode 100644 index 0000000..83e4cfc --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0002.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| ++- Cell 1:3 1:7 (XmlElem title) +| | +| `- Cell 1:3 1:7 (XmlText "sec1") +| ++- Cell 2:4 2:9 (XmlElem title) +| | +| `- Cell 2:4 2:9 (XmlText "sec11") +| +`- Cell 3:4 3:9 (XmlElem title) + | + `- Cell 3:4 3:9 (XmlText "sec12") + diff --git a/test/Golden/TCT/HeaderSection/0003.tct b/test/Golden/TCT/HeaderSection/0003.tct new file mode 100644 index 0000000..046e672 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0003.tct @@ -0,0 +1,3 @@ +# sec1 + # sec11 + # sec12 diff --git a/test/Golden/TCT/HeaderSection/0003.tct.ast b/test/Golden/TCT/HeaderSection/0003.tct.ast new file mode 100644 index 0000000..03466a7 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0003.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:10 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:3 2:10 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:5 2:10 NodePara) + [ Tree (Cell 2:5 2:10 (NodeToken (TokenText "sec11"))) [] + ] + ] + , Tree (Cell 3:3 3:10 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:5 3:10 NodePara) + [ Tree (Cell 3:5 3:10 (NodeToken (TokenText "sec12"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0003.tct.html5 b/test/Golden/TCT/HeaderSection/0003.tct.html5 new file mode 100644 index 0000000..cc64ee2 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0003.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

 +
#

sec11

+
#

sec12

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0003.tct.xml b/test/Golden/TCT/HeaderSection/0003.tct.xml new file mode 100644 index 0000000..a077f91 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0003.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| ++- Cell 1:3 1:7 (XmlElem title) +| | +| `- Cell 1:3 1:7 (XmlText "sec1") +| ++- Cell 2:5 2:10 (XmlElem title) +| | +| `- Cell 2:5 2:10 (XmlText "sec11") +| +`- Cell 3:5 3:10 (XmlElem title) + | + `- Cell 3:5 3:10 (XmlText "sec12") + diff --git a/test/Golden/TCT/HeaderSection/0004.tct b/test/Golden/TCT/HeaderSection/0004.tct new file mode 100644 index 0000000..3fbe8ae --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0004.tct @@ -0,0 +1,3 @@ +# sec1 + # sub11 + # sub12 diff --git a/test/Golden/TCT/HeaderSection/0004.tct.ast b/test/Golden/TCT/HeaderSection/0004.tct.ast new file mode 100644 index 0000000..059af95 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0004.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:11 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:4 2:11 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:6 2:11 NodePara) + [ Tree (Cell 2:6 2:11 (NodeToken (TokenText "sub11"))) [] + ] + ] + , Tree (Cell 3:4 3:11 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:6 3:11 NodePara) + [ Tree (Cell 3:6 3:11 (NodeToken (TokenText "sub12"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0004.tct.html5 b/test/Golden/TCT/HeaderSection/0004.tct.html5 new file mode 100644 index 0000000..f3978aa --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0004.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

 +
#

sub11

+
#

sub12

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0004.tct.xml b/test/Golden/TCT/HeaderSection/0004.tct.xml new file mode 100644 index 0000000..cf11177 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0004.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| ++- Cell 1:3 1:7 (XmlElem title) +| | +| `- Cell 1:3 1:7 (XmlText "sec1") +| ++- Cell 2:6 2:11 (XmlElem title) +| | +| `- Cell 2:6 2:11 (XmlText "sub11") +| +`- Cell 3:6 3:11 (XmlElem title) + | + `- Cell 3:6 3:11 (XmlText "sub12") + diff --git a/test/Golden/TCT/HeaderSection/0005.tct b/test/Golden/TCT/HeaderSection/0005.tct new file mode 100644 index 0000000..e32971e --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0005.tct @@ -0,0 +1,3 @@ +## sec1 + # sub11 + # sub12 diff --git a/test/Golden/TCT/HeaderSection/0005.tct.ast b/test/Golden/TCT/HeaderSection/0005.tct.ast new file mode 100644 index 0000000..56de2d8 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0005.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:10 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 1:4 1:8 NodePara) + [ Tree (Cell 1:4 1:8 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:3 2:10 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:5 2:10 NodePara) + [ Tree (Cell 2:5 2:10 (NodeToken (TokenText "sub11"))) [] + ] + ] + , Tree (Cell 3:3 3:10 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:5 3:10 NodePara) + [ Tree (Cell 3:5 3:10 (NodeToken (TokenText "sub12"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0005.tct.html5 b/test/Golden/TCT/HeaderSection/0005.tct.html5 new file mode 100644 index 0000000..f335800 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0005.tct.html5 @@ -0,0 +1,4 @@ + + sec1
##

sec1

 +
#

sub11

+
#

sub12

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0005.tct.xml b/test/Golden/TCT/HeaderSection/0005.tct.xml new file mode 100644 index 0000000..bc4e97e --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0005.tct.xml @@ -0,0 +1,14 @@ +Cell 1:4 1:8 (XmlElem about) +| ++- Cell 1:4 1:8 (XmlElem title) +| | +| `- Cell 1:4 1:8 (XmlText "sec1") +| ++- Cell 2:5 2:10 (XmlElem title) +| | +| `- Cell 2:5 2:10 (XmlText "sub11") +| +`- Cell 3:5 3:10 (XmlElem title) + | + `- Cell 3:5 3:10 (XmlText "sub12") + diff --git a/test/Golden/TCT/HeaderSection/0006.tct b/test/Golden/TCT/HeaderSection/0006.tct new file mode 100644 index 0000000..b0eb163 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0006.tct @@ -0,0 +1,3 @@ +# sec1 + ## sub11 + ## sub12 diff --git a/test/Golden/TCT/HeaderSection/0006.tct.ast b/test/Golden/TCT/HeaderSection/0006.tct.ast new file mode 100644 index 0000000..976e048 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0006.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 3:11 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:3 2:11 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 2:6 2:11 NodePara) + [ Tree (Cell 2:6 2:11 (NodeToken (TokenText "sub11"))) [] + ] + ] + , Tree (Cell 3:3 3:11 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 3:6 3:11 NodePara) + [ Tree (Cell 3:6 3:11 (NodeToken (TokenText "sub12"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0006.tct.html5 b/test/Golden/TCT/HeaderSection/0006.tct.html5 new file mode 100644 index 0000000..d024940 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0006.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

 +
##

sub11

+
##

sub12

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0006.tct.xml b/test/Golden/TCT/HeaderSection/0006.tct.xml new file mode 100644 index 0000000..d3f84c0 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0006.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:3 2:11 (XmlElem section) +| +`- Cell 2:6 2:11 (XmlAttr id "sub11") + +Cell 3:3 3:11 (XmlElem section) +| +`- Cell 3:6 3:11 (XmlAttr id "sub12") + diff --git a/test/Golden/TCT/HeaderSection/0007.tct b/test/Golden/TCT/HeaderSection/0007.tct new file mode 100644 index 0000000..30e3aaf --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0007.tct @@ -0,0 +1,3 @@ +## sec11 +# sec2 +# sec3 diff --git a/test/Golden/TCT/HeaderSection/0007.tct.ast b/test/Golden/TCT/HeaderSection/0007.tct.ast new file mode 100644 index 0000000..9a139fa --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0007.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 1:9 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 1:4 1:9 NodePara) + [ Tree (Cell 1:4 1:9 (NodeToken (TokenText "sec11"))) [] + ] + ] +, Tree (Cell 2:1 2:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:3 2:7 NodePara) + [ Tree (Cell 2:3 2:7 (NodeToken (TokenText "sec2"))) [] + ] + ] +, Tree (Cell 3:1 3:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:3 3:7 NodePara) + [ Tree (Cell 3:3 3:7 (NodeToken (TokenText "sec3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0007.tct.html5 b/test/Golden/TCT/HeaderSection/0007.tct.html5 new file mode 100644 index 0000000..1479b8a --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0007.tct.html5 @@ -0,0 +1,4 @@ + + sec11
##

sec11

+
#

sec2

+
#

sec3

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0007.tct.xml b/test/Golden/TCT/HeaderSection/0007.tct.xml new file mode 100644 index 0000000..a86a318 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0007.tct.xml @@ -0,0 +1,14 @@ +Cell 1:4 1:9 (XmlElem about) +| +`- Cell 1:4 1:9 (XmlElem title) + | + `- Cell 1:4 1:9 (XmlText "sec11") + +Cell 2:1 2:7 (XmlElem section) +| +`- Cell 2:3 2:7 (XmlAttr id "sec2") + +Cell 3:1 3:7 (XmlElem section) +| +`- Cell 3:3 3:7 (XmlAttr id "sec3") + diff --git a/test/Golden/TCT/HeaderSection/0008.tct b/test/Golden/TCT/HeaderSection/0008.tct new file mode 100644 index 0000000..1b70f0d --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0008.tct @@ -0,0 +1,3 @@ +# sec1 +# sec12 +# sec3 diff --git a/test/Golden/TCT/HeaderSection/0008.tct.ast b/test/Golden/TCT/HeaderSection/0008.tct.ast new file mode 100644 index 0000000..6e54b1c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0008.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 1:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + ] +, Tree (Cell 2:1 2:8 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:3 2:8 NodePara) + [ Tree (Cell 2:3 2:8 (NodeToken (TokenText "sec12"))) [] + ] + ] +, Tree (Cell 3:1 3:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:3 3:7 NodePara) + [ Tree (Cell 3:3 3:7 (NodeToken (TokenText "sec3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0008.tct.html5 b/test/Golden/TCT/HeaderSection/0008.tct.html5 new file mode 100644 index 0000000..94ea619 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0008.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

+
#

sec12

+
#

sec3

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0008.tct.xml b/test/Golden/TCT/HeaderSection/0008.tct.xml new file mode 100644 index 0000000..82dc053 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0008.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 2:8 (XmlElem section) +| +`- Cell 2:3 2:8 (XmlAttr id "sec12") + +Cell 3:1 3:7 (XmlElem section) +| +`- Cell 3:3 3:7 (XmlAttr id "sec3") + diff --git a/test/Golden/TCT/HeaderSection/0009.tct b/test/Golden/TCT/HeaderSection/0009.tct new file mode 100644 index 0000000..bf0b3ea --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0009.tct @@ -0,0 +1,3 @@ +# sec1 +# sec2 +## sec21 diff --git a/test/Golden/TCT/HeaderSection/0009.tct.ast b/test/Golden/TCT/HeaderSection/0009.tct.ast new file mode 100644 index 0000000..e3e8c00 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0009.tct.ast @@ -0,0 +1,16 @@ +[ Tree (Cell 1:1 1:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + ] +, Tree (Cell 2:1 3:9 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:3 2:7 NodePara) + [ Tree (Cell 2:3 2:7 (NodeToken (TokenText "sec2"))) [] + ] + , Tree (Cell 3:1 3:9 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 3:4 3:9 NodePara) + [ Tree (Cell 3:4 3:9 (NodeToken (TokenText "sec21"))) [] + ] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0009.tct.html5 b/test/Golden/TCT/HeaderSection/0009.tct.html5 new file mode 100644 index 0000000..15004f4 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0009.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

+
#

sec2

 +
##

sec21

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0009.tct.xml b/test/Golden/TCT/HeaderSection/0009.tct.xml new file mode 100644 index 0000000..e9fbadd --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0009.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 3:9 (XmlElem section) +| ++- Cell 2:3 2:7 (XmlAttr id "sec2") +| +`- Cell 3:1 3:9 (XmlElem section) + | + `- Cell 3:4 3:9 (XmlAttr id "sec21") + diff --git a/test/Golden/TCT/HeaderSection/0010.tct b/test/Golden/TCT/HeaderSection/0010.tct new file mode 100644 index 0000000..270ac8c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0010.tct @@ -0,0 +1,6 @@ +# sec1 +## sec11 +### sec111 +## sec12 +# sec2 +# sec3 diff --git a/test/Golden/TCT/HeaderSection/0010.tct.ast b/test/Golden/TCT/HeaderSection/0010.tct.ast new file mode 100644 index 0000000..1f57430 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0010.tct.ast @@ -0,0 +1,31 @@ +[ Tree (Cell 1:1 4:9 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:1 3:11 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 2:4 2:9 NodePara) + [ Tree (Cell 2:4 2:9 (NodeToken (TokenText "sec11"))) [] + ] + , Tree (Cell 3:1 3:11 (NodeHeader (HeaderSection 3))) + [ Tree (Cell 3:5 3:11 NodePara) + [ Tree (Cell 3:5 3:11 (NodeToken (TokenText "sec111"))) [] + ] + ] + ] + , Tree (Cell 4:1 4:9 (NodeHeader (HeaderSection 2))) + [ Tree (Cell 4:4 4:9 NodePara) + [ Tree (Cell 4:4 4:9 (NodeToken (TokenText "sec12"))) [] + ] + ] + ] +, Tree (Cell 5:1 5:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 5:3 5:7 NodePara) + [ Tree (Cell 5:3 5:7 (NodeToken (TokenText "sec2"))) [] + ] + ] +, Tree (Cell 6:1 6:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 6:3 6:7 NodePara) + [ Tree (Cell 6:3 6:7 (NodeToken (TokenText "sec3"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0010.tct.html5 b/test/Golden/TCT/HeaderSection/0010.tct.html5 new file mode 100644 index 0000000..db78170 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0010.tct.html5 @@ -0,0 +1,7 @@ + + sec1
#

sec1

 +
##

sec11

 +
###

sec111

+
##

sec12

+
#

sec2

+
#

sec3

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0010.tct.xml b/test/Golden/TCT/HeaderSection/0010.tct.xml new file mode 100644 index 0000000..2caabdd --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0010.tct.xml @@ -0,0 +1,26 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 3:11 (XmlElem section) +| ++- Cell 2:4 2:9 (XmlAttr id "sec11") +| +`- Cell 3:1 3:11 (XmlElem section) + | + `- Cell 3:5 3:11 (XmlAttr id "sec111") + +Cell 4:1 4:9 (XmlElem section) +| +`- Cell 4:4 4:9 (XmlAttr id "sec12") + +Cell 5:1 5:7 (XmlElem section) +| +`- Cell 5:3 5:7 (XmlAttr id "sec2") + +Cell 6:1 6:7 (XmlElem section) +| +`- Cell 6:3 6:7 (XmlAttr id "sec3") + diff --git a/test/Golden/TCT/HeaderSection/0011.tct b/test/Golden/TCT/HeaderSection/0011.tct new file mode 100644 index 0000000..6977fb9 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0011.tct @@ -0,0 +1,2 @@ +text1 +# sec1 diff --git a/test/Golden/TCT/HeaderSection/0011.tct.ast b/test/Golden/TCT/HeaderSection/0011.tct.ast new file mode 100644 index 0000000..3de57d6 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0011.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 1:6 NodePara) + [ Tree (Cell 1:1 1:6 (NodeToken (TokenText "text1"))) [] + ] +, Tree (Cell 2:1 2:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 2:3 2:7 NodePara) + [ Tree (Cell 2:3 2:7 (NodeToken (TokenText "sec1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0011.tct.html5 b/test/Golden/TCT/HeaderSection/0011.tct.html5 new file mode 100644 index 0000000..c48de13 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0011.tct.html5 @@ -0,0 +1,4 @@ + + + sec1text1 +
#

sec1

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0011.tct.xml b/test/Golden/TCT/HeaderSection/0011.tct.xml new file mode 100644 index 0000000..3cc53c0 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0011.tct.xml @@ -0,0 +1,8 @@ +Cell 1:1 1:6 (XmlElem para) +| +`- Cell 1:1 1:6 (XmlText "text1") + +Cell 2:1 2:7 (XmlElem section) +| +`- Cell 2:3 2:7 (XmlAttr id "sec1") + diff --git a/test/Golden/TCT/HeaderSection/0012.tct b/test/Golden/TCT/HeaderSection/0012.tct new file mode 100644 index 0000000..3323a96 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0012.tct @@ -0,0 +1,2 @@ +# sec1 +text1 diff --git a/test/Golden/TCT/HeaderSection/0012.tct.ast b/test/Golden/TCT/HeaderSection/0012.tct.ast new file mode 100644 index 0000000..6e58cac --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0012.tct.ast @@ -0,0 +1,9 @@ +[ Tree (Cell 1:1 2:6 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:1 2:6 NodePara) + [ Tree (Cell 2:1 2:6 (NodeToken (TokenText "text1"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0012.tct.html5 b/test/Golden/TCT/HeaderSection/0012.tct.html5 new file mode 100644 index 0000000..e0a2805 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0012.tct.html5 @@ -0,0 +1,3 @@ + + sec1
#

sec1

 +text1
\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0012.tct.xml b/test/Golden/TCT/HeaderSection/0012.tct.xml new file mode 100644 index 0000000..5606126 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0012.tct.xml @@ -0,0 +1,10 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 2:6 (XmlElem para) +| +`- Cell 2:1 2:6 (XmlText "text1") + diff --git a/test/Golden/TCT/HeaderSection/0013.tct b/test/Golden/TCT/HeaderSection/0013.tct new file mode 100644 index 0000000..94207e6 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0013.tct @@ -0,0 +1,3 @@ +# sec1 +text1 +# sec2 diff --git a/test/Golden/TCT/HeaderSection/0013.tct.ast b/test/Golden/TCT/HeaderSection/0013.tct.ast new file mode 100644 index 0000000..f381f7a --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0013.tct.ast @@ -0,0 +1,14 @@ +[ Tree (Cell 1:1 2:6 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:1 2:6 NodePara) + [ Tree (Cell 2:1 2:6 (NodeToken (TokenText "text1"))) [] + ] + ] +, Tree (Cell 3:1 3:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:3 3:7 NodePara) + [ Tree (Cell 3:3 3:7 (NodeToken (TokenText "sec2"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0013.tct.html5 b/test/Golden/TCT/HeaderSection/0013.tct.html5 new file mode 100644 index 0000000..9f7782d --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0013.tct.html5 @@ -0,0 +1,4 @@ + + sec1
#

sec1

 +text1
+
#

sec2

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0013.tct.xml b/test/Golden/TCT/HeaderSection/0013.tct.xml new file mode 100644 index 0000000..4ea66e6 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0013.tct.xml @@ -0,0 +1,14 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 2:6 (XmlElem para) +| +`- Cell 2:1 2:6 (XmlText "text1") + +Cell 3:1 3:7 (XmlElem section) +| +`- Cell 3:3 3:7 (XmlAttr id "sec2") + diff --git a/test/Golden/TCT/HeaderSection/0014.tct b/test/Golden/TCT/HeaderSection/0014.tct new file mode 100644 index 0000000..a9fcf92 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0014.tct @@ -0,0 +1,5 @@ +# sec1 +text1 +# sec11 +text2 +# sec2 diff --git a/test/Golden/TCT/HeaderSection/0014.tct.ast b/test/Golden/TCT/HeaderSection/0014.tct.ast new file mode 100644 index 0000000..44ce0d9 --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0014.tct.ast @@ -0,0 +1,22 @@ +[ Tree (Cell 1:1 2:6 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 1:3 1:7 NodePara) + [ Tree (Cell 1:3 1:7 (NodeToken (TokenText "sec1"))) [] + ] + , Tree (Cell 2:1 2:6 NodePara) + [ Tree (Cell 2:1 2:6 (NodeToken (TokenText "text1"))) [] + ] + ] +, Tree (Cell 3:1 4:6 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 3:3 3:8 NodePara) + [ Tree (Cell 3:3 3:8 (NodeToken (TokenText "sec11"))) [] + ] + , Tree (Cell 4:1 4:6 NodePara) + [ Tree (Cell 4:1 4:6 (NodeToken (TokenText "text2"))) [] + ] + ] +, Tree (Cell 5:1 5:7 (NodeHeader (HeaderSection 1))) + [ Tree (Cell 5:3 5:7 NodePara) + [ Tree (Cell 5:3 5:7 (NodeToken (TokenText "sec2"))) [] + ] + ] +] \ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0014.tct.html5 b/test/Golden/TCT/HeaderSection/0014.tct.html5 new file mode 100644 index 0000000..1f4971c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0014.tct.html5 @@ -0,0 +1,6 @@ + + sec1
#

sec1

 +text1
+
#

sec11

 +text2
+
#

sec2

\ No newline at end of file diff --git a/test/Golden/TCT/HeaderSection/0014.tct.xml b/test/Golden/TCT/HeaderSection/0014.tct.xml new file mode 100644 index 0000000..7065a9c --- /dev/null +++ b/test/Golden/TCT/HeaderSection/0014.tct.xml @@ -0,0 +1,22 @@ +Cell 1:3 1:7 (XmlElem about) +| +`- Cell 1:3 1:7 (XmlElem title) + | + `- Cell 1:3 1:7 (XmlText "sec1") + +Cell 2:1 2:6 (XmlElem para) +| +`- Cell 2:1 2:6 (XmlText "text1") + +Cell 3:1 4:6 (XmlElem section) +| ++- Cell 3:3 3:8 (XmlAttr id "sec11") +| +`- Cell 4:1 4:6 (XmlElem title) + | + `- Cell 4:1 4:6 (XmlText "text2") + +Cell 5:1 5:7 (XmlElem section) +| +`- Cell 5:3 5:7 (XmlAttr id "sec2") + diff --git a/test/HLint.hs b/test/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/test/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..2b600b8 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +module Main where + +import System.IO (IO) +import Data.Function (($)) + +import Test.Tasty +import Golden + +main :: IO () +main = do + goldens <- goldensIO + defaultMain $ + testGroup "Hdoc" + [ goldens + ] -- 2.42.0