a year went byHEADmain

This does many meta-things, but changes no functionality:
 - get rid of stack, and use just cabal with a stackage snapshot instead
   (why did I ever think stack was a good idea?)
 - update the stackage snapshot to something halfway recent
 - thus making builds work on nixpkgs-23.05 (current stable)
 - separating out packages into their own cabal files
 - use the GHC2021 set of extensions as default
 - very slight code changes to make things build again
 - update readme accordingly
 - stylish-haskell run

1 files changed, 0 insertions, 753 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
deleted file mode 100644
index e72bfd0..0000000
--- a/lib/Properties.hs
+++ /dev/null
@@ -1,753 +0,0 @@
-{-# 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           Data.Text           (intercalate, isPrefixOf)
-import qualified Data.Text           as T
-import           Data.Tiled          (Layer (..), Object (..), Property (..),
-                                      PropertyValue (..), Tile (..),
-                                      Tiledmap (..), Tileset (..))
-import           Data.Tiled.Abstract (HasData (..), HasName (..),
-                                      HasProperties (..), HasTypeName (..),
-                                      IsProperty (..), layerIsEmpty)
-import qualified Data.Vector         as V
-import           Util                (mkProxy, naiveEscapeHTML, prettyprint)
-
-import           Badges              (Badge (Badge),
-                                      BadgeArea (BadgePoint, BadgeRect),
-                                      BadgeToken, parseToken)
-import           Data.List           ((\\))
-import qualified Data.Set            as S
-import           Data.Text.Metrics   (damerauLevenshtein)
-import           GHC.TypeLits        (KnownSymbol)
-import           LayerData           (Collision, layerOverlaps)
-import           LintConfig          (LintConfig (..))
-import           LintWriter          (LintWriter, adjust, askContext,
-                                      askFileDepth, complain, dependsOn, forbid,
-                                      lintConfig, offersBadge, offersCWs,
-                                      offersEntrypoint, offersJitsi, suggest,
-                                      warn, zoom)
-import           Paths               (PathResult (..), RelPath (..),
-                                      getExtension, isOldStyle, parsePath)
-import           Types               (Dep (Link, Local, LocalMap, MapLink))
-import           Uris                (SubstError (..), applySubsts)
-
-
-knownMapProperties :: Vector Text
-knownMapProperties = V.fromList
-  [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script"
-  , "contentWarnings" ]
-
-knownTilesetProperties :: Vector Text
-knownTilesetProperties = V.fromList
-  [ "tilesetCopyright", "collides"]
-
-knownObjectProperties :: Vector Text
-knownObjectProperties = V.fromList
-  [ "name", "url", "getBadge", "soundRadius", "default", "persist", "openLayer"
-  , "closeLayer", "door", "bell", "openSound", "closeSound", "bellSound"
-  , "allowapi"]
-
-knownTileLayerProperites :: Vector Text
-knownTileLayerProperites = V.fromList
-  [ "jitsiRoom", "jitsiTrigger", "jitsiTriggerMessage", "jitsiWidth"
-  , "playAudio", "audioLoop", "audioVolumne"
-  , "openWebsite", "openWebsiteTrigger", "openWebsiteTriggerMessage", "openTag"
-  , "exitUrl", "startLayer", "silent", "getBadge", "zone", "name", "doorVariable"
-  , "bindVariable", "bellVariable", "code", "openTriggerMessage"
-  , "closeTriggerMessage", "autoOpen", "autoClose", "bellButtonText", "bellPopup"
-  , "enterValue", "leaveValue" ]
-
--- | Checks an entire map for "general" lints.
---
--- Note that it does /not/ check any tile layer/tileset properties;
--- these are handled seperately in CheckMap, since these lints go
--- into a different field of the output.
-checkMap :: LintWriter Tiledmap
-checkMap = do
-  tiledmap <- askContext
-  let layers = collectLayers tiledmap
-  let unlessLayer = unlessElement layers
-
-  -- test custom map properties
-  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
-  refuseDoubledNames layers
-  refuseDoubledNames (tiledmapTilesets tiledmap)
-  refuseDoubledNames (getProperties tiledmap)
-
-  -- some layers should exist
-  unlessElementNamed layers "start"
-    $ complain "The map must have one layer named \"start\"."
-  unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup")
-    $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"."
-  unlessLayer (`containsProperty` "exitUrl")
-    $ complain "The map must contain at least one layer with the property \"exitUrl\" set."
-
-  -- reject maps not suitable for workadventure
-  unless (tiledmapOrientation tiledmap == "orthogonal")
-    $ complain "The map's orientation must be set to \"orthogonal\"."
-  unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
-    $ complain "The map's tile size must be 32 by 32 pixels."
-
-  unlessHasProperty "mapCopyright"
-    $ suggest "document the map's copyright via the \"mapCopyright\" property."
-
-  unlessHasProperty "contentWarnings"
-    $ suggest "set content warnings for your map via the \"contentWarnings\" property."
-
-  -- TODO: this doesn't catch collisions with the default start layer!
-  whenLayerCollisions layers (\(Property name _) -> name == "exitUrl" || name == "startLayer")
-    $ \cols -> warn $ "collisions between entry and / or exit layers: " <> prettyprint cols
-
-  let missingMetaInfo =
-        ["mapName","mapDescription","mapLink"]
-        \\ map getName (getProperties tiledmap)
-
-  unless (null missingMetaInfo)
-   $ suggest $ "consider adding meta information to your map using the "
-                <> prettyprint missingMetaInfo <> " properties."
-
-  where
-    -- recursively find all layers (to deal with nested group layers)
-    collectLayers :: Tiledmap -> V.Vector Layer
-    collectLayers tiledmap = tiledmapLayers tiledmap <>
-      V.fromList (concatMap groupmembers (tiledmapLayers tiledmap))
-     where groupmembers :: Layer -> [Layer]
-           groupmembers layer = concatMap groupmembers layers <> layers
-            where layers = fromMaybe [] $ layerLayers layer
-
--- | Checks a single property of a map.
-checkMapProperty :: Property -> LintWriter Tiledmap
-checkMapProperty p@(Property name _) = case name of
-  "mapName" -> naiveEscapeProperty p
-  "mapDescription" -> naiveEscapeProperty p
-  "mapCopyright" -> naiveEscapeProperty p
-  "mapLink" -> pure ()
-  "contentWarnings" ->
-    unwrapString p $ \str -> do
-      offersCWs (T.splitOn "," str)
-  -- usually the linter will complain if names aren't in their
-  -- "canonical" form, but allowing that here so that multiple
-  -- scripts can be used by one map
-  _ | T.toLower name == "script" ->
-      unwrapURI (Proxy @"script") p
-       (dependsOn . Link)
-       (const $ forbid "scripts loaded from local files are disallowed")
-    | name `elem` ["jitsiRoom", "playAudio", "openWebsite"
-                  , "url", "exitUrl", "silent", "getBadge"]
-      -> complain $ "property " <> name
-                      <> " should be set on layers, not the map directly"
-    | otherwise
-      -> warnUnknown p knownMapProperties
-
-
--- | check an embedded tileset.
---
--- Important to collect dependency files
-checkTileset ::  LintWriter Tileset
-checkTileset = do
-  tileset <- askContext
-  case tilesetImage tileset of
-    Just str -> unwrapPath str (dependsOn . Local)
-    Nothing  -> complain "Tileset does not refer to an image."
-
-  refuseDoubledNames (getProperties tileset)
-
-  -- reject tilesets unsuitable for workadventure
-  unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32)
-    $ complain "Tilesets must have tile size 32x32."
-
-  when (tilesetImageheight tileset > 4096 || tilesetImagewidth tileset > 4096)
-    $ warn "Tilesets should not be larger than 4096x4096 pixels in total."
-
-  when (isJust (tilesetSource tileset))
-    $ complain "Tilesets must be embedded and cannot be loaded from external files."
-
-  unlessHasProperty "tilesetCopyright"
-    $ forbid "property \"tilesetCopyright\" for tilesets must be set."
-
-  when (isJust (tilesetFileName tileset))
-    $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)."
-
-  -- check properties of individual tiles
-  tiles' <- forM (tilesetTiles tileset) $ mapM $ \tile -> do
-    mapM_ (checkTileProperty tile) (getProperties tile)
-    zoom (const tileset) (const tile) $ mapM_ (checkTileThing True) (getProperties tile)
-
-  adjust (\t -> t { tilesetTiles = tiles' })
-
-  -- check individual tileset properties
-  mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset)
-
-  case tilesetTiles tileset of
-    Nothing -> pure ()
-    Just tiles -> ifDoubledThings tileId
-      -- can't set properties on the same tile twice
-        (\tile -> complain $ "cannot set properties on the \
-                  \tile with the id" <> show (tileId tile) <> "twice.")
-        tiles
-
-  where
-    checkTilesetProperty :: Property -> LintWriter Tileset
-    checkTilesetProperty p@(Property name _value) = case name of
-      "tilesetCopyright" -> naiveEscapeProperty p
-      "collides"         -> warn "property \"collides\" should be set on individual tiles, not the tileset"
-      _                  -> warn $ "unknown tileset property " <> prettyprint name
-
-    checkTileProperty :: Tile -> Property -> LintWriter Tileset
-    checkTileProperty tile p@(Property name _) =
-      case name of
-        "collides" -> isBool p
-        -- named tiles are needed for scripting and do not hurt otherwise
-        "name" -> isString p
-        "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \
-                                   \not an individual tile."
-        _ -> warnUnknown' ("unknown tile property "
-                <> prettyprint name <> " in tile with global id "
-                <> show (tileId tile)) p knownTilesetProperties
-
-
--- | collect lints on a single map layer
-checkLayer :: LintWriter Layer
-checkLayer = do
-  layer <- askContext
-
-  refuseDoubledNames (getProperties layer)
-
-  when (isJust (layerImage layer))
-    $ complain "imagelayer are not supported."
-
-  case layerType layer of
-    "tilelayer" -> mapM_ (checkTileThing False) (getProperties layer)
-    "group" -> pure ()
-    "objectgroup" -> do
-
-      -- check object properties
-      objs <- forM (layerObjects layer) $ mapM $ \object -> do
-        -- this is a confusing constant zoom ...
-        zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object)
-      adjust (\l -> l { layerObjects = objs })
-
-      -- all objects which don't define badges
-      let publicObjects = map (V.filter (not . (`containsProperty` "getBadge"))) objs
-
-      -- remove badges from output
-      adjust $ \l -> l { layerObjects = publicObjects
-                       , layerProperties = Nothing }
-
-      -- check layer properties
-      forM_ (getProperties layer) checkObjectGroupProperty
-
-      unless (layerName layer == "floorLayer") $
-        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 (isNothing (layerLayers layer))
-    $ warn "Empty group layers are pointless."
-    else when (isJust (layerLayers layer))
-    $ complain "Layer is not of type \"group\", but has sublayers."
-
-checkObjectProperty :: Property -> LintWriter Object
-checkObjectProperty p@(Property name _) = do
- obj <- askContext
- case name of
-  "url" -> do
-    unwrapURI (Proxy @"website") p
-      (dependsOn . Link)
-      (const $ forbid "using \"url\" to open local html files is disallowed.")
-    unless (objectType obj == "website")
-      $ complain "\"url\" can only be set for objects of type \"website\""
-  "getBadge" -> do
-    when (1 /= length (getProperties obj))
-      $ warn "Objects with the property \"getBadge\" set are removed at runtime, \
-             \and any other properties set on them will be gone."
-    unwrapString p $ \str ->
-      unwrapBadgeToken str $ \token -> do
-        case obj of
-          ObjectPolygon {} -> complain "polygons are not supported."
-          ObjectPolyline {} -> complain "polylines are not supported."
-          ObjectText {} -> complain "cannot use texts to define badge areas."
-          ObjectRectangle {..} ->
-            if objectEllipse == Just True
-            then complain "ellipses are not supported."
-            else offersBadge
-            $ Badge token $ case (objectWidth, objectHeight) of
-              (Just w, Just h) | w /= 0 && h /= 0 ->
-                 BadgeRect objectX objectY w h
-              _ -> BadgePoint objectX objectY
-  "soundRadius" -> do
-    isIntInRange 0 maxBound p
-    unless (containsProperty obj "door" || containsProperty obj "bell")
-      $ complain "property \"soundRadius\" can only be set on objects with \
-                 \either property \"bell\" or \"door\" also set."
-
-  _ | name `elem` [ "default", "persist" ] ->
-        suggestPropertyName' "door"
-    -- extended API for doors and bells
-    | name `elem` [ "openLayer", "closeLayer" ] -> do
-        isString p
-        suggestPropertyName' "door"
-        -- extended API for doors and bells
-    | name `elem` ["door", "bell"] -> do
-        isBool p
-        unless (objectType obj == "variable") $
-          complain $ "the "<>prettyprint name<>" property should only be set \
-                     \on objects of type \"variable\""
-        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
-        isString p
-        unwrapURI (Proxy @"audio") p
-          (dependsOn . Link)
-          (dependsOn . Local)
-        case name of
-          "bellSound" ->
-            suggestPropertyName' "bell"
-          "closeSound" | containsProperty obj  "openSound" ->
-            suggestPropertyName' "door"
-          _ -> do
-            suggestPropertyName' "door"
-            suggestPropertyName "soundRadius"
-              "set \"soundRadius\" to limit the door sound to a certain area."
-    | T.toLower name == "allowapi"
-      -> forbidProperty name
-    | otherwise ->
-        warnUnknown p knownObjectProperties
-
--- | Checks a single (custom) property of an objectgroup layer
-checkObjectGroupProperty :: Property -> LintWriter Layer
-checkObjectGroupProperty (Property name _) = case name of
-  "getBadge" -> warn "the property \"getBadge\" must be set on individual objects, \
-                       \not the object layer."
-  _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
-
-
-
--- | Checks a single (custom) property. Since almost all properties
--- can be set on tile layer AND on tilesets, this function aims to
--- be generic over both — the only difference is that tilesets can't
--- have exits, which is specified by the sole boolean argument
-checkTileThing
-  :: (HasProperties a, HasName a, HasData a)
-  => Bool -> Property -> LintWriter a
-checkTileThing removeExits p@(Property name _value) = case name of
-    "jitsiRoom" -> do
-      uselessEmptyLayer
-      -- members of an assembly should automatically get
-      -- admin rights in jitsi (prepending "assembly-" here
-      -- to avoid namespace clashes with other admins)
-      lintConfig configAssemblyTag
-        >>= setProperty "jitsiRoomAdminTag"
-        . ("assembly-" <>)
-      unwrapString p $ \jitsiRoom -> do
-        suggestProperty $ Property "jitsiTrigger" "onaction"
-
-        -- prevents namespace clashes for jitsi room names
-        if not ("shared" `isPrefixOf` jitsiRoom) then do
-          assemblyname <- lintConfig configAssemblyTag
-          setProperty "jitsiRoom" (assemblyname <> "-" <> jitsiRoom)
-          offersJitsi (assemblyname <> "-" <> jitsiRoom)
-        else
-          offersJitsi jitsiRoom
-    "jitsiTrigger" -> do
-      isString p
-      unlessHasProperty "jitsiTriggerMessage"
-       $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite \
-                 \the default \"press SPACE to enter in jitsi meet room\"."
-      requireProperty "jitsiRoom"
-    "jitsiTriggerMessage" -> do
-      isString p
-      requireProperty "jitsiTrigger"
-    "jitsiWidth" ->
-      isIntInRange 0 100 p
-    "playAudio" -> do
-      uselessEmptyLayer
-      unwrapURI (Proxy @"audio") p
-        (dependsOn . Link)
-        (dependsOn . Local)
-    "audioLoop" -> do
-      isBool p
-      requireProperty "playAudio"
-    "playAudioLoop" ->
-      deprecatedUseInstead "audioLoop"
-    "audioVolume" -> do
-      isOrdInRange unwrapFloat 0 1 p
-      requireProperty "playAudio"
-    "openWebsiteTrigger" -> do
-      isString p
-      requireOneOf ["openWebsite", "openTab"]
-      unlessHasProperty "openWebsiteTriggerMessage"
-        $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to \
-                  \overwrite the default \"press SPACE to open Website\"."
-    "openWebsiteTriggerMessage" -> do
-      isString p
-      requireProperty "openWebsiteTrigger"
-    "url" -> complain "the property \"url\" defining embedded iframes must be \
-                      \set on an object in an objectgroup layer."
-    "exitUrl" -> if not removeExits
-      then do
-        forbidEmptyLayer
-        unwrapURI (Proxy @"map") p
-          (\link -> do
-              assemblyslug <- lintConfig configAssemblyTag
-              eventslug <- lintConfig configEventSlug
-              case T.stripPrefix ("/@/"<>eventslug<>"/"<>assemblyslug<>"/") link of
-                Nothing -> do
-                  dependsOn (MapLink link)
-                  setProperty "exitUrl" link
-                Just path -> case parsePath path of
-                  OkRelPath (Path _ p frag) -> do
-                    up <- askFileDepth
-                    dependsOn (LocalMap (Path up p frag))
-                    setProperty "exitUrl" path
-                    warn "You should use relative links to your own assembly instead \
-                         \of world://-style links (I've tried to adjust them \
-                         \automatically for now)."
-                  _ -> complain "There's a path I don't understand here. Perhaps try \
-                                \asking a human?"
-          )
-          ( \path ->
-            let ext = getExtension path in
-            if | isOldStyle path -> do
-                   eventslug <- lintConfig configEventSlug
-                   complain $
-                     "Old-Style inter-repository links (using {<placeholder>}) \
-                     \cannot be used at "<>eventslug<>"; please use world:// \
-                     \instead (see the howto)."
-               | ext == "tmx" ->
-                   complain "Cannot use .tmx map format; use Tiled's json export instead."
-               | ext /= "json" ->
-                   complain "All exit links must link to .json files."
-               | otherwise -> dependsOn . LocalMap $ path
-          )
-      else do
-        warn "exitUrls in Tilesets are not unsupported; if you want to \
-             \add an exit, please use a tile layer instead."
-    "exitSceneUrl" ->
-      deprecatedUseInstead "exitUrl"
-    "exitInstance" ->
-      deprecatedUseInstead "exitUrl"
-    "startLayer" -> do
-      forbidEmptyLayer
-      layer <- askContext
-      unwrapBool p $ \case
-        True  -> offersEntrypoint $ getName layer
-        False -> warn "property \"startLayer\" is useless if set to false."
-    "silent" -> do
-      isBool p
-      uselessEmptyLayer
-    "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \
-                           \ layer; it does not work on tile layers."
-
-    -- extended API stuff
-    "zone" -> do
-      isString p
-      uselessEmptyLayer
-    -- name on tile layer unsupported
-    "name" -> isUnsupported
-    _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ]
-        -> do { isString p; requireProperty "zone" }
-      | name `elem` [ "code", "openTriggerMessage", "closeTriggerMessage"]
-        -> do { isString p; requireProperty "doorVariable" }
-      | name `elem` [ "autoOpen", "autoClose"]
-        -> do { isBool p; requireProperty "doorVariable" }
-      | name `elem` [ "bellButtonText", "bellPopup" ]
-        -> do { isString p; requireProperty "bellVariable" }
-      | name `elem` [ "enterValue", "leaveValue" ]
-        -> do { isString p; requireProperty "bindVariable" }
-      | T.toLower name `elem` [ "jitsiurl", "jitsiconfig", "jitsiclientconfig"
-                              , "jitsiroomadmintag", "jitsiinterfaceconfig"
-                              , "openwebsitepolicy", "allowapi" ]
-        -> forbidProperty name
-      | name `elem` [ "openWebsite", "openTab" ] -> do
-          uselessEmptyLayer
-          suggestProperty $ Property "openWebsiteTrigger" "onaction"
-
-          properties <- askContext <&> getProperties
-          let isScript = any (\(Property name _) ->
-                                T.toLower name == "openwebsiteallowapi")
-                          properties
-          if isScript
-            then unwrapURI (Proxy @"script") p
-              (dependsOn . Link)
-              (const $ forbid "accessing local html files is disallowed")
-            else unwrapURI (Proxy @"website") p
-              (dependsOn . Link)
-              (const $ forbid "accessing local html files is disallowed.")
-      | otherwise ->
-        when (not removeExits || name `notElem` [ "collides", "name", "tilesetCopyright" ]) $ do
-          warnUnknown p knownTileLayerProperites
-    where
-      requireProperty req = propertyRequiredBy req name
-      requireOneOf names = do
-        context <- askContext
-        unless (any (containsProperty context) names)
-          $ complain $ "property " <> prettyprint name <> " requires one of "
-                    <> prettyprint names
-
-      isUnsupported = warn $ "property " <> name <> " is not (yet) supported by walint."
-      deprecatedUseInstead instead =
-        warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead."
-
-      -- | this property can only be used on a layer that contains
-      -- | at least one tile
-      forbidEmptyLayer = when removeExits $ do
-        layer <- askContext
-        when (layerIsEmpty layer)
-          $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.")
-
-      -- | this layer is allowed, but also useless on a layer that contains no tiles
-      uselessEmptyLayer = when removeExits $ do
-        layer <- askContext
-        when (layerIsEmpty layer)
-          $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.")
-
-
--- | refuse doubled names in everything that's somehow a collection of names
-refuseDoubledNames
-  :: (Container t, HasName (Element t), HasTypeName (Element t))
-  => t
-  -> LintWriter b
-refuseDoubledNames = ifDoubledThings getName
-  (\thing -> complain $ "cannot use " <> typeName (mkProxy thing) <> " name "
-                     <> getName thing <> " multiple times.")
-
--- | do `ifDouble` if any element of `things` occurs more than once under
--- the function `f`
-ifDoubledThings
-  :: (Eq a, Ord a, Container t)
-  => (Element t -> a)
-  -> (Element t -> LintWriter b)
-  -> t
-  -> LintWriter b
-ifDoubledThings f ifDouble things = foldr folding base things (mempty, mempty)
-  where
-    folding thing cont (seen, twice)
-      | f thing `elem` seen && f thing `notElem` twice = do
-        ifDouble thing
-        cont (seen, S.insert (f thing) twice)
-      | otherwise =
-        cont (S.insert (f thing) seen, twice)
-    base _ = pure ()
-
--- | we don't know this property; give suggestions for ones with similar names
-warnUnknown' :: Text -> Property -> Vector Text -> LintWriter a
-warnUnknown' msg (Property name _) knowns =
-  if snd minDist < 4
-  then warn (msg <> ", perhaps you meant " <> prettyprint (fst minDist) <> "?")
-  else warn msg
-  where dists = V.map (\n -> (n, damerauLevenshtein name n)) knowns
-        minDist = V.minimumBy (\(_,a) (_,b) -> compare a b) dists
-
-warnUnknown :: Property -> Vector Text -> LintWriter a
-warnUnknown p@(Property name _) =
-  warnUnknown' ("unknown property " <> prettyprint name) p
-
----- General functions ----
-
-unlessElement
-  :: Container f
-  => f
-  -> (Element f -> Bool)
-  -> LintWriter b
-  -> LintWriter b
-unlessElement things op = unless (any op things)
-
-unlessElementNamed :: (HasName (Element f), Container f)
-  => f -> Text -> LintWriter b -> LintWriter b
-unlessElementNamed things name =
-  unlessElement things ((==) name . getName)
-
-unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a
-unlessHasProperty name linter =
-  askContext >>= \ctxt ->
-    unlessElementNamed (getProperties ctxt) name linter
-
--- | does this layer have the given property?
-containsProperty :: HasProperties a => a -> Text -> Bool
-containsProperty thing name = any
-  (\(Property name' _) -> name' == name) (getProperties thing)
-
--- | should the layers fulfilling the given predicate collide, then perform andthen.
-whenLayerCollisions
-  :: V.Vector Layer
-  -> (Property -> Bool)
-  -> (Set Collision -> LintWriter a)
-  -> LintWriter a
-whenLayerCollisions layers f andthen = do
-  let collisions = layerOverlaps . V.filter (any f . getProperties) $ layers
-  unless (null collisions)
-    $ andthen collisions
-
------ Functions with concrete lint messages -----
-
--- | this property is forbidden and should not be used
-forbidProperty :: HasProperties a => Text -> LintWriter a
-forbidProperty name =
-  forbid $ "property " <> prettyprint name <> " is disallowed."
-
-propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a
-propertyRequiredBy req by =
-  unlessHasProperty req
-  $ complain $ "property " <> prettyprint req <>
-               " is required by property " <> prettyprint by <> "."
-
--- | suggest some value for another property if that property does not
--- also already exist
-suggestProperty :: HasProperties a => Property -> LintWriter a
-suggestProperty p@(Property name value) =
-  suggestProperty' p $ "add property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"."
-
-suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a
-suggestProperty' (Property name _) msg =
-  unlessHasProperty name (suggest msg)
-
-suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a
-suggestPropertyName name msg =
-  unlessHasProperty name (suggest msg)
-
-suggestPropertyName' :: HasProperties a => Text -> LintWriter a
-suggestPropertyName' name = suggestPropertyName name
-  $ "consider setting property " <> prettyprint name <> "."
-
----- Functions for adjusting the context -----
-
-
--- | set a property, overwriting whatever value it had previously
-setProperty :: (IsProperty prop, HasProperties ctxt)
-  => Text -> prop -> LintWriter ctxt
-setProperty name value = adjust $ \ctxt ->
-  flip adjustProperties ctxt
-  $ \ps -> Just $ Property name (asProperty value) : filter sameName ps
-  where sameName (Property name' _) = name /= name'
-
-naiveEscapeProperty :: HasProperties a =>  Property -> LintWriter a
-naiveEscapeProperty prop@(Property name _) =
-  unwrapString prop (setProperty name . naiveEscapeHTML)
-
----- "unwrappers" checking that a property has some type, then do something ----
-
--- | asserts that this property is a string, and unwraps it
-unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
-unwrapString (Property name value) f = case value of
-  StrProp str -> f str
-  _ -> complain $ "type error: property "
-               <> prettyprint name <> " should be of type string."
-
-
--- | asserts that this property is a boolean, and unwraps it
-unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a
-unwrapBool (Property name value) f = case value of
-  BoolProp b -> f b
-  _ -> complain $ "type error: property " <> prettyprint name
-               <> " should be of type bool."
-
-unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a
-unwrapInt (Property name value) f = case value of
-  IntProp float -> f float
-  _ -> complain $ "type error: property " <> prettyprint name
-               <> " should be of type int."
-
-unwrapFloat :: Property -> (Float -> LintWriter a) -> LintWriter a
-unwrapFloat (Property name value) f = case value of
-  FloatProp float -> f float
-  _ -> complain $ "type error: property " <> prettyprint name
-               <> " should be of type float."
-
-unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
-unwrapPath str f = case parsePath str of
-  OkRelPath p@(Path up _ _) -> do
-    depth <- askFileDepth
-    if up <= depth
-      then f p
-      else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository."
-  NotAPath -> complain $ "path \"" <> str <> "\" is invalid."
-  AbsolutePath -> forbid "absolute paths are disallowed. Use world:// instead."
-  UnderscoreMapLink -> forbid "map links using /_/ are disallowed. Use world:// instead."
-  AtMapLink -> forbid "map links using /@/ are disallowed. Use world:// instead."
-  PathVarsDisallowed -> forbid "extended API variables are not allowed in asset paths."
-
-unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a
-unwrapBadgeToken str f = case parseToken str of
-  Just a  -> f a
-  Nothing -> complain "invalid badge token."
-
-
--- | unwraps a link, giving two  cases:
---   - the link might be an (allowed) remote URI
---   - the link might be relative to this map (i.e. just a filepath)
-unwrapURI :: (KnownSymbol s, HasProperties a)
-  => Proxy s
-  -> Property
-  -> (Text -> LintWriter a)
-  -> (RelPath -> LintWriter a)
-  -> LintWriter a
-unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
-  subst <- lintConfig configUriSchemas
-  case applySubsts sym subst link of
-    Right uri -> do
-      setProperty name uri
-      f uri
-    Left NotALink -> unwrapPath link g
-    Left err -> do
-      isLobby <- lintConfig configAssemblyTag <&> (== "lobby")
-
-      (if isLobby then warn else complain) $ case err of
-        DomainIsBlocked domains -> link <> " is a blocked site; links in this \
-                                   \context may link to " <> prettyprint domains
-        IsBlocked -> link <> " is blocked."
-        DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \
-                                     \please make sure it is spelled correctly."
-        SchemaDoesNotExist schema ->
-          "the URI schema " <> schema <> "// cannot be used."
-        WrongScope schema allowed ->
-          "the URI schema " <> schema <> "// cannot be used in property \
-          \\"" <> name <> "\"; allowed "
-          <> (if length allowed == 1 then "is " else "are ")
-          <> intercalate ", " (map (<> "//") allowed) <> "."
-        VarsDisallowed -> "extended API links are disallowed in links"
-
-
-
--- | just asserts that this is a string
-isString :: Property -> LintWriter a
-isString = flip unwrapString (const $ pure ())
-
--- | just asserts that this is a boolean
-isBool :: Property -> LintWriter a
-isBool = flip unwrapBool (const $ pure ())
-
-isIntInRange :: Int -> Int -> Property -> LintWriter b
-isIntInRange = isOrdInRange @Int unwrapInt
-
-isOrdInRange :: (Ord a, Show a)
-  => (Property -> (a -> LintWriter b) -> LintWriter b)
-  -> a
-  -> a
-  -> Property
-  -> LintWriter b
-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 "
-               <> show l <> " and " <> show r<>"."