summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Badges.hs17
-rw-r--r--lib/CheckDir.hs13
-rw-r--r--lib/CheckMap.hs3
-rw-r--r--lib/Paths.hs6
-rw-r--r--lib/Tiled.hs29
-rw-r--r--lib/Types.hs7
6 files changed, 45 insertions, 30 deletions
diff --git a/lib/Badges.hs b/lib/Badges.hs
index 5da2643..c1a17b3 100644
--- a/lib/Badges.hs
+++ b/lib/Badges.hs
@@ -1,11 +1,14 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
-- | module defining Badge types and utility functions
module Badges where
+import Control.DeepSeq (NFData)
import Data.Aeson (Options (fieldLabelModifier, sumEncoding),
SumEncoding (UntaggedValue), ToJSON (toJSON),
defaultOptions, genericToJSON, (.=))
@@ -27,10 +30,10 @@ data BadgeArea =
, areaWidth :: Double
, areaHeight :: Double
}
- deriving (Ord, Eq, Generic, Show)
+ deriving (Ord, Eq, Generic, Show, NFData)
newtype BadgeToken = BadgeToken Text
- deriving (Eq, Ord, Show)
+ deriving newtype (Eq, Ord, Show, NFData)
instance ToJSON BadgeArea where
toJSON = genericToJSON defaultOptions
@@ -46,7 +49,7 @@ parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text)
else Nothing
data Badge = Badge BadgeToken BadgeArea
- deriving (Ord, Eq, Generic, Show)
+ deriving (Ord, Eq, Generic, Show, NFData)
instance ToJSON Badge where
toJSON (Badge token area) = A.object $ case area of
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index b9a3a31..652d58f 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -10,6 +10,7 @@
module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal) where
import CheckMap (MapResult (..), loadAndLintMap)
+import Control.DeepSeq (NFData)
import Control.Monad (void)
import Control.Monad.Extra (mapMaybeM)
import Data.Aeson (ToJSON, (.=))
@@ -36,6 +37,7 @@ import Types (Dep (Local, LocalMap), Hint (Hint),
Level (..), hintLevel)
import Util (PrettyPrint (prettyprint))
+
-- based on the startling observation that Data.Map has lower complexity
-- for difference than Data.Set, but the same complexity for fromList
type Set a = Map a ()
@@ -52,19 +54,20 @@ data DirResult = DirResult
-- ^ all dependencies to things outside this repository
, dirresultMissingAssets :: [MissingAsset]
-- ^ entrypoints of maps which are referred to but missing
- , dirresultGraph :: Dot ()
- } deriving (Generic)
+ , dirresultGraph :: Text
+ } deriving (Generic, NFData)
data MissingDep = MissingDep
{ depFatal :: Maybe Bool
, entrypoint :: Text
, neededBy :: [FilePath]
- } deriving (Generic, ToJSON)
+ } deriving (Generic, ToJSON, NFData)
-- | Missing assets are the same thing as missing dependencies,
-- but should not be confused (and also serialise differently
-- to json)
newtype MissingAsset = MissingAsset MissingDep
+ deriving (Generic, NFData)
-- | given this config, should the result be considered to have failed?
resultIsFatal :: LintConfig' -> DirResult -> Bool
@@ -97,7 +100,7 @@ instance ToJSON DirResult where
[ "missingDeps" .= dirresultDeps res
, "missingAssets" .= dirresultMissingAssets res
, "mapLints" .= dirresultMaps res
- , "exitGraph" .= showDot (dirresultGraph res)
+ , "exitGraph" .= dirresultGraph res
]
, "severity" .= maximumLintLevel res
, "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ])
@@ -163,7 +166,7 @@ recursiveCheckDir config prefix root = do
pure $ DirResult { dirresultDeps = missingDeps root maps'
, dirresultMissingAssets = mAssets
, dirresultMaps = maps'
- , dirresultGraph = graphToDot exitGraph
+ , dirresultGraph = T.pack $ showDot $ graphToDot exitGraph
}
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index cfa4b6e..9dd0530 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -21,6 +21,7 @@ import GHC.Generics (Generic)
import Badges (Badge)
+import Control.DeepSeq (NFData)
import LintConfig (LintConfig')
import LintWriter (LintResult, invertLintResult,
resultToAdjusted, resultToBadges,
@@ -55,7 +56,7 @@ data MapResult = MapResult
-- ^ badges that can be found on this map
, mapresultGeneral :: [Hint]
-- ^ general-purpose lints that didn't fit anywhere else
- } deriving (Generic)
+ } deriving (Generic, NFData)
instance ToJSON MapResult where
toJSON res = A.object
diff --git a/lib/Paths.hs b/lib/Paths.hs
index b9b0d50..15dc66b 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -5,8 +7,10 @@
-- I just hope you are running this on some kind of Unix
module Paths where
+import Control.DeepSeq (NFData)
import Data.Text (Text, isPrefixOf)
import qualified Data.Text as T
+import GHC.Generics (Generic)
import System.FilePath (splitPath)
import System.FilePath.Posix ((</>))
import Text.Regex.TDFA
@@ -16,7 +20,7 @@ import Util (PrettyPrint (prettyprint))
-- a path without any . or .. in it. Also possibly a
-- fragment, mostly for map links.
data RelPath = Path Int Text (Maybe Text)
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, NFData, Generic)
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
index bca5f1a..ab7d4f4 100644
--- a/lib/Tiled.hs
+++ b/lib/Tiled.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -15,6 +17,7 @@
-- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/
module Tiled where
+import Control.DeepSeq (NFData)
import Control.Exception (try)
import Control.Exception.Base (SomeException)
import Data.Aeson hiding (Object)
@@ -43,26 +46,26 @@ aesonOptions l = defaultOptions
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
- deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+ deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData)
mkTiledId :: Int -> GlobalId
mkTiledId i = GlobalId { unGlobalId = i }
-- | A locally indexed identifier.
newtype LocalId = LocalId { unLocalId :: Int }
- deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+ deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData)
type Color = Text
-- | A custom tiled property, which just has a name and a value.
data Property = Property Text PropertyValue
- deriving (Eq, Generic, Show)
+ deriving (Eq, Generic, Show, NFData)
-- | The value of a custom tiled property.
-- It is strongly typed via a tag in the json representation,
-- and needs a custom ToJSON and FromJSON instance because of that.
data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int | FloatProp Float
- deriving (Eq, Generic, Show)
+ deriving (Eq, Generic, Show, NFData)
instance IsString PropertyValue where
fromString s = StrProp (T.pack s)
@@ -111,7 +114,7 @@ instance ToJSON Property where
data Point = Point { pointX :: Double
, pointY :: Double
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Point where
parseJSON = genericParseJSON (aesonOptions 5)
@@ -178,7 +181,7 @@ data Object = ObjectRectangle
, objectHeight :: Maybe Double
, objectEllipse :: Maybe Bool
, objectType :: Text
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
@@ -226,7 +229,7 @@ data Layer = Layer { layerWidth :: Maybe Double
, layerStartX :: Maybe Int
, layerStartY :: Maybe Int
, layerColor :: Maybe Color
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Layer where
parseJSON = genericParseJSON (aesonOptions 5)
@@ -238,7 +241,7 @@ data Terrain = Terrain { terrainName :: String
-- ^ Name of terrain
, terrainTile :: LocalId
-- ^ Local ID of tile representing terrain
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Terrain where
parseJSON (A.Object o) = Terrain <$> o .: "name"
@@ -254,7 +257,7 @@ instance ToJSON Terrain where
data Frame = Frame { frameDuration :: Int
, frameTileId :: LocalId
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Frame where
parseJSON (A.Object o) = Frame <$> o .: "duration"
@@ -277,7 +280,7 @@ data Tile = Tile { tileId :: Int
, tileProbability :: Maybe Float
, tileType :: Maybe Text
, tileTerrain :: Maybe [Int]
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Tile where
parseJSON = genericParseJSON (aesonOptions 4)
@@ -331,10 +334,10 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId
, tilesetWangsets :: Maybe Value
, tilesetType :: Maybe Text
, tilesetFileName :: Maybe Text
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
- deriving (Show, Eq, Generic, FromJSON)
+ deriving newtype (Show, Eq, FromJSON)
instance FromJSON Tileset where
parseJSON = genericParseJSON (aesonOptions 7)
@@ -378,7 +381,7 @@ data Tiledmap = Tiledmap { tiledmapVersion :: Value
, tiledmapStaggerindex :: Maybe String
, tiledmapType :: String
, tiledmapEditorsettings :: Maybe Value
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Tiledmap where
parseJSON = genericParseJSON (aesonOptions 8)
diff --git a/lib/Types.hs b/lib/Types.hs
index 588c8ea..43a5131 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -24,6 +24,7 @@ import Data.Text (Text)
import GHC.Generics (Generic)
import Badges (Badge)
+import Control.DeepSeq (NFData)
import qualified Data.Aeson as A
import Data.Maybe (mapMaybe)
import Paths (RelPath)
@@ -37,7 +38,7 @@ import WithCli.Pure (Argument (argumentType, parseArgumen
-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
- deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON)
+ deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData)
instance Argument Level where
argumentType Proxy = "Lint Level"
@@ -60,12 +61,12 @@ data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
deriving (Ord, Eq, Generic, ToJSONKey)
data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
- deriving (Generic, Ord, Eq)
+ deriving (Generic, Ord, Eq, NFData)
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text
- } deriving (Generic, Ord, Eq)
+ } deriving (Generic, Ord, Eq, NFData)
-- | shorter constructor (called hint because (a) older name and
-- (b) lint also exists and is monadic)