From 35566bf15f43c355bdc72d62841a850a90c8ba03 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 16 Sep 2021 02:27:26 +0200
Subject: [PATCH] moving lots of code around
(also renaming things now that concepts seem a bit clearer)
---
lib/LintWriter.hs | 61 ++++++++++++++
lib/Properties.hs | 116 +++++++++++++++++++++++++
{src => lib}/Tiled2.hs | 0
lib/Types.hs | 3 +
lib/Util.hs | 27 ++++++
src/Main.hs | 187 ++++++-----------------------------------
tiled-hs.cabal | 35 ++++++--
7 files changed, 260 insertions(+), 169 deletions(-)
create mode 100644 lib/LintWriter.hs
create mode 100644 lib/Properties.hs
rename {src => lib}/Tiled2.hs (100%)
create mode 100644 lib/Types.hs
create mode 100644 lib/Util.hs
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
new file mode 100644
index 0000000..0146366
--- /dev/null
+++ b/lib/LintWriter.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- | a monad that collects warnings, outputs, etc,
+module LintWriter where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Maybe (isJust, mapMaybe)
+import Control.Monad.Writer
+import Control.Monad.Trans.Maybe
+
+
+-- | Levels of errors and warnings, collectively called
+-- "Hints" until I can think of some better name
+data Level = Warning | Suggestion | Info | Forbidden | Error
+ deriving Show
+
+-- | a hint comes with an explanation (and a level)
+data Hint = Hint
+ { hintLevel :: Level
+ , hintMsg :: Text }
+ deriving Show
+
+-- shorter constructor
+hint level msg = Hint { hintLevel = level, hintMsg = msg }
+
+-- | a monad to collect hints. If it yields Left, then the
+-- map is flawed in some fundamental way which prevented us
+-- from getting any hints at all except whatever broke it
+type LintWriter a = WriterT [Hint] (Either Hint) a
+
+type LintResult a = Either Hint (a, [Hint])
+
+-- | write a hint into the LintWriter monad
+lint :: Level -> Text -> LintWriter ()
+lint level = tell . (: []) . hint level
+
+warn = lint Warning
+info = lint Info
+forbid = lint Forbidden
+suggest = lint Suggestion
+complain = lint Error
+
+
+-- TODO: all these functions should probably also just operate on LintWriter
+
+-- | converts a Maybe to an Either, with a default value for Left
+unwrap :: b -> Maybe a -> Either b a
+unwrap hint maybe = case maybe of
+ Just a -> Right a
+ Nothing -> Left hint
+
+-- | unwrap and produce a warning if the value was Nothing
+unwrapWarn :: Text -> Maybe a -> Either Hint a
+unwrapWarn msg = unwrap $ hint Warning msg
+
+-- | same as unwrapWarn, but for booleans
+assertWarn :: Text -> Bool -> LintWriter ()
+assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg
diff --git a/lib/Properties.hs b/lib/Properties.hs
new file mode 100644
index 0000000..0b9a71f
--- /dev/null
+++ b/lib/Properties.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Contains checks for custom properties of the map json
+module Properties (checkProperty) where
+
+
+import Control.Monad (unless, when)
+import Control.Monad.Trans.Class (lift)
+import Data.Aeson as Aeson (Value (String))
+import Data.Map (Map, (!?))
+import Data.Text (Text)
+import Tiled2 (Layer (layerProperties))
+import Util (quote, showAeson)
+
+import LintWriter (Hint, LintWriter, Level(..), hint,
+ assertWarn, complain, forbid, info,
+ suggest, unwrapWarn, warn)
+
+-- | values may be anything, and are not typechecked (for now),
+-- since they may contain arbitrary json – our only guarantee
+-- is that they are named, and therefore a map.
+type Properties = Map Text Aeson.Value
+
+
+
+-- | /technically/ the main function here
+--
+-- given a property, check if it is valid. It gets a reference
+-- to its own layer since sometimes the presense of one property
+-- implies the presence or absense of another.
+--
+-- The tests in here are meant to comply with the informal spec
+-- at https://workadventu.re/map-building
+--
+-- In practice, the actual specifiaction of what is allowed is
+-- handled in checkProperty', since apparently all possible layerProperties
+-- are strings anyways, so this just extracts that string and then
+-- calls that.
+checkProperty :: Layer -> Properties -> LintWriter ()
+checkProperty layer prop = do
+ tyObj <- lift $ getAttr prop "name"
+ ty <- lift $ case tyObj of
+ Aeson.String str -> Right str
+ _ -> Left (hint Suggestion "wtf")
+ checkProperty' layer prop ty
+
+-- | The /real/ main thing.
+--
+-- I've attempted to build the LintWriter monad in a way
+-- that should make this readable even to non-Haskellers
+checkProperty' :: Layer -> Properties -> Text -> LintWriter ()
+checkProperty' layer prop ty = case ty of
+ "jitsiRoom" -> do
+ propEqual prop "type" "string"
+ urlValue <- lift $ getAttr prop "value"
+ info $ "found jitsi room: " <> showAeson urlValue
+ suggestPropertyValue "jitsiTrigger" "onaction"
+ "jitsiTrigger" ->
+ requireProperty "jitsiRoom"
+ "jitsiUrl" -> isForbidden
+ "jitsiConfig" -> isForbidden
+ "jitsiClientConfig" -> isForbidden
+ "jitsiRoomAdminTag" -> isForbidden
+ "playAudio" -> do
+ -- TODO: check for url validity?
+ propEqual prop "type" "string"
+ "audioLoop" ->
+ requireProperty "playAudio"
+ "audioVolume" ->
+ requireProperty "playAudio"
+ "openWebsite" ->
+ suggestPropertyValue "openWebsiteTrigger" "onaction"
+ "openWebsiteTrigger" ->
+ requireProperty "openWebsite"
+ "openWebsitePolicy" ->
+ requireProperty "openWebsite"
+ "exitUrl" -> pure ()
+ "startLayer" -> pure ()
+ -- could also make this a "hard error" (i.e. Left), but then it
+ -- stops checking other properties as checkLayer short-circuits.
+ _ -> warn $ "unknown property type " <> quote ty
+ where
+ -- | require some property in this layer
+ requireProperty name = unless (hasProperty name layer)
+ $ complain $ "property "<>quote name<>" requires property "<>quote ty
+ -- | forbid some property in this layer
+ forbidProperty name = when (hasProperty name layer)
+ $ forbid $ "property " <> quote name <> " should not be used"
+ -- | This property is forbidden and should not be used
+ isForbidden = forbid $ "property " <> quote ty <> " should not be used"
+ -- TODO: check if the property has the correct value
+ suggestPropertyValue name value = unless (hasProperty name layer)
+ $ suggest $ "set property " <> quote name <> " to " <> quote value
+
+
+
+
+-- | does this layer have the given property?
+hasProperty :: Text -> Layer -> Bool
+hasProperty name = any
+ (\prop -> prop !? "name" == Just (Aeson.String name))
+ . layerProperties
+
+-- | get an attribute from a map
+getAttr :: Properties -> Text -> Either Hint Aeson.Value
+getAttr props name = unwrapWarn msg $ props !? name
+ where msg = "field " <> name <> "does not exist"
+
+-- | lint goal: the property with the given name has given value
+propEqual :: Properties -> Text -> Aeson.Value -> LintWriter ()
+propEqual props name value = do
+ value' <- lift $ getAttr props name
+ assertWarn ("field "<>name<>" has unexpected value "<>showAeson value'
+ <>", should be "<>showAeson value)
+ $ value' == value
diff --git a/src/Tiled2.hs b/lib/Tiled2.hs
similarity index 100%
rename from src/Tiled2.hs
rename to lib/Tiled2.hs
diff --git a/lib/Types.hs b/lib/Types.hs
new file mode 100644
index 0000000..082b30e
--- /dev/null
+++ b/lib/Types.hs
@@ -0,0 +1,3 @@
+-- | basic types for workadventure maps
+
+module Types where
diff --git a/lib/Util.hs b/lib/Util.hs
new file mode 100644
index 0000000..be67143
--- /dev/null
+++ b/lib/Util.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module Util where
+
+import Data.Text (Text)
+import Data.Text as T
+import Data.Aeson as Aeson
+
+-- | haskell's many string types are FUN …
+showText :: Show a => a -> Text
+showText = T.pack . show
+
+-- | same as showText, but without the "String"-prefix for strings
+-- TODO: serialise back into json for printing? People may get
+-- confused by the type annotations if they only know json …
+showAeson :: Aeson.Value -> Text
+showAeson (Aeson.String s) = showText s
+showAeson v = showText v
+
+
+
+
+
+-- | adds quotes (but does not escape, for now!)
+quote :: Text -> Text
+quote text = "\"" <> text <> "\""
diff --git a/src/Main.hs b/src/Main.hs
index 4de1183..d820c20 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,160 +1,28 @@
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
module Main where
-import Data.Map (Map, (!?))
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Maybe (isJust, mapMaybe)
-import qualified Data.Aeson as Aeson
-import Data.Vector (Vector)
-import Data.Set (Set, fromList)
-import qualified Data.Vector as V
-import Control.Monad.Writer
-import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Maybe
+import Control.Monad.Writer
+import qualified Data.Aeson as Aeson
+import Data.Map (Map, (!?))
+import Data.Maybe (isJust, mapMaybe)
+import Data.Set (Set, fromList)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Vector (Vector)
+import qualified Data.Vector as V
-import Tiled2
+import LintWriter (LintWriter, LintResult, Hint(..), Level(..))
+import Properties (checkProperty)
+import Tiled2
+import Util (showText)
-data Level = Warning | Suggestion | Info | Forbidden | Error
- deriving Show
-data Hint = Hint
- { hintLevel :: Level
- , hintMsg :: Text }
- deriving Show
--- shorter constructors
-suggestion msg = Hint { hintLevel = Suggestion, hintMsg = msg }
-warning msg = Hint { hintLevel = Warning, hintMsg = msg }
-forbidden msg = Hint { hintLevel = Forbidden, hintMsg = msg }
-
-
--- | converts a Maybe to an Either, with a default value for Left
-unwrap :: b -> Maybe a -> Either b a
-unwrap hint maybe = case maybe of
- Just a -> Right a
- Nothing -> Left hint
-
--- | unwrap and produce a warning if the value was Nothing
-unwrapWarn :: Text -> Maybe a -> Either Hint a
-unwrapWarn msg = unwrap $ warning msg
-
--- | get an attribute from a map
-getAttr :: Map Text Aeson.Value -> Text -> Either Hint Aeson.Value
-getAttr props name = unwrapWarn msg $ props !? name
- where msg = "field " <> name <> "does not exist"
-
--- | same as unwrapWarn, but for booleans
-assertWarn :: Text -> Bool -> Either Hint ()
-assertWarn msg cond = if cond then Right () else Left $ warning msg
-
--- | haskell's many string types are FUN …
-showText :: Show a => a -> Text
-showText = T.pack . show
-
--- | same as showText, but without the "String"-prefix for strings
--- TODO: serialise back into json for printing? People may get
--- confused by the type annotations if they only know json …
-showAeson :: Aeson.Value -> Text
-showAeson (Aeson.String s) = showText s
-showAeson v = showText v
-
--- | the given property should have the given value. Otherwise, warning.
-propEqual :: Map Text Aeson.Value -> Text -> Aeson.Value -> Either Hint ()
-propEqual props name value = do
- value' <- getAttr props name
- assertWarn ("field "<>name<>" has unexpected value "<>showAeson value'
- <>", should be "<>showAeson value)
- $ value' == value
-
--- |
--- This type may require some explanation.
--- Essentially, it's a monad that can short-curcuit (i.e. abort),
--- and also collect hints as it goes. Currently, both aborts and
--- hints are the same type (Hint); if the monad ends up returning
--- Left Hint, then something went entirely wrong; if it returns
--- Right (a, [Hint]), then it ran through, calculated a, and collected
--- a list of linter hints along the way.
-type MaybeWriter a = WriterT [Hint] (Either Hint) a
-
-
--- | type juggling to get a single warning into MaybeWriter a
-maybeWriterHint :: (Text -> Hint) -> Text -> MaybeWriter ()
-maybeWriterHint constructor = tell . (: []) . constructor
-
-warn = maybeWriterHint warning
-info = maybeWriterHint (\t -> Hint { hintLevel = Info, hintMsg = t })
-forbid = maybeWriterHint forbidden
-suggest = maybeWriterHint suggestion
-complain = maybeWriterHint (\t -> Hint { hintLevel = Error, hintMsg = t })
-
--- | adds quotes (but does not escape, for now!)
-quote :: Text -> Text
-quote text = "\"" <> text <> "\""
-
--- | does this layer have the given property?
-hasProperty :: Text -> Layer -> Bool
-hasProperty name = any
- (\prop -> prop !? "name" == Just (Aeson.String name))
- . layerProperties
-
-
-
--- | The main thing
---
--- given a property, check if it is valid. It gets a reference
--- to its own layer since sometimes the presense of one property
--- implies the presence or absense of another.
---
--- The tests in here are meant to comply with the informal spec
--- at https://workadventu.re/map-building
-checkProperty :: Layer -> Map Text Aeson.Value -> MaybeWriter ()
-checkProperty layer prop = do
- tyObj <- lift $ getAttr prop "name"
- ty <- lift $ case tyObj of
- Aeson.String str -> Right str
- _ -> Left (suggestion "wtf")
- checkTyped ty
- where checkTyped ty = case ty of
- "jitsiRoom" -> do
- lift $ propEqual prop "type" "string"
- urlValue <- lift $ getAttr prop "value"
- info $ "found jitsi room: " <> showAeson urlValue
- suggestPropertyValue "jitsiTrigger" "onaction"
- "jitsiTrigger" -> requireProperty "jitsiRoom"
- "jitsiUrl" -> isForbidden
- "jitsiConfig" -> isForbidden
- "jitsiClientConfig" -> isForbidden
- "jitsiRoomAdminTag" -> isForbidden
- "playAudio" -> do
- -- TODO: check for url validity?
- lift $ propEqual prop "type" "string"
- "audioLoop" -> requireProperty "playAudio"
- "audioVolume" -> requireProperty "playAudio"
- "openWebsite" -> suggestPropertyValue "openWebsiteTrigger" "onaction"
- "openWebsiteTrigger" -> requireProperty "openWebsite"
- "openWebsitePolicy" -> requireProperty "openWebsite"
- "exitUrl" -> return ()
- "startLayer" -> return ()
- -- could also make this a "hard error" (i.e. Left), but then it
- -- stops checking other properties as checkLayer short-circuits.
- _ -> warn $ "unknown property type " <> quote ty
- where
- -- | require some property in this layer
- requireProperty name = unless (hasProperty name layer)
- $ complain $ "property "<>quote name<>" requires property "<>quote ty
- -- | forbid some property in this layer
- forbidProperty name = when (hasProperty name layer)
- $ forbid $ "property " <> quote name <> " should not be used"
- -- | This property is forbidden and should not be used
- isForbidden = forbid $ "property " <> quote ty <> " should not be used"
- -- TODO: check if the property has the correct value
- suggestPropertyValue name value = unless (hasProperty name layer)
- $ suggest $ "set property " <> quote name <> " to " <> quote value
-
-checkLayer :: Layer -> MaybeWriter ()
+checkLayer :: Layer -> LintWriter ()
checkLayer layer =
mapM_ (checkProperty layer) (layerProperties layer)
@@ -163,7 +31,7 @@ showContext :: Text -> Text
showContext ctxt = " (in layer " <> ctxt <> ")\n"
-- | pretty-printer for a result of WriterMaybe (currently only for errors/hints)
-showResult :: Show a => Text -> Either Hint (a, [Hint]) -> Maybe Text
+showResult :: Show a => Text -> LintResult a -> Maybe Text
showResult ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
showResult _ (Right (a, [])) = Nothing
showResult ctxt (Right (a, hints)) = Just $ showHints hints
@@ -172,21 +40,18 @@ showResult ctxt (Right (a, hints)) = Just $ showHints hints
-- TODO: make the "log level" configurable
showHint Hint { hintMsg, hintLevel } = case hintLevel of
Info -> Nothing
- _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
+ _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
ctxtHint = showContext ctxt
-
main :: IO ()
main = do
Right map <- loadTiledmap "example.json"
- --print $ mapJitsiUrls map
- --print $ fmap layerJitsiUrls (tiledmapLayers map)
- -- TODO: print the layer each hint originates from
- let lines = V.mapMaybe (\layer ->
- (showResult (T.pack $ layerName layer)
- . runWriterT
- . checkLayer)
- layer)
- (tiledmapLayers map)
+ -- LintWriter is a Writer transformer, so run it with runWriterT
+ let lints = fmap (runWriterT . checkLayer) (tiledmapLayers map)
+
+ -- well this is a bit awkward (but how to get layer names otherwise?)
+ let lines = V.mapMaybe thing (tiledmapLayers map)
+ where thing layer = (showResult (T.pack $ layerName layer)
+ . runWriterT . checkLayer) layer
mapM_ T.putStr lines
diff --git a/tiled-hs.cabal b/tiled-hs.cabal
index fa85e00..094d31b 100644
--- a/tiled-hs.cabal
+++ b/tiled-hs.cabal
@@ -21,16 +21,35 @@ maintainer: stuebinm@disroot.org
-- category:
extra-source-files: CHANGELOG.md
+library
+ default-language: Haskell2010
+ ghc-options: -Wall
+ hs-source-dirs: lib
+ exposed-modules:
+ LintWriter
+ Properties
+ Tiled2
+ Util
+ build-depends: base ^>=4.14.1.0,
+ aeson,
+ bytestring,
+ containers,
+ text,
+ vector,
+ transformers,
+ mtl,
+ either
+
+-- TODO: move more stuff into lib, these dependencies are silly
executable tiled-hs
main-is: Main.hs
- other-modules: Tiled2
-
- -- Modules included in this executable, other than Main.
- -- other-modules:
-
- -- LANGUAGE extensions used by modules in this package.
- -- other-extensions:
build-depends: base ^>=4.14.1.0,
- aeson, bytestring, containers, text, vector, transformers, mtl, either
+ aeson,
+ text,
+ tiled-hs,
+ transformers,
+ containers,
+ vector,
+ mtl
hs-source-dirs: src
default-language: Haskell2010
--
GitLab