switch to universum prelude

also don't keep adjusted maps around if not necessary

1 files changed, 36 insertions, 39 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
index 9cde1ec..eb31403 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -1,18 +1,21 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE MultiWayIf        #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE MultiWayIf          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
 
 -- | Contains checks for custom ties of the map json
 module Properties (checkMap, checkTileset, checkLayer) where
 
+import           Universum         hiding (intercalate, isPrefixOf)
 
-import           Control.Monad     (forM, forM_, unless, when)
-import           Data.Text         (Text, intercalate, isInfixOf, isPrefixOf)
+import           Data.Text         (intercalate, isInfixOf, isPrefixOf)
 import qualified Data.Text         as T
 import qualified Data.Vector       as V
 import           Tiled             (Layer (..), Object (..), Property (..),
@@ -27,14 +30,9 @@ import           Util              (mkProxy, naiveEscapeHTML, prettyprint,
 import           Badges            (Badge (Badge),
                                     BadgeArea (BadgePoint, BadgeRect),
                                     BadgeToken, parseToken)
-import           Data.Data         (Proxy (Proxy))
-import           Data.Functor      ((<&>))
 import           Data.List         ((\\))
-import           Data.Maybe        (fromMaybe, isJust)
-import           Data.Set          (Set)
 import qualified Data.Set          as S
 import           Data.Text.Metrics (damerauLevenshtein)
-import           Data.Vector       (Vector)
 import           GHC.TypeLits      (KnownSymbol)
 import           LayerData         (Collision, layerOverlaps)
 import           LintConfig        (LintConfig (..))
@@ -86,7 +84,7 @@ checkMap = do
   let unlessLayer = unlessElement layers
 
   -- test custom map properties
-  mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap)
+  mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap)
 
   -- can't have these with the rest of layer/tileset lints since they're
   -- not specific to any one of them
@@ -144,10 +142,10 @@ checkMapProperty p@(Property name _) = case name of
   -- scripts can be used by one map
   _ | T.toLower name == "script" ->
       unwrapString p $ \str ->
-        unless ((checkIsRc3Url str) &&
-                (not $ "/../" `isInfixOf` str) &&
-                (not $ "%" `isInfixOf` str) &&
-                (not $ "@" `isInfixOf` str))
+        unless (checkIsRc3Url str &&
+                not ( "/../" `isInfixOf` str) &&
+                not ( "%" `isInfixOf` str) &&
+                not ( "@" `isInfixOf` str))
         $ forbid "only scripts hosted on static.rc3.world are allowed."
     | name `elem` ["jitsiRoom", "bbbRoom", "playAudio", "openWebsite"
                   , "url", "exitUrl", "silent", "getBadge"]
@@ -192,14 +190,14 @@ checkTileset = do
   adjust (\t -> t { tilesetTiles = tiles' })
 
   -- check individual tileset properties
-  mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset)
+  mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset)
 
   case tilesetTiles tileset of
     Nothing -> pure ()
     Just tiles -> refuseDoubledThings tileId
       -- can't set properties on the same tile twice
         (\tile -> complain $ "cannot set properties on the \
-                  \tile with the id" <> showText (tileId tile) <> "twice.")
+                  \tile with the id" <> show (tileId tile) <> "twice.")
         tiles
 
   where
@@ -258,14 +256,14 @@ checkLayer = do
       forM_ (getProperties layer) checkObjectGroupProperty
 
       unless (layerName layer == "floorLayer") $
-        when (null (layerObjects layer) || layerObjects layer == Just mempty) $
+        when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $
           warn "objectgroup layer (which aren't the floorLayer) \
                \are useless if they are empty."
 
     ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."
 
   if layerType layer == "group"
-    then when (null (layerLayers layer))
+    then when (isNothing (layerLayers layer))
     $ warn "Empty group layers are pointless."
     else when (isJust (layerLayers layer))
     $ complain "Layer is not of type \"group\", but has sublayers."
@@ -316,7 +314,7 @@ checkObjectProperty p@(Property name _) = do
         unless (objectType obj == "variable") $
           complain $ "the "<>prettyprint name<>" property should only be set \
                      \on objects of type \"variable\""
-        when (null (objectName obj) || objectName obj == Just mempty) $
+        when (isNothing (objectName obj) || objectName obj == Just mempty) $
           complain $ "Objects with the property "<>prettyprint name<>" set must \
                      \be named."
     | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do
@@ -525,7 +523,7 @@ checkTileThing removeExits p@(Property name _value) = case name of
       requireProperty req = propertyRequiredBy req name
       requireOneOf names = do
         context <- askContext
-        when (all (not . containsProperty context) names)
+        unless (any (containsProperty context) names)
           $ complain $ "property " <> prettyprint name <> " requires one of "
                     <> prettyprint names
 
@@ -549,9 +547,8 @@ checkTileThing removeExits p@(Property name _value) = case name of
 
 -- | refuse doubled names in everything that's somehow a collection of names
 refuseDoubledNames
-  :: (HasName a, HasTypeName a)
-  => (Foldable t, Functor t)
-  => t a
+  :: (Container t, HasName (Element t), HasTypeName (Element t))
+  => t
   -> LintWriter b
 refuseDoubledNames = refuseDoubledThings
   getName
@@ -560,10 +557,10 @@ refuseDoubledNames = refuseDoubledThings
 
 -- | refuse doubled things via equality on after applying some function
 refuseDoubledThings
-  :: (Eq a, Ord a, Foldable t, Functor t)
-  => (a' -> a)
-  -> (a' -> LintWriter b)
-  -> t a'
+  :: (Eq a, Ord a, Container t)
+  => (Element t -> a)
+  -> (Element t -> LintWriter b)
+  -> t
   -> LintWriter b
 refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempty)
   where
@@ -591,15 +588,15 @@ warnUnknown p@(Property name _) =
 ---- General functions ----
 
 unlessElement
-  :: Foldable f
-  => f a
-  -> (a -> Bool)
+  :: Container f
+  => f
+  -> (Element f -> Bool)
   -> LintWriter b
   -> LintWriter b
 unlessElement things op = unless (any op things)
 
-unlessElementNamed :: (HasName a, Foldable f)
-  => f a -> Text -> LintWriter b -> LintWriter b
+unlessElementNamed :: (HasName (Element f), Container f)
+  => f -> Text -> LintWriter b -> LintWriter b
 unlessElementNamed things name =
   unlessElement things ((==) name . getName)
 
@@ -777,4 +774,4 @@ isOrdInRange :: (Ord a, Show a)
 isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int ->
   if l < int && int < r then pure ()
   else complain $ "Property " <> prettyprint name <> " should be between "
-               <> showText l <> " and " <> showText r<>"."
+               <> show l <> " and " <> show r<>"."