about summary refs log tree commit diff
path: root/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs
blob: 0f47729d68710e2a053647b43891bcb4343ba36c (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------------------------------
module Xanthous.Messages.Template
  ( -- * Template AST
    Template(..)
  , Substitution(..)
  , Filter(..)

    -- ** Template AST transformations
  , reduceTemplate

    -- * Template parser
  , template
  , runParser
  , errorBundlePretty

    -- * Template pretty-printer
  , ppTemplate

    -- * Rendering templates
  , TemplateVar(..)
  , nested
  , TemplateVars(..)
  , vars
  , RenderError
  , render
  )
where
--------------------------------------------------------------------------------
import           Xanthous.Prelude hiding
                 (many, concat, try, elements, some, parts)
--------------------------------------------------------------------------------
import           Test.QuickCheck hiding (label)
import           Test.QuickCheck.Instances.Text ()
import           Test.QuickCheck.Instances.Semigroup ()
import           Test.QuickCheck.Checkers (EqProp)
import           Control.Monad.Combinators.NonEmpty
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Data
import           Text.Megaparsec hiding (sepBy1, some)
import           Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import           Data.Function (fix)
--------------------------------------------------------------------------------
import Xanthous.Util (EqEqProp(..))
--------------------------------------------------------------------------------

genIdentifier :: Gen Text
genIdentifier = pack <$> listOf1 (elements identifierChars)

identifierChars :: String
identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_']

newtype Filter = FilterName Text
  deriving stock (Show, Eq, Ord, Generic, Data)
  deriving anyclass (NFData)
  deriving (IsString) via Text

instance Arbitrary Filter where
  arbitrary = FilterName <$> genIdentifier
  shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn

data Substitution
  = SubstPath (NonEmpty Text)
  | SubstFilter Substitution Filter
  deriving stock (Show, Eq, Ord, Generic, Data)
  deriving anyclass (NFData)

instance Arbitrary Substitution where
  arbitrary = sized . fix $ \gen n ->
    let leaves =
          [ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)]
        subtree = gen $ n `div` 2
    in if n == 0
       then oneof leaves
       else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ]
  shrink (SubstPath pth) =
    fmap SubstPath
    . filter (not . any ((||) <$> null <*> any (`notElem` identifierChars)))
    $ shrink pth
  shrink (SubstFilter s f)
    = shrink s
    <> (uncurry SubstFilter <$> shrink (s, f))

data Template
  = Literal Text
  | Subst Substitution
  | Concat Template Template
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)
  deriving EqProp via EqEqProp Template

instance Plated Template where
  plate _ tpl@(Literal _) = pure tpl
  plate _ tpl@(Subst _) = pure tpl
  plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂

reduceTemplate :: Template -> Template
reduceTemplate = transform $ \case
  (Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂)
  (Concat (Literal "") t) -> t
  (Concat t (Literal "")) -> t
  (Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃
  (Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃))
  t -> t

instance Eq Template where
  tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of
    (Literal t₁, Literal t₂) -> t₁ == t₂
    (Subst s₁, Subst s₂) -> s₁ == s₂
    (Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂
    _ -> False

instance Arbitrary Template where
  arbitrary = sized . fix $ \gen n ->
    let leaves = [ Literal . filter (`notElem` ['\\', '{']) <$> arbitrary
                 , Subst <$> arbitrary
                 ]
        subtree = gen $ n `div` 2
        genConcat = Concat <$> subtree <*> subtree
    in if n == 0
       then oneof leaves
       else oneof $ genConcat : leaves
  shrink (Literal t) = Literal <$> shrink t
  shrink (Subst s) = Subst <$> shrink s
  shrink (Concat t₁ t₂)
    = shrink t₁
    <> shrink t₂
    <> (Concat <$> shrink t₁ <*> shrink t₂)

instance Semigroup Template where
  (<>) = Concat

instance Monoid Template where
  mempty = Literal ""

--------------------------------------------------------------------------------

type Parser = Parsec Void Text

sc :: Parser ()
sc = L.space space1 empty empty

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc

symbol :: Text -> Parser Text
symbol = L.symbol sc

identifier :: Parser Text
identifier = lexeme . label "identifier" $ do
  firstChar <- letterChar <|> oneOf ['-', '_']
  restChars <- many $ alphaNumChar <|> oneOf ['-', '_']
  pure $ firstChar <| pack restChars

filterName :: Parser Filter
filterName = FilterName <$> identifier

substitutionPath :: Parser Substitution
substitutionPath = SubstPath <$> sepBy1 identifier (char '.')

substitutionFilter :: Parser Substitution
substitutionFilter = do
  path <- substitutionPath
  fs <- some $ symbol "|" *> filterName
  pure $ foldl' SubstFilter path fs
  -- pure $ SubstFilter path f

substitutionContents :: Parser Substitution
substitutionContents
  =   try substitutionFilter
  <|> substitutionPath

substitution :: Parser Substitution
substitution = between (string "{{") (string "}}") substitutionContents

literal :: Parser Template
literal = Literal <$>
  (   (string "\\{" $> "{")
  <|> takeWhile1P Nothing (`notElem` ['\\', '{'])
  )

subst :: Parser Template
subst = Subst <$> substitution

template' :: Parser Template
template' = do
  parts <- many $ literal <|> subst
  pure $ foldr Concat (Literal "") parts


template :: Parser Template
template = reduceTemplate <$> template' <* eof

--------------------------------------------------------------------------------

ppSubstitution :: Substitution -> Text
ppSubstitution (SubstPath substParts) = intercalate "." substParts
ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f

ppTemplate :: Template -> Text
ppTemplate (Literal txt) = txt
ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}"
ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂

--------------------------------------------------------------------------------

data TemplateVar
  = Val Text
  | Nested (Map Text TemplateVar)
  deriving stock (Show, Eq, Generic)
  deriving anyclass (NFData)

nested :: [(Text, TemplateVar)] -> TemplateVar
nested = Nested . mapFromList

instance Arbitrary TemplateVar where
  arbitrary = sized . fix $ \gen n ->
    let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2)
    in if n == 0
       then Val <$> arbitrary
       else oneof [ Val <$> arbitrary
                  , Nested <$> nst]

newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar }
  deriving stock (Show, Eq, Generic)
  deriving anyclass (NFData)
  deriving (Arbitrary) via (Map Text TemplateVar)

type instance Index TemplateVars = Text
type instance IxValue TemplateVars = TemplateVar
instance Ixed TemplateVars where
  ix k f (Vars vs) = Vars <$> ix k f vs
instance At TemplateVars where
  at k f (Vars vs) = Vars <$> at k f vs

vars :: [(Text, TemplateVar)] -> TemplateVars
vars = Vars . mapFromList

lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar
lookupVar vs (p :| []) = vs ^. at p
lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case
  (Val _) -> Nothing
  (Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps

data RenderError
  = NoSuchVariable (NonEmpty Text)
  | NestedFurther (NonEmpty Text)
  | NoSuchFilter Filter
  deriving stock (Show, Eq, Generic)
  deriving anyclass (NFData)

renderSubst
  :: Map Filter (Text -> Text) -- ^ Filters
  -> TemplateVars
  -> Substitution
  -> Either RenderError Text
renderSubst _ vs (SubstPath pth) =
  case lookupVar vs pth of
    Just (Val v) -> Right v
    Just (Nested _) -> Left $ NestedFurther pth
    Nothing -> Left $ NoSuchVariable pth
renderSubst fs vs (SubstFilter s fn) =
  case fs ^. at fn of
    Just filterFn -> filterFn <$> renderSubst fs vs s
    Nothing -> Left $ NoSuchFilter fn

render
  :: Map Filter (Text -> Text) -- ^ Filters
  -> TemplateVars             -- ^ Template variables
  -> Template                 -- ^ Template
  -> Either RenderError Text
render _ _ (Literal s) = pure s
render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂
render fs vs (Subst s) = renderSubst fs vs s