{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Token where
+import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
-import Data.Foldable (foldMap, foldr)
import Data.Function ((.))
-import Data.Monoid (Monoid(..))
+import Data.Foldable (foldMap, foldr)
+import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
+import Data.Sequence (Seq)
+import Data.Ord (Ord)
import Data.Text (Text)
import Data.Text.Buildable (Buildable(..))
+import Data.Text.Lazy.Builder (Builder)
import GHC.Exts (IsList(..))
import Text.Show (Show(..))
+import qualified Data.Char as Char
import qualified Data.Sequence as Seq
+import qualified Data.Text as Text
+import Language.TCT.Cell
import Language.TCT.Elem
-- * Type 'Token'
| TokenTag !Tag
| TokenEscape !Char
| TokenLink !Text
- deriving (Eq, Show)
+ 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<>build ts<>build o
+ 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))) ""
+
-- * Type 'Tokens'
-newtype Tokens = Tokens (Seq Token)
- deriving (Eq, Show)
+type Tokens = Seq (Cell Token)
+{-
instance Semigroup Tokens where
Tokens (Seq.viewr -> xs:>TokenPlain x) <>
Tokens (Seq.viewl -> TokenPlain y:<ys) =
unTokens :: Tokens -> Seq Token
unTokens (Tokens ts) = ts
+-}
+
+-- | Build 'Tokens' from many 'Token's.
+tokens :: [Cell Token] -> Tokens
+tokens = Seq.fromList
+
+-- | Build 'Tokens' from one 'Token'.
+tokens1 :: Cell Token -> Tokens
+tokens1 = Seq.singleton
+
+tokensPlainEmpty :: Tokens
+tokensPlainEmpty = Seq.singleton (cell1 (TokenPlain ""))
+
+isTokenWhite :: Token -> Bool
+isTokenWhite (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))
+ _ -> Nothing
--- | Build a 'Token' from many.
-tokens :: [Token] -> Tokens
-tokens = Tokens . Seq.fromList
+isTokenElem :: Tokens -> Bool
+isTokenElem ts =
+ case toList (Seq.dropWhileR (isTokenWhite . unCell) ts) of
+ [unCell -> TokenPair PairElem{} _] -> True
+ _ -> False
-- ** Type 'Tag'
type Tag = Text
| PairParen -- ^ @(value)@
| PairBrace -- ^ @{value}@
| PairBracket -- ^ @[value]@
- deriving (Eq, Show)
+ deriving (Eq, Ord, Show)
pairBorders :: Pair -> Tokens -> (Text,Text)
pairBorders p ts =
case p of
PairElem e attrs ->
- case ts of
- Tokens s | Seq.null s -> ("<"<>e<>foldMap f attrs<>"/>","")
- _ -> ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
+ if Seq.null ts
+ then ("<"<>e<>foldMap f attrs<>"/>","")
+ else ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
where f (attr_white,Attr{..}) =
attr_white <>
attr_name <>