Language/TCT/Token.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 module Language.TCT.Token where
   4
   5 import Control.Monad (Monad(..))
   6 import Data.Bool (Bool(..))
   7 import Data.Char (Char)
   8 import Data.Eq (Eq(..))
   9 import Data.Monoid (Monoid(..))
  10 import Data.Function ((.))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
  14 import Data.Text (Text)
  15 import Data.Text.Buildable (Buildable(..))
  16 import Text.Show (Show(..))
  17 import qualified Data.Sequence as Seq
  18 import qualified Data.Text as Text
  19
  20 import Language.TCT.Elem
  21
  22 -- * Type 'Token'
  23 data Token
  24  =   Tokens (Seq Token)
  25  |   TokenPlain Text
  26  |   TokenGroup Group Token
  27  |   TokenTag Tag
  28  |   TokenEscape Char
  29  |   TokenLink Text
  30  deriving (Eq, Show)
  31 instance Semigroup Token where
  32         TokenPlain (Text.null -> True) <> y = y
  33         x <> TokenPlain (Text.null -> True) = x
  34
  35         TokenPlain x <> TokenPlain y = TokenPlain (x<>y)
  36         Tokens (Seq.viewr -> xs:>x@TokenPlain{}) <> y@TokenPlain{} = Tokens (xs|>(x<>y))
  37         x@TokenPlain{} <> Tokens (Seq.viewl -> y@TokenPlain{}:<ys) = Tokens ((x<>y)<|ys)
  38
  39         Tokens x <> Tokens y = Tokens (x<>y)
  40         Tokens x <> y = Tokens (x|>y)
  41         x <> Tokens y = Tokens (x<|y)
  42
  43         x <> y = Tokens (Seq.fromList [x,y])
  44 instance Monoid Token where
  45         mempty  = TokenPlain mempty
  46         mappend = (<>)
  47 instance Buildable Token where
  48         build (TokenPlain t) = build t
  49         build (Tokens ms) = foldr (\a b -> b <> build a) "" ms
  50         build (TokenTag t) = "#"<>build t
  51         build (TokenLink lnk) = build lnk
  52         build (TokenEscape c) = "\\"<>build c
  53         build (TokenGroup g m) =
  54                 let (o,c) = groupBorders g m in
  55                 build c<>build m<>build o
  56
  57 -- | Build a 'Token' from many.
  58 tokens :: [Token] -> Token
  59 tokens = Tokens . Seq.fromList
  60
  61 -- | Remove 'Tokens' in given 'Token'
  62 -- by flattening all 'Token's in a single 'Seq'.
  63 unTokens :: Token -> Seq Token
  64 unTokens (Tokens ts) = ts >>= unTokens
  65 unTokens tok = Seq.singleton tok
  66
  67 -- ** Type 'Tag'
  68 type Tag = Text
  69
  70 -- ** Type 'Group'
  71 data Group
  72  =   GroupHash            -- ^ @#value#@
  73  |   GroupElem Elem Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
  74  |   GroupStar            -- ^ @*value*@
  75  |   GroupSlash           -- ^ @/value/@
  76  |   GroupUnderscore      -- ^ @_value_@
  77  |   GroupDash            -- ^ @-value-@
  78  |   GroupBackquote       -- ^ @`value`@
  79  |   GroupSinglequote     -- ^ @'value'@
  80  |   GroupDoublequote     -- ^ @"value"@
  81  |   GroupFrenchquote     -- ^ @«value»@
  82  |   GroupParen           -- ^ @(value)@
  83  |   GroupBrace           -- ^ @{value}@
  84  |   GroupBracket         -- ^ @[value]@
  85  deriving (Eq, Show)
  86
  87 groupBorders :: Group -> Token -> (Text,Text)
  88 groupBorders g m =
  89         case g of
  90          GroupElem e attrs ->
  91                 case m of
  92                  Tokens ms | Seq.null ms -> ("<"<>e<>foldMap f attrs<>"/>","")
  93                  _ -> ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
  94                 where f (attr_white,Attr{..}) =
  95                         attr_white <>
  96                         attr_name  <>
  97                         attr_open  <>
  98                         attr_value <>
  99                         attr_close
 100          GroupHash        -> ("#","#")
 101          GroupStar        -> ("*","*")
 102          GroupSlash       -> ("/","/")
 103          GroupUnderscore  -> ("_","_")
 104          GroupDash        -> ("-","-")
 105          GroupBackquote   -> ("`","`")
 106          GroupSinglequote -> ("'","'")
 107          GroupDoublequote -> ("\"","\"")
 108          GroupFrenchquote -> ("«","»")
 109          GroupParen       -> ("(",")")
 110          GroupBrace       -> ("{","}")
 111          GroupBracket     -> ("[","]")