{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
module Language.TCT.Token where
-import Control.Monad (Monad(..))
-import Data.Bool (Bool(..))
+import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
-import Data.Monoid (Monoid(..))
import Data.Function ((.))
-import Data.Foldable (Foldable(..))
+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'
data Token
- = Tokens (Seq Token)
- | TokenPlain Text
- | TokenPair Pair Token
- | TokenTag Tag
- | TokenEscape Char
- | TokenLink Text
- deriving (Eq, Show)
-instance Semigroup Token where
- TokenPlain (Text.null -> True) <> y = y
- x <> TokenPlain (Text.null -> True) = x
-
- TokenPlain x <> TokenPlain y = TokenPlain (x<>y)
- Tokens (Seq.viewr -> xs:>x@TokenPlain{}) <> y@TokenPlain{} = Tokens (xs|>(x<>y))
- x@TokenPlain{} <> Tokens (Seq.viewl -> y@TokenPlain{}:<ys) = Tokens ((x<>y)<|ys)
-
+ = 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
+
+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:<ys) =
+ Tokens (xs<>(TokenPlain (x<>y)<|ys))
Tokens x <> Tokens y = Tokens (x<>y)
- Tokens x <> y = Tokens (x|>y)
- x <> Tokens y = Tokens (x<|y)
-
- x <> y = Tokens (Seq.fromList [x,y])
-instance Monoid Token where
- mempty = TokenPlain mempty
+instance Monoid Tokens where
+ mempty = Tokens mempty
mappend = (<>)
-instance Buildable Token where
- build (TokenPlain t) = build t
- build (Tokens ms) = foldr (\a b -> b <> build a) "" ms
- build (TokenTag t) = "#"<>build t
- build (TokenLink lnk) = build lnk
- build (TokenEscape c) = "\\"<>build c
- build (TokenPair g m) =
- let (o,c) = pairBorders g m in
- build c<>build m<>build o
-
--- | Build a 'Token' from many.
-tokens :: [Token] -> Token
-tokens = Tokens . Seq.fromList
-
--- | Remove 'Tokens' in given 'Token'
--- by flattening all 'Token's in a single 'Seq'.
-unTokens :: Token -> Seq Token
-unTokens (Tokens ts) = ts >>= unTokens
-unTokens tok = Seq.singleton tok
+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
+-}
+
+-- | 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
+
+isTokenElem :: Tokens -> Bool
+isTokenElem ts =
+ case toList (Seq.dropWhileR (isTokenWhite . unCell) ts) of
+ [unCell -> TokenPair PairElem{} _] -> True
+ _ -> False
-- ** Type 'Tag'
type Tag = Text
-- ** Type '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, Show)
-
-pairBorders :: Pair -> Token -> (Text,Text)
-pairBorders g m =
- case g of
+ = 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)
+
+pairBorders :: Pair -> Tokens -> (Text,Text)
+pairBorders p ts =
+ case p of
PairElem e attrs ->
- case m of
- Tokens ms | Seq.null ms -> ("<"<>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 <>
sourcephile / git / doclang.git / blobdiff