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)
-- * 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
, 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(..))
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
import Language.TCT.Read.Tree
import Language.TCT.Read.Token
+import Debug.Trace (trace)
+
-- * Type 'TCT'
type TCT = Tree (Cell Key) Tokens
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
{-# 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(..))
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(..))
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 -- ^ @<name a=b@
+ | KeyDot !Name -- ^ @1. @
+ | KeyDash -- ^ @- @
+ | KeyDashDash -- ^ @-- @
+ | KeySection !LevelSection -- ^ @# @
+ | KeyBrackets !Name -- ^ @[name]@
+ | KeyDotSlash !PathFile -- ^ @./file @
+ | KeyPara
+ deriving (Eq, Ord, Show)
+
+-- ** Type 'Name'
+type Name = Text
+
+-- ** Type 'Value'
+type Value = Text
+
+-- ** Type 'PathFile'
+type PathFile = FP.FilePath
+
+-- ** Type 'LevelSection'
+type LevelSection = Int
+
+-- * Type 'Rows'
+-- | In reverse order: a list of nodes in scope
+-- (hence to which the next line can append to).
+type Rows = [Tree (Cell Key) (Cell Value)]
+
+-- * 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 -- ^ @<elem n0=v0 n1=v1>value</elem>@
+ | 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
(`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
-- | 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 =
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
| 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
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
'»' -> 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
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 -> ("[","]")
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.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
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Token where
+{-
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
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 -- ^ @<elem n0=v0 n1=v1>value</elem>@
- | 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
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Tree
( module Language.TCT.Tree
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 -- ^ @<name a=b@
- | KeyDot !Name -- ^ @1. @
- | KeyDash -- ^ @- @
- | KeyDashDash -- ^ @-- @
- | KeySection !LevelSection -- ^ @# @
- | KeyBrackets !Name -- ^ @[name]@
- | KeyDotSlash !PathFile -- ^ @./file @
- deriving (Eq, Ord, Show)
-
--- ** Type 'Name'
-type Name = Text
-
--- ** Type 'PathFile'
-type PathFile = FP.FilePath
-
--- ** Type 'LevelSection'
-type LevelSection = Int
-
--- * Type 'Rows'
-type Rows = [Tree (Cell Key) (Cell Text)]
-- | @appendRow rows row@ appends @row@ to @rows@.
--
dbg "appendRow" $
let colParent = columnPos $ posTree parent in
let colRow = columnPos $ posTree cell in
- case dbg "colParent" colParent`compare`dbg "colRow" colRow of
+ 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?
- (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
(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
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
+
+
+
{-# 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"
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 " "
{-# 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
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 ">"
"<" <>
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 =
S.put $ posEndCell p
ts' <- go`mapM`ts
return $ TreeN (lastPos,p) ts'
+-}
-- ** 'Int64'
int64 :: Integral i => i -> Int64
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") $
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) $
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))
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Blaze.Utils where
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
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
-- * 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 =
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
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
mainWithCommand (CommandRNC ArgsRNC{}) =
forM_ DTC.dtcRNC $ \w ->
Text.hPutStrLn stdout $ RNC.renderWriter w
+-}
-- * Options utils
-- * Type 'Command'
data Command
= CommandTCT ArgsTCT
+ {-
| CommandDTC ArgsDTC
| CommandRNC ArgsRNC
+ -}
pCommand :: Lang -> Parser Command
pCommand lang =
, command "tct" $
info (CommandTCT <$> pArgsTCT) $
progDesc "TCT (Texte Convivial Technique) rendition."
- ] <|>
+ ] {-<|>
hsubparser
[ metavar "dtc"
, command "dtc" $
, command "rnc" $
info (CommandRNC <$> pArgsRNC) $
progDesc "RNC (RelaxNG Compact) schema."
- ]
+ ]-}
-- * Type 'Trace'
data Trace
= ArgsTCT
{ input :: FilePath
, format :: TctFormat
+ , trace :: Trace
}
pArgsTCT :: Parser ArgsTCT
ArgsTCT
<$> argument str (metavar "FILE")
<*> pTctFormat
+ <*> pTrace
-- *** Type 'TctFormat'
data TctFormat
sourcephile / git / doclang.git / commitdiff