Add HTML5 rendition of DTC.Index.
[doclang.git] / Language / TCT / Token.hs
index 7590b42dac646991420d9972b7a63d82b762dffc..3a571910c7c6c754395a50b1da9fc19511939458 100644 (file)
@@ -1,21 +1,27 @@
 {-# 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'
@@ -25,20 +31,23 @@ data 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) =
@@ -56,10 +65,34 @@ instance IsList Tokens where
 
 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
@@ -79,15 +112,15 @@ data Pair
  |   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  <>