From e730b8b904be35ebb21a26f788078de63207728c Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 3 Mar 2022 15:57:21 +0100
Subject: cwality-maps: add mustache templating

not going to be my faviourite templating language, but it seems to work
pretty well for this.
---
 cwality-maps/Substitute.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 95 insertions(+)
 create mode 100644 cwality-maps/Substitute.hs

(limited to 'cwality-maps/Substitute.hs')

diff --git a/cwality-maps/Substitute.hs b/cwality-maps/Substitute.hs
new file mode 100644
index 0000000..65e8fc3
--- /dev/null
+++ b/cwality-maps/Substitute.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Typeclasses for (generic) substitution on all strings contained in an ADT,
+-- failsafe, but with error reporting
+module Substitute (SubstitutionError, Substitutable(..)) where
+
+import           Universum
+
+import qualified Data.Aeson           as A
+import qualified Data.Foldable        as Fold
+import           Data.Tiled           (GlobalId, LocalId)
+import           GHC.Generics         (Generic (Rep, from, to), K1 (K1),
+                                       M1 (M1), U1, type (:*:) ((:*:)),
+                                       type (:+:) (..))
+import qualified Text.Mustache        as MU
+import qualified Text.Mustache.Render as MU
+import           Text.Parsec.Error    (ParseError)
+
+-- | errors that might be encountered. SubstitutionErrors occur during substitution
+-- and a generally non-fatal (but might result e.g. in empty strings being inserted
+-- instead of variables), while CompileErrors may indicate that (invalid) template
+-- syntax got leaked into the output
+data SubstitutionError = CompileError ParseError  | Mustache MU.SubstitutionError
+  deriving Show
+
+
+class Substitutable s where
+  substitute :: s -> Map Text Text -> ([SubstitutionError], s)
+
+instance Substitutable Text where
+  substitute orig substs = case MU.compileTemplate "" orig of
+    Right template -> first (map Mustache) $ MU.checkedSubstitute template substs
+    Left err -> ([CompileError err], orig) -- just ignore syntactic errors (TODO: add a log message?)
+
+
+instance {-# OVERLAPS #-} Substitutable String where
+  substitute orig substs = second toString (substitute (toText orig) substs)
+
+instance {-# OVERLAPPING #-} (Functor a, Substitutable b, Foldable a) => Substitutable (a b) where
+  substitute orig substs = (Fold.fold $ map fst orig',) $ map snd orig'
+    where orig' = map (`substitute` substs) orig
+
+-- | helper: don't substitute anything, don't produce errors
+trivial :: t -> b -> ([a], t)
+trivial = const . ([],)
+
+instance {-# OVERLAPS #-} Substitutable A.Value where
+  substitute = trivial
+
+instance Substitutable Int where
+  substitute = trivial
+
+instance Substitutable GlobalId where
+  substitute = trivial
+
+instance Substitutable LocalId where
+  substitute = trivial
+
+instance Substitutable Double where
+  substitute = trivial
+
+instance Substitutable Float where
+  substitute = trivial
+
+class GSubstitutable i where
+  gsubstitute :: i p -> Map Text Text -> ([SubstitutionError], i p)
+
+instance Substitutable c => GSubstitutable (K1 i c) where
+  gsubstitute (K1 text) = second K1 . substitute text
+
+instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :*: b) where
+  gsubstitute (a :*: b) substs = (e1 <> e2, a' :*: b')
+    where (e1, a') = gsubstitute a substs
+          (e2, b') = gsubstitute b substs
+
+instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :+: b) where
+  gsubstitute (L1 a) = second L1 . gsubstitute a
+  gsubstitute (R1 a) = second R1 . gsubstitute a
+
+instance (GSubstitutable a) => GSubstitutable (M1 x y a) where
+  gsubstitute (M1 a) = second M1 . gsubstitute a
+
+instance GSubstitutable U1 where
+  gsubstitute = trivial
+
+instance {-# OVERLAPPABLE #-} (GSubstitutable (Rep a), Generic a) => Substitutable a where
+  substitute a substs = second to (gsubstitute (from a) substs)
-- 
cgit v1.2.3