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