From 4caded904c54d1cd85bf54239517e93650a404f5 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Tue, 11 Oct 2022 13:39:16 +0200
Subject: [PATCH] use template haskell aeson, not generics
this has been bothering me for MONTHS, and it compiles faster now. also fixed some warnings
---
lib/CheckDir.hs | 1 -
lib/CheckMap.hs | 2 +-
lib/Dirgraph.hs | 2 +-
lib/Util.hs | 4 +--
package.yaml | 1 +
server/HtmlOrphans.hs | 8 ++---
server/Server.hs | 6 ++--
server/Worker.hs | 3 +-
tiled/Data/Tiled.hs | 65 ++++++++----------------------------
tiled/Data/Tiled/Abstract.hs | 6 ++--
tiled/Data/Tiled/TH.hs | 15 +++++++++
walint.cabal | 1 +
12 files changed, 45 insertions(+), 69 deletions(-)
create mode 100644 tiled/Data/Tiled/TH.hs
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index eaf9aee..8bf33cf 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -35,7 +35,6 @@ import qualified Data.Text as T
import Data.Tiled (Tiledmap)
import Dirgraph (graphToDot, invertGraph, resultToGraph,
takeSubGraph, unreachableFrom)
-import GHC.Generics (Generic)
import LintConfig (LintConfig', configMaxLintLevel)
import Paths (normalise, normaliseWithFrag)
import System.Directory.Extra (doesFileExist)
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 73464a8..279a2c1 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -44,7 +44,7 @@ import Util (PrettyPrint (prettyprint), prettyprint)
data ResultKind = Full | Shrunk
-type family Optional (a :: ResultKind) (b :: *) where
+type family Optional (a :: ResultKind) (b :: Type) where
Optional Full b = b
Optional Shrunk b = ()
diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs
index 3fe1ce6..57852d0 100644
--- a/lib/Dirgraph.hs
+++ b/lib/Dirgraph.hs
@@ -8,7 +8,7 @@ module Dirgraph where
import Universum
import CheckMap (MapResult (mapresultDepends))
-import Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey)
+import Data.Map.Strict (mapMaybeWithKey, mapWithKey)
import qualified Data.Map.Strict as M
import Data.Set ((\\))
import qualified Data.Set as S
diff --git a/lib/Util.hs b/lib/Util.hs
index 93060aa..5ec1b12 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -15,8 +15,8 @@ import Universum
import Data.Aeson as Aeson
import qualified Data.Set as S
import qualified Data.Text as T
-import Data.Tiled (Layer (layerData), PropertyValue (..),
- Tileset (tilesetName), layerName, mkTiledId)
+import Data.Tiled (Layer, PropertyValue (..),
+ Tileset (tilesetName), layerName)
-- | helper function to create proxies
mkProxy :: a -> Proxy a
diff --git a/package.yaml b/package.yaml
index e2f6ea6..ceefc73 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,6 +23,7 @@ internal-libraries:
exposed-modules:
- Data.Tiled
- Data.Tiled.Abstract
+ - Data.Tiled.TH
library:
source-dirs: 'lib'
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index bf06d4c..594d55f 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -26,7 +26,7 @@ import Handlers (AdminOverview (..))
import Lucid (HtmlT, ToHtml)
import Lucid.Base (ToHtml (toHtml))
import Lucid.Html5 (a_, body_, button_, class_, code_, disabled_,
- div_, em_, h1_, h2_, h3_, h4_, h5_, head_,
+ div_, em_, h1_, h2_, h3_, h4_, head_,
href_, html_, id_, li_, link_, main_,
onclick_, p_, rel_, script_, span_, src_,
title_, type_, ul_)
@@ -114,9 +114,9 @@ instance ToHtml AdminOverview where
if null jobs then em_ "(nothing yet)"
else flip M.foldMapWithKey jobs $ \sha1 (ref, status, _lastvalid) -> li_ $ do
case status of
- Pending _ -> badge Info "pending"
- (Linted res rev _) -> toHtml $ maximumLintLevel res
- (Failed _) -> badge Error "system error"
+ Pending _ -> badge Info "pending"
+ (Linted res _ _) -> toHtml $ maximumLintLevel res
+ (Failed _) -> badge Error "system error"
" "; a_ [href_ ("/status/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ do
mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
diff --git a/server/Server.hs b/server/Server.hs
index 2c16834..84b4ae8 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -219,9 +219,9 @@ data JobStatus
instance TS.Show JobStatus where
show = \case
- Pending _ -> "Pending"
- Linted res rev _ -> "Linted result"
- Failed err -> "Failed with: " <> show err
+ Pending _ -> "Pending"
+ Linted _ _ _ -> "Linted result"
+ Failed err -> "Failed with: " <> show err
-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
diff --git a/server/Worker.hs b/server/Worker.hs
index d85c44f..ba0fb41 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -16,14 +16,13 @@ import CheckDir (recursiveCheckDir,
import Control.Concurrent.Async (async, link)
import Control.Concurrent.STM (writeTChan)
import Control.Concurrent.STM.TQueue
-import Control.Exception (IOException, handle, throw)
+import Control.Exception (IOException, handle)
import Control.Monad.Logger (logError, logErrorN, logInfoN,
runStdoutLoggingT)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Fmt ((+|), (|+))
-import GHC.IO.Exception (ioException)
import LintConfig (stuffConfig)
import Server (Config, JobStatus (..),
Org (..),
diff --git a/tiled/Data/Tiled.hs b/tiled/Data/Tiled.hs
index 3e6c737..4372a97 100644
--- a/tiled/Data/Tiled.hs
+++ b/tiled/Data/Tiled.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -9,6 +8,9 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+
-- | This module provides Haskell types for Tiled's JSON exports, which you can
-- read about at http://doc.mapeditor.org/en/latest/reference/json-map-format/.
@@ -23,27 +25,15 @@ import Universum
import Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import Data.Aeson.Types (typeMismatch)
-import Data.Char (toLower)
+import Data.Aeson.TH (deriveJSON)
import Control.Exception (IOException)
+import Data.Tiled.TH
--- | options for Aeson's generic encoding and parsing functions
-aesonOptions :: Int -> Options
-aesonOptions l = defaultOptions
- { omitNothingFields = True
- , rejectUnknownFields = True
- -- can't be bothered to do a nicer prefix strip
- , fieldLabelModifier = drop l . map toLower
- , sumEncoding = UntaggedValue
- }
-
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
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 newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData)
@@ -109,11 +99,6 @@ data Point = Point { pointX :: Double
, pointY :: Double
} deriving (Eq, Generic, Show, NFData)
-instance FromJSON Point where
- parseJSON = genericParseJSON (aesonOptions 5)
-instance ToJSON Point where
- toJSON = genericToJSON (aesonOptions 5)
-
-- | all kinds of objects that can occur in object layers, even
-- | those that we don't want to allow.
@@ -177,15 +162,6 @@ data Object = ObjectRectangle
} deriving (Eq, Generic, Show, NFData)
-
-
-
-instance FromJSON Object where
- parseJSON = genericParseJSON (aesonOptions 6)
-instance ToJSON Object where
- toJSON = genericToJSON (aesonOptions 6)
-
-
data Layer = Layer { layerWidth :: Maybe Double
-- ^ Column count. Same as map width for fixed-size maps.
, layerHeight :: Maybe Double
@@ -224,11 +200,6 @@ data Layer = Layer { layerWidth :: Maybe Double
, layerColor :: Maybe Color
} deriving (Eq, Generic, Show, NFData)
-instance FromJSON Layer where
- parseJSON = genericParseJSON (aesonOptions 5)
-instance ToJSON Layer where
- toJSON = genericToJSON (aesonOptions 5)
-
data Terrain = Terrain { terrainName :: String
-- ^ Name of terrain
@@ -275,13 +246,6 @@ data Tile = Tile { tileId :: Int
, tileTerrain :: Maybe [Int]
} deriving (Eq, Generic, Show, NFData)
-instance FromJSON Tile where
- parseJSON = genericParseJSON (aesonOptions 4)
-
-instance ToJSON Tile where
- toJSON = genericToJSON (aesonOptions 4)
-
-
data Tileset = Tileset { tilesetFirstgid :: GlobalId
-- ^ GID corresponding to the first tile in the set
@@ -332,13 +296,6 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
deriving newtype (Show, Eq, FromJSON)
-instance FromJSON Tileset where
- parseJSON = genericParseJSON (aesonOptions 7)
-
-instance ToJSON Tileset where
- toJSON = genericToJSON (aesonOptions 7)
-
-
-- | The full monty.
data Tiledmap = Tiledmap { tiledmapVersion :: Value
-- ^ The JSON format version
@@ -376,10 +333,14 @@ data Tiledmap = Tiledmap { tiledmapVersion :: Value
, tiledmapEditorsettings :: Maybe Value
} deriving (Eq, Generic, Show, NFData)
-instance FromJSON Tiledmap where
- parseJSON = genericParseJSON (aesonOptions 8)
-instance ToJSON Tiledmap where
- toJSON = genericToJSON (aesonOptions 8)
+
+$(deriveJSON (aesonOptions 5) ''Point)
+$(deriveJSON (aesonOptions 6) ''Object)
+$(deriveJSON (aesonOptions 5) ''Layer)
+$(deriveJSON (aesonOptions 4) ''Tile)
+$(deriveJSON (aesonOptions 7) ''Tileset)
+$(deriveJSON (aesonOptions 8) ''Tiledmap)
+
-- | Load a Tiled map from the given 'FilePath'.
loadTiledmap :: FilePath -> IO (Either String Tiledmap)
diff --git a/tiled/Data/Tiled/Abstract.hs b/tiled/Data/Tiled/Abstract.hs
index 89c40b4..29e9022 100644
--- a/tiled/Data/Tiled/Abstract.hs
+++ b/tiled/Data/Tiled/Abstract.hs
@@ -4,9 +4,9 @@ module Data.Tiled.Abstract where
import Universum
-import Data.Tiled (GlobalId, Layer (..), Object (..), Property (..),
+import Data.Tiled (GlobalId (..), Layer (..), Object (..), Property (..),
PropertyValue (..), Tile (..), Tiledmap (..),
- Tileset (..), mkTiledId)
+ Tileset (..))
import qualified Data.Vector as V
class HasProperties a where
@@ -81,4 +81,4 @@ instance IsProperty Text where
layerIsEmpty :: HasData a => a -> Bool
layerIsEmpty layer = case getData layer of
Nothing -> True
- Just d -> all ((==) $ mkTiledId 0) d
+ Just d -> all ((==) $ GlobalId 0) d
diff --git a/tiled/Data/Tiled/TH.hs b/tiled/Data/Tiled/TH.hs
new file mode 100644
index 0000000..e0ad0e8
--- /dev/null
+++ b/tiled/Data/Tiled/TH.hs
@@ -0,0 +1,15 @@
+module Data.Tiled.TH where
+
+import Universum
+
+import qualified Data.Aeson.TH as TH
+import Data.Char (toLower)
+
+aesonOptions :: Int -> TH.Options
+aesonOptions l = TH.defaultOptions
+ { TH.omitNothingFields = True
+ , TH.rejectUnknownFields = True
+ -- can't be bothered to do a nicer prefix strip
+ , TH.fieldLabelModifier = drop l . map toLower
+ , TH.sumEncoding = TH.UntaggedValue
+ }
diff --git a/walint.cabal b/walint.cabal
index c380de3..9cfb5ee 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -62,6 +62,7 @@ library tiled
exposed-modules:
Data.Tiled
Data.Tiled.Abstract
+ Data.Tiled.TH
other-modules:
Paths_walint
autogen-modules:
--
GitLab