Language/TCT/Token.hs

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