Functional jitsiRoomAdminTag adjustment

also yet another typeclass™, because why not?

8 files changed, 55 insertions, 39 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 5540aae..4d81bc2 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -23,6 +23,7 @@ import           Data.Maybe             (mapMaybe)
 import           Data.Text              (Text)
 import qualified Data.Text              as T
 import           GHC.Generics           (Generic)
+import           LintConfig             (LintConfig')
 import           Paths                  (normalise, normaliseWithFrag)
 import           System.Directory.Extra (doesFileExist)
 import           System.FilePath        (splitPath, (</>))
@@ -119,9 +120,9 @@ instance Monoid DirResult where
 -- gets a prefix (i.e. the bare path to the repository) and
 -- a root (i.e. the name of the file containing the entrypoint
 -- map within that file)
-recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
-recursiveCheckDir prefix root = do
-  linted <- recursiveCheckDir' prefix [root] mempty mempty
+recursiveCheckDir :: LintConfig' -> FilePath -> FilePath -> IO DirResult
+recursiveCheckDir config prefix root = do
+  linted <- recursiveCheckDir' config prefix [root] mempty mempty
   mAssets <- missingAssets prefix linted
   pure $ linted <> mempty { dirresultDeps = missingDeps linted
                           , dirresultMissingAssets = mAssets
@@ -173,14 +174,14 @@ missingAssets prefix res =
 -- Strictly speaking it probably doesn't need to have `done` and
 -- `acc` since they are essentially the same thing, but doing it
 -- like this seemed convenient at the time
-recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
-recursiveCheckDir' prefix paths done acc = do
+recursiveCheckDir' :: LintConfig' -> FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
+recursiveCheckDir' config prefix paths done acc = do
 
   -- lint all maps in paths. The double fmap skips maps which cause IO errors
   -- (in which case loadAndLintMap returns Nothing); appropriate warnings will
   -- show up later during dependency checks
   lints <-
-    let lintPath p = fmap (fmap (p,)) (loadAndLintMap (prefix </> p) depth)
+    let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth)
           where depth = length (splitPath p) - 1
     in mapMaybeM lintPath paths
 
@@ -208,8 +209,4 @@ recursiveCheckDir' prefix paths done acc = do
   -- Tail recursion!
   case unknowns of
     [] -> pure acc'
-    _  -> recursiveCheckDir' prefix unknowns knowns acc'
-
-
-
-
+    _  -> recursiveCheckDir' config prefix unknowns knowns acc'
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 1b42854..962da22 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -21,6 +21,7 @@ import qualified Data.Vector      as V
 import           GHC.Generics     (Generic)
 
 
+import           LintConfig       (LintConfig')
 import           LintWriter       (filterLintLevel, invertLintResult, lintToDep,
                                    resultToAdjusted, resultToDeps,
                                    resultToLints, resultToOffers, runLintWriter)
@@ -71,19 +72,19 @@ instance ToJSON CollectedLints where
 -- | this module's raison d'être
 -- Lints the map at `path`, and limits local links to at most `depth`
 -- layers upwards in the file hierarchy
-loadAndLintMap :: FilePath -> Int -> IO (Maybe MapResult)
-loadAndLintMap path depth = loadTiledmap path <&> (\case
+loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
+loadAndLintMap config path depth = loadTiledmap path <&> (\case
     DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing
         [ hint Fatal . T.pack $
           path <> ": Fatal: " <> err
         ])
     IOErr _ -> Nothing
     Loaded waMap ->
-      Just (runLinter waMap depth))
+      Just (runLinter config waMap depth))
 
 -- | lint a loaded map
-runLinter :: Tiledmap -> Int -> MapResult
-runLinter tiledmap depth = MapResult
+runLinter :: LintConfig' -> Tiledmap -> Int -> MapResult
+runLinter config tiledmap depth = MapResult
   { mapresultLayer = invertThing layer
   , mapresultTileset = invertThing tileset
   , mapresultGeneral = resultToLints generalResult
@@ -96,10 +97,10 @@ runLinter tiledmap depth = MapResult
   where
     layer = checkThing tiledmapLayers checkLayer
     tileset = checkThing tiledmapTilesets checkTileset
-    generalResult = runLintWriter tiledmap depth checkMap
+    generalResult = runLintWriter config tiledmap depth checkMap
 
     checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap
-      where runCheck thing = runLintWriter thing depth checker
+      where runCheck thing = runLintWriter config thing depth checker
 
     -- | "inverts" a LintResult, i.e. groups it by lints instead of
     --    layers / maps
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index 0f65752..1493fe2 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -12,8 +12,8 @@
 module LintConfig where
 
 import           Control.Monad.Identity (Identity)
-import           Data.Aeson             (FromJSON (parseJSON), defaultOptions,
-                                         eitherDecode, Options(..))
+import           Data.Aeson             (FromJSON (parseJSON), Options (..),
+                                         defaultOptions, eitherDecode)
 import           Data.Aeson.Types       (genericParseJSON)
 import qualified Data.ByteString.Char8  as C8
 import qualified Data.ByteString.Lazy   as LB
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 54a5954..c8ab6d5 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -24,6 +24,7 @@ import           Data.Maybe                 (mapMaybe)
 import qualified Data.Text                  as T
 import           Util                       (PrettyPrint (..))
 
+import           LintConfig                 (LintConfig')
 import           Tiled2                     (HasName)
 import           Types
 
@@ -31,12 +32,14 @@ import           Types
 -- we currently are
 type Context = Int
 
-newtype LinterState ctxt = LinterState { fromLinterState :: ([Lint], ctxt)}
+newtype LinterState ctxt = LinterState
+  { fromLinterState :: ([Lint], ctxt)}
 
 
 -- | a monad to collect hints, with some context (usually the containing layer/etc.)
 type LintWriter ctxt = LintWriter' ctxt ()
-type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt)) res
+type LintWriter' ctxt res =
+  StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res
 
 -- wrapped to allow for manual writing of Aeson instances
 type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
@@ -88,9 +91,9 @@ resultToAdjusted :: LintResult a -> a
 resultToAdjusted (LintResult res) = fst res
 
 -- | run a linter. Returns the adjusted context, and a list of lints
-runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
-runLintWriter c c' linter =  LintResult (snd $ fromLinterState lints,fst $ fromLinterState lints)
-  where lints = snd $ runReader ranstate (c',c)
+runLintWriter :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
+runLintWriter config c c' linter =  LintResult (snd $ fromLinterState lints,fst $ fromLinterState lints)
+  where lints = snd $ runReader ranstate (c',c, config)
         ranstate = runStateT linter (LinterState ([], c))
 
 tell' :: Lint -> LintWriter ctxt
@@ -122,7 +125,10 @@ complain = lint Error
 
 -- | get the context as it was originally, without any modifications
 askContext :: LintWriter' a a
-askContext = lift $ asks snd
+askContext = lift $ asks (\(_,a,_) -> a)
 
 askFileDepth :: LintWriter' a Int
-askFileDepth = lift $ asks fst
+askFileDepth = lift $ asks (\(a,_,_) -> a)
+
+lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a
+lintConfig get = lift $ asks (\(_,_,config) -> get config)
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 3ad8af2..e6a3384 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -9,14 +9,16 @@ module Properties (checkMap, checkTileset, checkLayer) where
 import           Control.Monad (unless, when)
 import           Data.Text     (Text, isPrefixOf)
 import           Tiled2        (HasProperties (adjustProperties, getProperties),
-                                Layer (..), Property (..), PropertyValue (..),
+                                IsProperty (asProperty), Layer (..),
+                                Property (..), PropertyValue (..),
                                 Tiledmap (..), Tileset (..))
 import           Util          (layerIsEmpty, prettyprint)
 
 import           Data.Maybe    (fromMaybe)
+import           LintConfig    (LintConfig (configAssemblyTag))
 import           LintWriter    (LintWriter, adjust, askContext, askFileDepth,
-                                complain, dependsOn, forbid, offersEntrypoint,
-                                suggest, warn)
+                                complain, dependsOn, forbid, lintConfig,
+                                offersEntrypoint, suggest, warn)
 import           Paths         (RelPath (..), parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
 
@@ -108,7 +110,8 @@ checkLayer = do
 checkLayerProperty :: Property -> LintWriter Layer
 checkLayerProperty p@(Property name _value) = case name of
     "jitsiRoom" -> do
-      setProperty "jitsiRoomAdminTag" "Hello, World"
+      lintConfig configAssemblyTag
+        >>= setProperty "jitsiRoomAdminTag"
       uselessEmptyLayer
       unwrapString p $ \_val -> do
         suggestProperty $ Property "jitsiTrigger" (StrProp "onaction")
@@ -228,9 +231,11 @@ suggestProperty (Property name value) =
   $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
 
 -- | set a property, overwriting whatever value it had previously
-setProperty :: HasProperties ctxt => Text -> PropertyValue -> LintWriter ctxt
+setProperty :: (IsProperty prop, HasProperties ctxt)
+  => Text -> prop -> LintWriter ctxt
 setProperty name value = adjust $ \ctxt ->
-  adjustProperties (\props -> Just $ Property name value : filter sameName props) ctxt
+  flip adjustProperties ctxt
+  $ \ps -> Just $ Property name (asProperty value) : filter sameName ps
   where sameName (Property name' _) = name /= name'
 
 -- | does this layer have the given property?
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index efa8a07..873e22d 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -339,6 +339,15 @@ instance HasName Layer where
 instance HasName Tileset where
   getName = tilesetName
 
+class IsProperty a where
+  asProperty :: a -> PropertyValue
+instance IsProperty PropertyValue where
+  asProperty = id
+  {-# INLINE asProperty #-}
+instance IsProperty Text where
+  asProperty = StrProp
+  {-# INLINE asProperty #-}
+
 data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String
 
 -- | Load a Tiled map from the given 'FilePath'.
diff --git a/lib/Types.hs b/lib/Types.hs
index 00f0ee7..0d35432 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -10,7 +10,8 @@
 module Types where
 
 import           Control.Monad.Trans.Maybe ()
-import           Data.Aeson                (ToJSON (toJSON), ToJSONKey, (.=))
+import           Data.Aeson                (FromJSON, ToJSON (toJSON),
+                                            ToJSONKey, (.=))
 import           Data.Text                 (Text)
 import           GHC.Generics              (Generic)
 
@@ -27,7 +28,7 @@ import           WithCli.Pure              (Argument (argumentType, parseArgumen
 -- | Levels of errors and warnings, collectively called
 -- "Hints" until I can think of some better name
 data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
-  deriving (Show, Generic, Ord, Eq, ToJSON)
+  deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON)
 
 instance Argument Level where
   argumentType Proxy = "Lint Level"
diff --git a/src/Main.hs b/src/Main.hs
index 5dcf13c..a7710eb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -49,7 +49,6 @@ run options = do
   let repo = fromMaybe "." (repository options)
   let entry = fromMaybe "main.json" (entrypoint options)
   let level = fromMaybe Suggestion (lintlevel options)
-  print (config options)
 
   lintconfig <- case configFile options of
     Nothing -> error "Need a config file!"
@@ -60,9 +59,7 @@ run options = do
           Just p  -> pure (patch file p)
           Nothing -> pure file
 
-  print lintconfig
-
-  lints <- recursiveCheckDir repo entry
+  lints <- recursiveCheckDir lintconfig repo entry
 
   if json options
     then printLB