From 4caded904c54d1cd85bf54239517e93650a404f5 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 11 Oct 2022 13:39:16 +0200 Subject: 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: -- cgit v1.2.3