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