refactor(users/glittershark): Rename to grfn r/2485

Rename my //users directory and all places that refer to glittershark to
grfn, including nix references and documentation.

This may require some extra attention inside of gerrit's database after
it lands to allow me to actually push things.

Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: lukegb <lukegb@tvl.fyi>
Reviewed-by: glittershark <grfn@gws.fyi>

1 files changed, 275 insertions, 0 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Messages/Template.hs b/users/grfn/xanthous/src/Xanthous/Messages/Template.hs
new file mode 100644
index 0000000000..5176880355
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Messages/Template.hs
@@ -0,0 +1,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 . pack . 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