Language/TCT/Token.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 {-# LANGUAGE TypeFamilies #-}
   4 module Language.TCT.Token where
   5
   6 import Data.Bool
   7 import Data.Char (Char)
   8 import Data.Eq (Eq(..))
   9 import Data.Function ((.))
  10 import Data.Foldable (foldMap, foldr)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Sequence (Seq)
  14 import Data.Ord (Ord)
  15 import Data.Text (Text)
  16 import Data.Text.Buildable (Buildable(..))
  17 import Data.Text.Lazy.Builder (Builder)
  18 import GHC.Exts (IsList(..))
  19 import Text.Show (Show(..))
  20 import qualified Data.Char as Char
  21 import qualified Data.Sequence as Seq
  22 import qualified Data.Text as Text
  23
  24 import Language.TCT.Cell
  25 import Language.TCT.Elem
  26
  27 -- * Type 'Token'
  28 data Token
  29  =   TokenPlain  !Text
  30  |   TokenPair   !Pair !Tokens
  31  |   TokenTag    !Tag
  32  |   TokenEscape !Char
  33  |   TokenLink   !Text
  34  deriving (Eq, Ord, Show)
  35
  36 instance Buildable Token where
  37         build (TokenPlain t)   = build t
  38         build (TokenTag t)     = "#"<>build t
  39         build (TokenLink lnk)  = build lnk
  40         build (TokenEscape c)  = "\\"<>build c
  41         build (TokenPair p ts) = build c<>buildTokens ts<>build o
  42                 where (o,c) = pairBorders p ts
  43
  44 buildTokens :: Tokens -> Builder
  45 buildTokens = foldr (\a -> (<> build (unCell a))) ""
  46
  47 -- * Type 'Tokens'
  48 type Tokens = Seq (Cell Token)
  49
  50 {-
  51 instance Semigroup Tokens where
  52         Tokens (Seq.viewr -> xs:>TokenPlain x) <>
  53          Tokens (Seq.viewl -> TokenPlain y:<ys) =
  54                 Tokens (xs<>(TokenPlain (x<>y)<|ys))
  55         Tokens x <> Tokens y = Tokens (x<>y)
  56 instance Monoid Tokens where
  57         mempty  = Tokens mempty
  58         mappend = (<>)
  59 instance Buildable Tokens where
  60         build (Tokens ts) = foldr (\a -> (<> build a)) "" ts
  61 instance IsList Tokens where
  62         type Item Tokens = Token
  63         fromList = Tokens . fromList
  64         toList (Tokens ts) = toList ts
  65
  66 unTokens :: Tokens -> Seq Token
  67 unTokens (Tokens ts) = ts
  68 -}
  69
  70 -- | Build 'Tokens' from many 'Token's.
  71 tokens :: [Cell Token] -> Tokens
  72 tokens = Seq.fromList
  73
  74 -- | Build 'Tokens' from one 'Token'.
  75 tokens1 :: Cell Token -> Tokens
  76 tokens1 = Seq.singleton
  77
  78 tokensPlainEmpty :: Tokens
  79 tokensPlainEmpty = Seq.singleton (cell1 (TokenPlain ""))
  80
  81 isTokenWhite :: Token -> Bool
  82 isTokenWhite (TokenPlain t) = Text.all Char.isSpace t
  83 isTokenWhite _              = False
  84
  85 unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens))
  86 unTokenElem ts =
  87         case toList (Seq.dropWhileR (isTokenWhite . unCell) ts) of
  88          [Cell bp ep (TokenPair (PairElem e as) toks)] -> Just (Cell bp ep (e,as,toks))
  89          _ -> Nothing
  90
  91 isTokenElem :: Tokens -> Bool
  92 isTokenElem ts =
  93         case toList (Seq.dropWhileR (isTokenWhite . unCell) ts) of
  94          [unCell -> TokenPair PairElem{} _] -> True
  95          _ -> False
  96
  97 -- ** Type 'Tag'
  98 type Tag = Text
  99
 100 -- ** Type 'Pair'
 101 data Pair
 102  =   PairHash              -- ^ @#value#@
 103  |   PairElem !Elem !Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
 104  |   PairStar              -- ^ @*value*@
 105  |   PairSlash             -- ^ @/value/@
 106  |   PairUnderscore        -- ^ @_value_@
 107  |   PairDash              -- ^ @-value-@
 108  |   PairBackquote         -- ^ @`value`@
 109  |   PairSinglequote       -- ^ @'value'@
 110  |   PairDoublequote       -- ^ @"value"@
 111  |   PairFrenchquote       -- ^ @«value»@
 112  |   PairParen             -- ^ @(value)@
 113  |   PairBrace             -- ^ @{value}@
 114  |   PairBracket           -- ^ @[value]@
 115  deriving (Eq, Ord, Show)
 116
 117 pairBorders :: Pair -> Tokens -> (Text,Text)
 118 pairBorders p ts =
 119         case p of
 120          PairElem e attrs ->
 121                 if Seq.null ts
 122                 then ("<"<>e<>foldMap f attrs<>"/>","")
 123                 else ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
 124                 where f (attr_white,Attr{..}) =
 125                         attr_white <>
 126                         attr_name  <>
 127                         attr_open  <>
 128                         attr_value <>
 129                         attr_close
 130          PairHash        -> ("#","#")
 131          PairStar        -> ("*","*")
 132          PairSlash       -> ("/","/")
 133          PairUnderscore  -> ("_","_")
 134          PairDash        -> ("-","-")
 135          PairBackquote   -> ("`","`")
 136          PairSinglequote -> ("'","'")
 137          PairDoublequote -> ("\"","\"")
 138          PairFrenchquote -> ("«","»")
 139          PairParen       -> ("(",")")
 140          PairBrace       -> ("{","}")
 141          PairBracket     -> ("[","]")