Language/TCT/Token.hs

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