moving lots of code around

(also renaming things now that concepts seem a bit clearer)

1 files changed, 26 insertions, 161 deletions

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