1 files changed, 36 insertions, 23 deletions

diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index b6361b5..23267a8 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -1,27 +1,30 @@
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns         #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Module that contains the high-level checking functions
-module CheckMap (loadAndLintMap, MapResult(..)) where
+module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where
+
+import           Universum
 
 import           Data.Aeson       (ToJSON (toJSON))
 import qualified Data.Aeson       as A
 import           Data.Aeson.Types ((.=))
-import           Data.Functor     ((<&>))
-import           Data.Map         (Map, toList)
 import qualified Data.Map         as M
-import           Data.Text        (Text)
 import qualified Data.Text        as T
 import qualified Data.Vector      as V
-import           GHC.Generics     (Generic)
 
 
 import           Badges           (Badge)
-import           Control.DeepSeq  (NFData)
 import           LintConfig       (LintConfig (configAssemblyTag), LintConfig')
 import           LintWriter       (LintResult, invertLintResult,
                                    resultToAdjusted, resultToBadges,
@@ -39,9 +42,14 @@ import           Types            (Dep (MapLink),
 import           Util             (PrettyPrint (prettyprint), prettyprint)
 
 
+data ResultKind = Full | Shrunk
+
+type family Optional (a :: ResultKind) (b :: *) where
+  Optional Full b = b
+  Optional Shrunk b = ()
 
 -- | What this linter produces: lints for a single map
-data MapResult = MapResult
+data MapResult (kind :: ResultKind) = MapResult
   { mapresultLayer    :: Map Hint [Text]
   -- ^ lints that occurred in one or more layers
   , mapresultTileset  :: Map Hint [Text]
@@ -50,16 +58,18 @@ data MapResult = MapResult
   -- ^ (external and local) dependencies of this map
   , mapresultProvides :: [Text]
   -- ^ entrypoints provided by this map (needed for dependency checking)
-  , mapresultAdjusted :: Maybe Tiledmap
+  , mapresultAdjusted :: Optional kind (Maybe Tiledmap)
   -- ^ the loaded map, with adjustments by the linter
   , mapresultBadges   :: [Badge]
   -- ^ badges that can be found on this map
   , mapresultGeneral  :: [Hint]
   -- ^ general-purpose lints that didn't fit anywhere else
-  } deriving (Generic, NFData)
+  } deriving (Generic)
 
+instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a)
 
-instance Eq MapResult where
+
+instance Eq (MapResult a) where
   a == b =
     mapresultLayer a == mapresultLayer b &&
     mapresultTileset a == mapresultTileset b &&
@@ -67,7 +77,7 @@ instance Eq MapResult where
     mapresultGeneral a == mapresultGeneral b
 
 
-instance ToJSON MapResult where
+instance ToJSON (MapResult a) where
   toJSON res = A.object
     [ "layer" .= CollectedLints (mapresultLayer res)
     , "tileset" .= CollectedLints (mapresultTileset res)
@@ -85,13 +95,16 @@ instance ToJSON CollectedLints where
             else cs
 
 
+shrinkMapResult :: MapResult Full -> MapResult Shrunk
+shrinkMapResult !res = res { mapresultAdjusted = () }
+
 -- | this module's raison d'être
 -- Lints the map at `path`, and limits local links to at most `depth`
 -- layers upwards in the file hierarchy
-loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
+loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full))
 loadAndLintMap config path depth = loadTiledmap path <&> (\case
     DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty
-        [ Hint Fatal . T.pack $
+        [ Hint Fatal . toText $
           path <> ": Fatal: " <> err
         ])
     IOErr _ -> Nothing
@@ -99,7 +112,7 @@ loadAndLintMap config path depth = loadTiledmap path <&> (\case
       Just (runLinter (takeFileName path == "main.json") config waMap depth))
 
 -- | lint a loaded map
-runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult
+runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full
 runLinter isMain config tiledmap depth = MapResult
   { mapresultLayer = invertThing layer
   , mapresultTileset = invertThing tileset
@@ -184,7 +197,7 @@ checkLayerRec config depth layers =
 
 
 -- human-readable lint output, e.g. for consoles
-instance PrettyPrint (Level, MapResult) where
+instance PrettyPrint (Level, MapResult a) where
   prettyprint (_, mapResult) = if complete == ""
     then "  all good!\n" else complete
     where
@@ -195,7 +208,7 @@ instance PrettyPrint (Level, MapResult) where
       -- | pretty-prints a collection of Hints, printing each
       --   Hint only once, then a list of its occurences line-wrapped
       --   to fit onto a decent-sized terminal
-      prettyLints :: (MapResult -> Map Hint [Text]) -> [Text]
+      prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text]
       prettyLints getter = fmap
         (\(h, cs) -> prettyprint h
           <> "\n    (in "
@@ -207,7 +220,7 @@ instance PrettyPrint (Level, MapResult) where
                         )
              (0, "") cs)
           <> ")\n")
-        (toList . getter $ mapResult)
+        (M.toList . getter $ mapResult)
 
       prettyGeneral :: [Text]
       prettyGeneral = map