From 0787b24786a329dae5f25c1cd2916ce962471f1d Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 5 Sep 2021 19:10:30 +0200 Subject: simple proof of concept Lots of monads everywhere, hurray! (unfortunately, workadventure maps don't quite form a category; they lack composition …) Credits: - the example.json file is by TabascoEye (with some modifications for testing purposes) - the Tiled module is forked from aeson-tiled on hackage, since that package didn't handle custom layer properties correctly --- src/Main.hs | 191 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 191 insertions(+) create mode 100644 src/Main.hs (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..c5787db --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,191 @@ +{-# 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 Tiled2 + +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" + forbidProperty "jitsiUrl" + -- TODO: not sure if we should really disallow these entirely + forbidProperty "jitsiConfig" + forbidProperty "jitsiClientConfig" + forbidProperty "jitsiRoomAdminTag" + "jitsiTrigger" -> requireProperty "jitsiRoom" + "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" + -- 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 = + mapM_ (checkProperty layer) (layerProperties layer) + +-- TODO: possibly expand this to something more detailed? +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 ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt +showResult _ (Right (a, [])) = Nothing +showResult ctxt (Right (a, hints)) = Just $ showHints hints + where + showHints hints = T.concat (mapMaybe showHint hints) + -- TODO: make the "log level" configurable + showHint Hint { hintMsg, hintLevel } = case hintLevel of + Info -> Nothing + _ -> 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) + mapM_ T.putStr lines -- cgit v1.2.3