From 35566bf15f43c355bdc72d62841a850a90c8ba03 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 16 Sep 2021 02:27:26 +0200 Subject: moving lots of code around (also renaming things now that concepts seem a bit clearer) --- src/Main.hs | 187 +++++++++--------------------------------------------------- 1 file changed, 26 insertions(+), 161 deletions(-) (limited to 'src/Main.hs') 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 -- cgit v1.2.3