Language/TCT/Token.hs

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