use template haskell aeson, not generics

this has been bothering me for MONTHS, and it compiles faster now. also fixed some warnings

12 files changed, 45 insertions, 69 deletions

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: