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 a 'Token' from many.
  61 tokens :: [Token] -> Tokens
  62 tokens = Tokens . Seq.fromList
  63
  64 -- ** Type 'Tag'
  65 type Tag = Text
  66
  67 -- ** Type 'Pair'
  68 data Pair
  69  =   PairHash            -- ^ @#value#@
  70  |   PairElem Elem Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
  71  |   PairStar            -- ^ @*value*@
  72  |   PairSlash           -- ^ @/value/@
  73  |   PairUnderscore      -- ^ @_value_@
  74  |   PairDash            -- ^ @-value-@
  75  |   PairBackquote       -- ^ @`value`@
  76  |   PairSinglequote     -- ^ @'value'@
  77  |   PairDoublequote     -- ^ @"value"@
  78  |   PairFrenchquote     -- ^ @«value»@
  79  |   PairParen           -- ^ @(value)@
  80  |   PairBrace           -- ^ @{value}@
  81  |   PairBracket         -- ^ @[value]@
  82  deriving (Eq, Show)
  83
  84 pairBorders :: Pair -> Tokens -> (Text,Text)
  85 pairBorders p ts =
  86         case p of
  87          PairElem e attrs ->
  88                 case ts of
  89                  Tokens s | Seq.null s -> ("<"<>e<>foldMap f attrs<>"/>","")
  90                  _ -> ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
  91                 where f (attr_white,Attr{..}) =
  92                         attr_white <>
  93                         attr_name  <>
  94                         attr_open  <>
  95                         attr_value <>
  96                         attr_close
  97          PairHash        -> ("#","#")
  98          PairStar        -> ("*","*")
  99          PairSlash       -> ("/","/")
 100          PairUnderscore  -> ("_","_")
 101          PairDash        -> ("-","-")
 102          PairBackquote   -> ("`","`")
 103          PairSinglequote -> ("'","'")
 104          PairDoublequote -> ("\"","\"")
 105          PairFrenchquote -> ("«","»")
 106          PairParen       -> ("(",")")
 107          PairBrace       -> ("{","}")
 108          PairBracket     -> ("[","]")