Language/TCT/Token.hs

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