Language/TCT/Token.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 module Language.TCT.Token where
   4
   5 import Data.Char (Char)
   6 import Data.Eq (Eq(..))
   7 import Data.Monoid (Monoid(..))
   8 import Data.Function ((.))
   9 import Data.Foldable (Foldable(..))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
  12 import Data.Text (Text)
  13 import Data.Text.Buildable (Buildable(..))
  14 import Text.Show (Show(..))
  15 import qualified Data.Sequence as Seq
  16
  17 import Language.TCT.Elem
  18
  19 -- * Type 'Token'
  20 data Token
  21  =   TokenPlain  Text
  22  |   TokenPair   Pair Tokens
  23  |   TokenTag    Tag
  24  |   TokenEscape Char
  25  |   TokenLink   Text
  26  deriving (Eq, Show)
  27
  28 instance Buildable Token where
  29         build (TokenPlain t)   = build t
  30         build (TokenTag t)     = "#"<>build t
  31         build (TokenLink lnk)  = build lnk
  32         build (TokenEscape c)  = "\\"<>build c
  33         build (TokenPair p ts) = build c<>build ts<>build o
  34                 where (o,c) = pairBorders p ts
  35
  36 -- * Type 'Tokens'
  37 newtype Tokens = Tokens (Seq Token)
  38  deriving (Eq, Show)
  39
  40 instance Semigroup Tokens where
  41         Tokens (Seq.viewr -> xs:>TokenPlain x) <>
  42          Tokens (Seq.viewl -> TokenPlain y:<ys) =
  43                 Tokens (xs<>(TokenPlain (x<>y)<|ys))
  44         Tokens x <> Tokens y = Tokens (x<>y)
  45 instance Monoid Tokens where
  46         mempty  = Tokens mempty
  47         mappend = (<>)
  48 instance Buildable Tokens where
  49         build (Tokens ts) = foldr (\a -> (<> build a)) "" ts
  50
  51 unTokens :: Tokens -> Seq Token
  52 unTokens (Tokens ts) = ts
  53
  54 -- | Build a 'Token' from many.
  55 tokens :: [Token] -> Tokens
  56 tokens = Tokens . Seq.fromList
  57
  58 -- ** Type 'Tag'
  59 type Tag = Text
  60
  61 -- ** Type 'Pair'
  62 data Pair
  63  =   PairHash            -- ^ @#value#@
  64  |   PairElem Elem Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
  65  |   PairStar            -- ^ @*value*@
  66  |   PairSlash           -- ^ @/value/@
  67  |   PairUnderscore      -- ^ @_value_@
  68  |   PairDash            -- ^ @-value-@
  69  |   PairBackquote       -- ^ @`value`@
  70  |   PairSinglequote     -- ^ @'value'@
  71  |   PairDoublequote     -- ^ @"value"@
  72  |   PairFrenchquote     -- ^ @«value»@
  73  |   PairParen           -- ^ @(value)@
  74  |   PairBrace           -- ^ @{value}@
  75  |   PairBracket         -- ^ @[value]@
  76  deriving (Eq, Show)
  77
  78 pairBorders :: Pair -> Tokens -> (Text,Text)
  79 pairBorders p ts =
  80         case p of
  81          PairElem e attrs ->
  82                 case ts of
  83                  Tokens s | Seq.null s -> ("<"<>e<>foldMap f attrs<>"/>","")
  84                  _ -> ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
  85                 where f (attr_white,Attr{..}) =
  86                         attr_white <>
  87                         attr_name  <>
  88                         attr_open  <>
  89                         attr_value <>
  90                         attr_close
  91          PairHash        -> ("#","#")
  92          PairStar        -> ("*","*")
  93          PairSlash       -> ("/","/")
  94          PairUnderscore  -> ("_","_")
  95          PairDash        -> ("-","-")
  96          PairBackquote   -> ("`","`")
  97          PairSinglequote -> ("'","'")
  98          PairDoublequote -> ("\"","\"")
  99          PairFrenchquote -> ("«","»")
 100          PairParen       -> ("(",")")
 101          PairBrace       -> ("{","}")
 102          PairBracket     -> ("[","]")