diff options
| author | stuebinm | 2022-02-18 18:09:23 +0100 | 
|---|---|---|
| committer | stuebinm | 2022-03-19 19:54:48 +0100 | 
| commit | 52bf0fa6dace596a4bd5b4e4229fbb9704fbf443 (patch) | |
| tree | 971604d125e2faba93db8845224a2d43ee645935 /lib | |
| parent | 53fb449b008e9b6aed9877b9d33f4026e454e0f9 (diff) | |
switch to universum prelude
also don't keep adjusted maps around if not necessary
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Badges.hs | 5 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 102 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 59 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 43 | ||||
| -rw-r--r-- | lib/KindLinter.hs | 7 | ||||
| -rw-r--r-- | lib/LayerData.hs | 12 | ||||
| -rw-r--r-- | lib/LintConfig.hs | 32 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 26 | ||||
| -rw-r--r-- | lib/Paths.hs | 31 | ||||
| -rw-r--r-- | lib/Properties.hs | 75 | ||||
| -rw-r--r-- | lib/Tiled.hs | 26 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 16 | ||||
| -rw-r--r-- | lib/Types.hs | 15 | ||||
| -rw-r--r-- | lib/Uris.hs | 44 | ||||
| -rw-r--r-- | lib/Util.hs | 19 | ||||
| -rw-r--r-- | lib/WriteRepo.hs | 16 | 
16 files changed, 254 insertions, 274 deletions
| diff --git a/lib/Badges.hs b/lib/Badges.hs index c1a17b3..d6afc43 100644 --- a/lib/Badges.hs +++ b/lib/Badges.hs @@ -8,14 +8,13 @@  -- | module defining Badge types and utility functions  module Badges where -import           Control.DeepSeq (NFData) +import           Universum +  import           Data.Aeson      (Options (fieldLabelModifier, sumEncoding),                                    SumEncoding (UntaggedValue), ToJSON (toJSON),                                    defaultOptions, genericToJSON, (.=))  import qualified Data.Aeson      as A  import           Data.Char       (toLower) -import           Data.Text       (Text) -import           GHC.Generics    (Generic)  import           Text.Regex.TDFA ((=~)) diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 1aeb5e3..a19a412 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -1,29 +1,35 @@ -{-# LANGUAGE DeriveAnyClass    #-} -{-# LANGUAGE DeriveGeneric     #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase        #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections     #-} -{-# LANGUAGE TypeFamilies      #-} +{-# LANGUAGE BangPatterns         #-} +{-# LANGUAGE DataKinds            #-} +{-# LANGUAGE DeriveAnyClass       #-} +{-# LANGUAGE DeriveGeneric        #-} +{-# LANGUAGE FlexibleContexts     #-} +{-# LANGUAGE FlexibleInstances    #-} +{-# LANGUAGE LambdaCase           #-} +{-# LANGUAGE OverloadedStrings    #-} +{-# LANGUAGE TupleSections        #-} +{-# LANGUAGE TypeFamilies         #-} +{-# LANGUAGE UndecidableInstances #-}  -- | Module that contains high-level checking for an entire directory -module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal)  where - -import           CheckMap               (MapResult (..), loadAndLintMap) -import           Control.DeepSeq        (NFData) -import           Control.Monad          (void) +module CheckDir ( maximumLintLevel +                , recursiveCheckDir +                , DirResult (..) +                , MissingAsset(..) +                , MissingDep(..) +                , resultIsFatal +                ,shrinkDirResult)  where + +import           Universum              hiding (Set) + +import           CheckMap               (MapResult (..), Optional, +                                         ResultKind (..), loadAndLintMap, +                                         shrinkMapResult)  import           Control.Monad.Extra    (mapMaybeM)  import           Data.Aeson             (ToJSON, (.=))  import qualified Data.Aeson             as A -import           Data.Bifunctor         (first) -import           Data.Foldable          (fold) -import           Data.Functor           ((<&>)) -import           Data.List              (partition) -import           Data.Map               (Map, elems, keys)  import qualified Data.Map               as M  import           Data.Map.Strict        (mapKeys, mapWithKey, (\\)) -import           Data.Maybe             (isJust, mapMaybe) -import           Data.Text              (Text, isInfixOf) +import           Data.Text              (isInfixOf)  import qualified Data.Text              as T  import           Dirgraph               (graphToDot, invertGraph, resultToGraph,                                           takeSubGraph, unreachableFrom) @@ -34,7 +40,8 @@ import           System.Directory.Extra (doesFileExist)  import           System.FilePath        (splitPath, (</>))  import qualified System.FilePath        as FP  import           System.FilePath.Posix  (takeDirectory) -import           Text.Dot               (Dot, showDot) +import           Text.Dot               (showDot) +import           Tiled                  (Tiledmap)  import           Types                  (Dep (Local, LocalMap), Hint (Hint),                                           Level (..), hintLevel)  import           Util                   (PrettyPrint (prettyprint), ellipsis) @@ -49,15 +56,18 @@ listFromSet :: Set a -> [a]  listFromSet = map fst . M.toList  -- | Result of linting an entire directory / repository -data DirResult = DirResult -  { dirresultMaps          :: Map FilePath MapResult +data DirResult (complete :: ResultKind) = DirResult +  { dirresultMaps          :: Map FilePath (MapResult complete)    -- ^ all maps of this respository, by (local) filepath    , dirresultDeps          :: [MissingDep]    -- ^ all dependencies to things outside this repository    , dirresultMissingAssets :: [MissingAsset]    -- ^ entrypoints of maps which are referred to but missing    , dirresultGraph         :: Text -  } deriving (Generic, NFData) +  } deriving (Generic) + +instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) +  data MissingDep = MissingDep    { depFatal   :: Maybe Bool @@ -71,8 +81,14 @@ data MissingDep = MissingDep  newtype MissingAsset = MissingAsset MissingDep    deriving (Generic, NFData) + +-- | "shrink" the result by throwing the adjusted tiledmaps away +shrinkDirResult :: DirResult Full -> DirResult Shrunk +shrinkDirResult !res = +  res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } +  -- | given this config, should the result be considered to have failed? -resultIsFatal :: LintConfig' -> DirResult -> Bool +resultIsFatal :: LintConfig' -> DirResult Full -> Bool  resultIsFatal config res =    not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res)))    || maximumLintLevel res > configMaxLintLevel config @@ -80,11 +96,11 @@ resultIsFatal config res =  -- | maximum lint level that was observed anywhere in any map.  -- note that it really does go through all lints, so don't  -- call it too often -maximumLintLevel :: DirResult -> Level +maximumLintLevel :: DirResult a -> Level  maximumLintLevel res    | not (null (dirresultMissingAssets res)) = Fatal    | otherwise = -    (\t -> if null t then Info else maximum t) +    (maybe Info maximum . nonEmpty)      . map hintLevel      . concatMap (\map -> keys (mapresultLayer map)                    <> keys (mapresultTileset map) @@ -96,7 +112,7 @@ maximumLintLevel res -instance ToJSON DirResult where +instance ToJSON (DirResult a) where    toJSON res = A.object [      "result" .=  A.object        [ "missingDeps" .= dirresultDeps res @@ -127,7 +143,7 @@ instance ToJSON MissingAsset where      ] -instance PrettyPrint (Level, DirResult) where +instance PrettyPrint (Level, DirResult a) where    prettyprint (level, res) = prettyMapLints <> prettyMissingDeps      where        prettyMissingDeps = if not (null (dirresultDeps res)) @@ -135,9 +151,9 @@ instance PrettyPrint (Level, DirResult) where          else ""        prettyMapLints = T.concat          (map prettyLint $ M.toList $ dirresultMaps res) -      prettyLint :: (FilePath, MapResult) -> Text +      prettyLint :: (FilePath, MapResult a) -> Text        prettyLint (p, lint) = -        "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint) +        "\nin " <> toText p <> ":\n" <> prettyprint (level, lint)  instance PrettyPrint MissingDep where    prettyprint (MissingDep _ f n) = @@ -145,7 +161,7 @@ instance PrettyPrint MissingDep where      <> prettyDependents <> "\n"      where        prettyDependents = -        T.intercalate "," $ map T.pack n +        T.intercalate "," $ map toText n  -- | check an entire repository @@ -155,7 +171,7 @@ recursiveCheckDir    -- ^ the repository's prefix (i.e. path to its directory)    -> FilePath    -- ^ the repository's entrypoint (filename of a map, from the repo's root) -  -> IO DirResult +  -> IO (DirResult Full)  recursiveCheckDir config prefix root = do    maps <- recursiveCheckDir' config prefix [root] mempty @@ -170,7 +186,7 @@ recursiveCheckDir config prefix root = do    let maps' = flip mapWithKey maps $ \path res ->          if path `elem` nowayback          then res { mapresultGeneral = -                   Hint Warning ("Cannot go back to " <> T.pack root <> " from this map.") +                   Hint Warning ("Cannot go back to " <> toText root <> " from this map.")                     : mapresultGeneral res                   }          else res @@ -180,7 +196,7 @@ recursiveCheckDir config prefix root = do                     , dirresultMissingAssets = mAssets                     , dirresultMaps = maps'                     , dirresultGraph = -                     T.pack +                     toText                       . showDot                       . graphToDot                       . takeSubGraph 7 root @@ -190,9 +206,9 @@ recursiveCheckDir config prefix root = do  -- | Given a (partially) completed DirResult, check which local  -- maps are referenced but do not actually exist. -missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep] +missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep]  missingDeps entrypoint maps = -  let simple = M.insert (T.pack entrypoint) [] used \\ M.union defined trivial +  let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial    in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple    where      -- which maps are linked somewhere? @@ -202,19 +218,19 @@ missingDeps entrypoint maps =        (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)        maps        where extractLocalDeps prefix = \case -              LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name +              LocalMap name -> Just $ toText $ normaliseWithFrag prefix name                _             -> Nothing      -- which are defined using startLayer?      defined :: Set Text      defined = setFromList        $ M.foldMapWithKey -      (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v) +      (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v)        maps      -- each map file is an entrypoint by itself -    trivial = mapKeys T.pack $ void maps +    trivial = mapKeys toText $ void maps  -- | Checks if all assets referenced in the result actually exist as files -missingAssets :: FilePath -> Map FilePath MapResult -> IO [MissingAsset] +missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset]  missingAssets prefix maps =    mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold    where missingOfMap (path, mapres) = mapMaybeM @@ -222,7 +238,7 @@ missingAssets prefix maps =                     let asset = normalise (takeDirectory path) relpath                     in doesFileExist (prefix </> asset) <&>                       \case True  -> Nothing -                           False -> Just $ MissingDep Nothing (T.pack asset) [path] +                           False -> Just $ MissingDep Nothing (toText asset) [path]                   _ -> pure Nothing)            (mapresultDepends mapres) @@ -234,9 +250,9 @@ recursiveCheckDir'    -- ^ the repo's directory    -> [FilePath]    -- ^ paths of maps yet to check -  -> Map FilePath MapResult +  -> Map FilePath (MapResult Full)    -- ^ accumulator for map results -  -> IO (Map FilePath MapResult) +  -> IO (Map FilePath (MapResult Full))  recursiveCheckDir' config prefix paths acc = do    -- lint all maps in paths. The double fmap skips maps which cause IO errors 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 diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs index 8d4a5f2..fe9dc96 100644 --- a/lib/Dirgraph.hs +++ b/lib/Dirgraph.hs @@ -1,26 +1,21 @@ -{-# LANGUAGE LambdaCase    #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase       #-} +{-# LANGUAGE TupleSections    #-}  -- | Simple directed graphs, for dependency checking  module Dirgraph where +import           Universum -import           CheckMap              (MapResult (mapresultDepends)) -import           Control.Monad         (forM_, unless) -import           Data.Functor          ((<&>)) -import           Data.Map.Strict       (Map, mapMaybeWithKey, mapWithKey, -                                        traverseMaybeWithKey, traverseWithKey) -import qualified Data.Map.Strict       as M -import           Data.Maybe            (fromMaybe) -import           Data.Set              (Set, (\\)) -import qualified Data.Set              as S -import           Paths                 (normalise) -import qualified System.FilePath       as FP -import           System.FilePath.Posix (takeDirectory, (</>)) -import           Text.Dot              (Dot, (.->.)) -import qualified Text.Dot              as D -import           Types                 (Dep (LocalMap)) -import           Witherable            (mapMaybe) +import           CheckMap        (MapResult (mapresultDepends)) +import           Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey) +import qualified Data.Map.Strict as M +import           Data.Set        ((\\)) +import qualified Data.Set        as S +import           Paths           (normalise) +import           Text.Dot        (Dot, (.->.)) +import qualified Text.Dot        as D +import           Types           (Dep (LocalMap))  -- | a simple directed graph  type Graph a = Map a (Set a) @@ -29,18 +24,16 @@ nodes :: Graph a -> Set a  nodes = M.keysSet  -- | simple directed graph of exits -resultToGraph :: Map FilePath MapResult -> Graph FilePath -resultToGraph = mapWithKey (\p r -> S.fromList -                             . mapMaybe (onlyLocalMaps (takeDirectory p)) -                             . mapresultDepends $ r) -  where onlyLocalMaps prefix = \case -          LocalMap path -> Just (FP.normalise (prefix </> normalise "" path)) +resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath +resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) +  where onlyLocalMaps = \case +          LocalMap path -> Just (normalise "" path)            _             -> Nothing  -- | invert edges of a directed graph  invertGraph :: (Eq a, Ord a) => Graph a -> Graph a  invertGraph graph = mapWithKey collectFroms graph -  where collectFroms to _ = S.fromList . M.elems . mapMaybeWithKey (select to) $ graph +  where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph          select to from elems = if to `elem` elems then Just from else Nothing  -- | all nodes reachable from some entrypoint diff --git a/lib/KindLinter.hs b/lib/KindLinter.hs index ccca1db..a876a8f 100644 --- a/lib/KindLinter.hs +++ b/lib/KindLinter.hs @@ -13,11 +13,10 @@  module KindLinter where +import           Universum +  import           Data.HList -import           Data.Kind       (Type) -import           Data.Map.Strict -import           Data.Void       (Void) -import           GHC.TypeLits    (KnownSymbol, Symbol, symbolVal) +import           GHC.TypeLits (KnownSymbol, Symbol, symbolVal)  func :: a -> HList [Int, String] diff --git a/lib/LayerData.hs b/lib/LayerData.hs index 1a07982..6956c92 100644 --- a/lib/LayerData.hs +++ b/lib/LayerData.hs @@ -2,12 +2,12 @@  module LayerData where +import           Universum         hiding (maximum, uncons)  import           Control.Monad.Zip (mzipWith) -import           Data.Set          (Set, insert) -import           Data.Text         (Text) -import qualified Data.Text         as T -import           Data.Vector       (Vector, uncons) +import           Data.Set          (insert) +import           Data.Vector       (maximum, uncons) +import qualified Text.Show         as TS  import           Tiled             (GlobalId (unGlobalId), Layer (..))  import           Util              (PrettyPrint (..)) @@ -22,8 +22,8 @@ instance Eq Collision where  instance PrettyPrint Collision where    prettyprint (Collision (a,b)) = a <> " and " <> b -instance Show Collision where -  show c = T.unpack $ prettyprint c +instance TS.Show Collision where +  show c = toString $ prettyprint c  -- | Finds pairwise tile collisions between the given layers.  layerOverlaps :: Vector Layer -> Set Collision diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs index e71638b..11a8122 100644 --- a/lib/LintConfig.hs +++ b/lib/LintConfig.hs @@ -12,21 +12,21 @@  -- | Module that deals with handling config options  module LintConfig (LintConfig(..), LintConfig', patchConfig) where -import           Control.Monad.Identity (Identity) -import           Data.Aeson             (FromJSON (parseJSON), Options (..), -                                         defaultOptions, eitherDecode) -import           Data.Aeson.Types       (genericParseJSON) -import qualified Data.ByteString.Char8  as C8 -import qualified Data.ByteString.Lazy   as LB -import qualified Data.Map.Strict        as M -import           Data.Text              (Text) -import           GHC.Generics           (Generic (Rep, from, to), K1 (..), -                                         M1 (..), (:*:) (..)) -import           Types                  (Level) -import           Uris                   (SchemaSet, -                                         Substitution (DomainSubstitution)) -import           WithCli                (Proxy (..)) -import           WithCli.Pure           (Argument (argumentType, parseArgument)) +import           Universum +import qualified Universum.Unsafe      as Unsafe + +import           Data.Aeson            (FromJSON (parseJSON), Options (..), +                                        defaultOptions, eitherDecode) +import           Data.Aeson.Types      (genericParseJSON) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy  as LB +import qualified Data.Map.Strict       as M +import           GHC.Generics          (Generic (Rep, from, to), K1 (..), +                                        M1 (..), (:*:) (..)) +import           Types                 (Level) +import           Uris                  (SchemaSet, +                                        Substitution (DomainSubstitution)) +import           WithCli.Pure          (Argument (argumentType, parseArgument))  type family HKD f a where    HKD Identity a = a @@ -138,7 +138,7 @@ patchConfig config p = config'            DomainSubstitution (M.fromList generated) scope            where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config'          scope = (\(DomainSubstitution _ s) -> s) -         . snd . head +         . snd . Unsafe.head           . filter ((==) "world" . fst)           $ configUriSchemas config' diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 2b891c3..d0c6c4e 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -42,21 +42,15 @@ module LintWriter    , adjust    ) where -import           Data.Text                  (Text) - -import           Badges                     (Badge) -import           Control.Monad.State        (MonadState (put), StateT, modify) -import           Control.Monad.Trans.Reader (Reader, asks, runReader) -import           Control.Monad.Trans.State  (get, runStateT) -import           Control.Monad.Writer.Lazy  (lift) -import           Data.Bifunctor             (Bifunctor (second)) -import           Data.Map                   (Map, fromListWith) -import           Data.Maybe                 (mapMaybe) -import qualified Data.Set                   as S -import           LintConfig                 (LintConfig') -import           TiledAbstract              (HasName (getName)) -import           Types                      (Dep, Hint, Level (..), Lint (..), -                                             hint, lintsToHints) +import           Universum + + +import           Badges        (Badge) +import           Data.Map      (fromListWith) +import           LintConfig    (LintConfig') +import           TiledAbstract (HasName (getName)) +import           Types         (Dep, Hint, Level (..), Lint (..), hint, +                                lintsToHints)  -- | A monad modelling the main linter features @@ -109,7 +103,7 @@ zoom embed extract operation = do  -- | "invert" a linter's result, grouping lints by their messages  invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text]  invertLintResult (LinterState (lints, ctxt)) = -  fmap (S.toList . S.fromList . fmap getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints +  fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints  resultToDeps :: LintResult a -> [Dep]  resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints diff --git a/lib/Paths.hs b/lib/Paths.hs index 15dc66b..f4dc3ed 100644 --- a/lib/Paths.hs +++ b/lib/Paths.hs @@ -7,15 +7,16 @@  -- 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           Universum +import qualified Universum.Unsafe      as Unsafe +  import qualified Data.Text             as T -import           GHC.Generics          (Generic)  import           System.FilePath       (splitPath)  import           System.FilePath.Posix ((</>))  import           Text.Regex.TDFA  import           Util                  (PrettyPrint (prettyprint)) +  -- | a normalised path: a number of "upwards" steps, and  -- a path without any . or .. in it. Also possibly a  -- fragment, mostly for map links. @@ -36,9 +37,9 @@ parsePath :: Text -> PathResult  parsePath text =    if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed       | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) -     | "/_/" `isPrefixOf` text ->  UnderscoreMapLink -     | "/@/" `isPrefixOf` text ->  AtMapLink -     | "/" `isPrefixOf` text ->  AbsolutePath +     | "/_/" `T.isPrefixOf` text ->  UnderscoreMapLink +     | "/@/" `T.isPrefixOf` text ->  AtMapLink +     | "/" `T.isPrefixOf` text ->  AbsolutePath       | otherwise ->  NotAPath    where      (_, prefix, rest, _) = @@ -47,10 +48,10 @@ parsePath text =      up = length . filter (".." ==) . T.splitOn  "/" $ prefix      parts = T.splitOn "#" rest      -- `head` is unsafe, but splitOn will always produce lists with at least one element -    path = head parts -    fragment = if length parts >= 2 -      then Just $ T.concat $ tail parts -      else Nothing +    path = Unsafe.head parts +    fragment = case nonEmpty parts of +      Nothing -> Nothing +      Just p  -> Just $ T.concat $ tail p  instance PrettyPrint RelPath where    prettyprint (Path up rest frag) = ups <> rest <> fragment @@ -63,14 +64,14 @@ instance PrettyPrint RelPath where  -- at the end of the prefix, i.e. it will never return paths  -- that lie (naïvely) outside of the prefix.  normalise :: FilePath -> RelPath ->  FilePath -normalise prefix (Path 0 path _) = prefix </> T.unpack path +normalise prefix (Path 0 path _) = prefix </> toString path  normalise prefix (Path i path _) = -  concat (take (length dirs - i) dirs) </> T.unpack path +  concat (take (length dirs - i) dirs) </> toString path    where dirs = splitPath prefix  normaliseWithFrag :: FilePath -> RelPath -> FilePath  normaliseWithFrag prefix (Path i path frag) = -  normalise prefix (Path (i+1) path frag) <> T.unpack (maybe mempty ("#" <>) frag) +  normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag)  -- | does this path contain an old-style pattern for inter-repository  -- links as was used at rc3 in 2020? @@ -81,7 +82,5 @@ isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text)            _      -> text  getExtension :: RelPath -> Text -getExtension (Path _ text _) = case length splitted of -  0 -> "" -  _ -> last splitted +getExtension (Path _ text _) = maybe "" last (nonEmpty splitted)    where splitted = T.splitOn "." text diff --git a/lib/Properties.hs b/lib/Properties.hs index 9cde1ec..eb31403 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE DataKinds         #-} -{-# LANGUAGE LambdaCase        #-} -{-# LANGUAGE MultiWayIf        #-} -{-# LANGUAGE NamedFieldPuns    #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards   #-} -{-# LANGUAGE TupleSections     #-} -{-# LANGUAGE TypeApplications  #-} +{-# LANGUAGE DataKinds           #-} +{-# LANGUAGE FlexibleContexts    #-} +{-# LANGUAGE LambdaCase          #-} +{-# LANGUAGE MultiWayIf          #-} +{-# LANGUAGE NamedFieldPuns      #-} +{-# LANGUAGE OverloadedStrings   #-} +{-# LANGUAGE RecordWildCards     #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections       #-} +{-# LANGUAGE TypeApplications    #-} +{-# LANGUAGE TypeFamilies        #-}  -- | Contains checks for custom ties of the map json  module Properties (checkMap, checkTileset, checkLayer) where +import           Universum         hiding (intercalate, isPrefixOf) -import           Control.Monad     (forM, forM_, unless, when) -import           Data.Text         (Text, intercalate, isInfixOf, isPrefixOf) +import           Data.Text         (intercalate, isInfixOf, isPrefixOf)  import qualified Data.Text         as T  import qualified Data.Vector       as V  import           Tiled             (Layer (..), Object (..), Property (..), @@ -27,14 +30,9 @@ import           Util              (mkProxy, naiveEscapeHTML, prettyprint,  import           Badges            (Badge (Badge),                                      BadgeArea (BadgePoint, BadgeRect),                                      BadgeToken, parseToken) -import           Data.Data         (Proxy (Proxy)) -import           Data.Functor      ((<&>))  import           Data.List         ((\\)) -import           Data.Maybe        (fromMaybe, isJust) -import           Data.Set          (Set)  import qualified Data.Set          as S  import           Data.Text.Metrics (damerauLevenshtein) -import           Data.Vector       (Vector)  import           GHC.TypeLits      (KnownSymbol)  import           LayerData         (Collision, layerOverlaps)  import           LintConfig        (LintConfig (..)) @@ -86,7 +84,7 @@ checkMap = do    let unlessLayer = unlessElement layers    -- test custom map properties -  mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap) +  mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap)    -- can't have these with the rest of layer/tileset lints since they're    -- not specific to any one of them @@ -144,10 +142,10 @@ checkMapProperty p@(Property name _) = case name of    -- scripts can be used by one map    _ | T.toLower name == "script" ->        unwrapString p $ \str -> -        unless ((checkIsRc3Url str) && -                (not $ "/../" `isInfixOf` str) && -                (not $ "%" `isInfixOf` str) && -                (not $ "@" `isInfixOf` str)) +        unless (checkIsRc3Url str && +                not ( "/../" `isInfixOf` str) && +                not ( "%" `isInfixOf` str) && +                not ( "@" `isInfixOf` str))          $ forbid "only scripts hosted on static.rc3.world are allowed."      | name `elem` ["jitsiRoom", "bbbRoom", "playAudio", "openWebsite"                    , "url", "exitUrl", "silent", "getBadge"] @@ -192,14 +190,14 @@ checkTileset = do    adjust (\t -> t { tilesetTiles = tiles' })    -- check individual tileset properties -  mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset) +  mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset)    case tilesetTiles tileset of      Nothing -> pure ()      Just tiles -> refuseDoubledThings tileId        -- can't set properties on the same tile twice          (\tile -> complain $ "cannot set properties on the \ -                  \tile with the id" <> showText (tileId tile) <> "twice.") +                  \tile with the id" <> show (tileId tile) <> "twice.")          tiles    where @@ -258,14 +256,14 @@ checkLayer = do        forM_ (getProperties layer) checkObjectGroupProperty        unless (layerName layer == "floorLayer") $ -        when (null (layerObjects layer) || layerObjects layer == Just mempty) $ +        when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $            warn "objectgroup layer (which aren't the floorLayer) \                 \are useless if they are empty."      ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."    if layerType layer == "group" -    then when (null (layerLayers layer)) +    then when (isNothing (layerLayers layer))      $ warn "Empty group layers are pointless."      else when (isJust (layerLayers layer))      $ complain "Layer is not of type \"group\", but has sublayers." @@ -316,7 +314,7 @@ checkObjectProperty p@(Property name _) = do          unless (objectType obj == "variable") $            complain $ "the "<>prettyprint name<>" property should only be set \                       \on objects of type \"variable\"" -        when (null (objectName obj) || objectName obj == Just mempty) $ +        when (isNothing (objectName obj) || objectName obj == Just mempty) $            complain $ "Objects with the property "<>prettyprint name<>" set must \                       \be named."      | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do @@ -525,7 +523,7 @@ checkTileThing removeExits p@(Property name _value) = case name of        requireProperty req = propertyRequiredBy req name        requireOneOf names = do          context <- askContext -        when (all (not . containsProperty context) names) +        unless (any (containsProperty context) names)            $ complain $ "property " <> prettyprint name <> " requires one of "                      <> prettyprint names @@ -549,9 +547,8 @@ checkTileThing removeExits p@(Property name _value) = case name of  -- | refuse doubled names in everything that's somehow a collection of names  refuseDoubledNames -  :: (HasName a, HasTypeName a) -  => (Foldable t, Functor t) -  => t a +  :: (Container t, HasName (Element t), HasTypeName (Element t)) +  => t    -> LintWriter b  refuseDoubledNames = refuseDoubledThings    getName @@ -560,10 +557,10 @@ refuseDoubledNames = refuseDoubledThings  -- | refuse doubled things via equality on after applying some function  refuseDoubledThings -  :: (Eq a, Ord a, Foldable t, Functor t) -  => (a' -> a) -  -> (a' -> LintWriter b) -  -> t a' +  :: (Eq a, Ord a, Container t) +  => (Element t -> a) +  -> (Element t -> LintWriter b) +  -> t    -> LintWriter b  refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempty)    where @@ -591,15 +588,15 @@ warnUnknown p@(Property name _) =  ---- General functions ----  unlessElement -  :: Foldable f -  => f a -  -> (a -> Bool) +  :: Container f +  => f +  -> (Element f -> Bool)    -> LintWriter b    -> LintWriter b  unlessElement things op = unless (any op things) -unlessElementNamed :: (HasName a, Foldable f) -  => f a -> Text -> LintWriter b -> LintWriter b +unlessElementNamed :: (HasName (Element f), Container f) +  => f -> Text -> LintWriter b -> LintWriter b  unlessElementNamed things name =    unlessElement things ((==) name . getName) @@ -777,4 +774,4 @@ isOrdInRange :: (Ord a, Show a)  isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int ->    if l < int && int < r then pure ()    else complain $ "Property " <> prettyprint name <> " should be between " -               <> showText l <> " and " <> showText r<>"." +               <> show l <> " and " <> show r<>"." diff --git a/lib/Tiled.hs b/lib/Tiled.hs index ab7d4f4..3162dfd 100644 --- a/lib/Tiled.hs +++ b/lib/Tiled.hs @@ -17,21 +17,15 @@  -- 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) -import qualified Data.Aeson             as A -import           Data.Aeson.Types       (typeMismatch) -import qualified Data.ByteString        as BS -import qualified Data.ByteString.Lazy   as LB -import           Data.Char              (toLower) -import           Data.Map               (Map) -import           Data.String            (IsString (fromString)) -import           Data.Text              (Text) -import qualified Data.Text              as T -import           Data.Vector            (Vector) -import           GHC.Generics           (Generic) +import           Universum + +-- TODO: what ever are these aeson imports +import           Data.Aeson           hiding (Object) +import qualified Data.Aeson           as A +import           Data.Aeson.Types     (typeMismatch) +import qualified Data.ByteString      as BS +import qualified Data.ByteString.Lazy as LB +import           Data.Char            (toLower)  -- | options for Aeson's generic encoding and parsing functions @@ -68,7 +62,7 @@ data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int | FloatProp Floa    deriving (Eq, Generic, Show, NFData)  instance IsString PropertyValue where -  fromString s = StrProp (T.pack s) +  fromString s = StrProp (toText s)  instance FromJSON Property where    parseJSON (A.Object o) = do diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs index 5589207..f55e75e 100644 --- a/lib/TiledAbstract.hs +++ b/lib/TiledAbstract.hs @@ -2,10 +2,8 @@  module TiledAbstract where -import           Data.Maybe  (fromMaybe) -import           Data.Proxy  (Proxy) -import           Data.Text   (Text) -import           Data.Vector (Vector) +import           Universum +  import qualified Data.Vector as V  import           Tiled       (GlobalId, Layer (..), Object (..), Property (..),                                PropertyValue (..), Tile (..), Tiledmap (..), @@ -17,27 +15,27 @@ class HasProperties a where    adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a  instance HasProperties Layer where -  getProperties = fromMaybe mempty . layerProperties +  getProperties = maybeToMonoid . layerProperties    adjustProperties f layer = layer      { layerProperties = f (getProperties layer) }  instance HasProperties Tileset where -  getProperties = fromMaybe mempty . tilesetProperties +  getProperties = maybeToMonoid . tilesetProperties    adjustProperties f tileset = tileset      { tilesetProperties = f (getProperties tileset) }  instance HasProperties Tile where -  getProperties = V.toList . fromMaybe mempty . tileProperties +  getProperties = V.toList . maybeToMonoid . tileProperties    adjustProperties f tile = tile      { tileProperties = (fmap V.fromList . f) (getProperties tile) }  instance HasProperties Object where -  getProperties = V.toList . fromMaybe mempty . objectProperties +  getProperties = V.toList . maybeToMonoid . objectProperties    adjustProperties f obj = obj      { objectProperties = (fmap V.fromList . f) (getProperties obj) }  instance HasProperties Tiledmap where -  getProperties = fromMaybe mempty . tiledmapProperties +  getProperties = maybeToMonoid . tiledmapProperties    adjustProperties f tiledmap = tiledmap      { tiledmapProperties = f (getProperties tiledmap) } diff --git a/lib/Types.hs b/lib/Types.hs index 43a5131..f58705a 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -17,20 +17,17 @@ module Types    , lintsToHints    ) where +import           Universum +  import           Control.Monad.Trans.Maybe ()  import           Data.Aeson                (FromJSON, ToJSON (toJSON),                                              ToJSONKey, (.=)) -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) -import           Util                      (PrettyPrint (..), showText) -import           WithCli                   (Argument, Proxy (..), -                                            atomicArgumentsParser) +import           Util                      (PrettyPrint (..)) +import           WithCli                   (Argument, atomicArgumentsParser)  import           WithCli.Pure              (Argument (argumentType, parseArgument),                                              HasArguments (argumentsParser)) @@ -83,7 +80,7 @@ lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing})  instance PrettyPrint Lint where    prettyprint (Lint  Hint { hintMsg, hintLevel } ) = -    "  " <> showText hintLevel <> ": " <> hintMsg +    "  " <> show hintLevel <> ": " <> hintMsg    prettyprint (Depends dep) =      "  Info: found dependency: " <> prettyprint dep    prettyprint (Offers dep) = @@ -92,7 +89,7 @@ instance PrettyPrint Lint where      "  Info: found a badge."  instance PrettyPrint Hint where -  prettyprint (Hint level msg) = "  " <> showText level <> ": " <> msg +  prettyprint (Hint level msg) = "  " <> show level <> ": " <> msg  instance ToJSON Lint where    toJSON (Lint h) = toJSON h diff --git a/lib/Uris.hs b/lib/Uris.hs index 00f86a4..a8c7068 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -8,26 +8,16 @@  -- | Functions to deal with uris and custom uri schemes  module Uris where +import           Universum - -import           Control.Monad           (unless, when) -import           Data.Aeson              (FromJSON (..), Options (..), -                                          SumEncoding (UntaggedValue), -                                          defaultOptions, genericParseJSON) -import           Data.Data               (Proxy) -import           Data.Either.Combinators (maybeToRight, rightToMaybe) -import           Data.Map.Strict         (Map) -import qualified Data.Map.Strict         as M -import           Data.Text               (Text, pack, unpack) -import qualified Data.Text               as T -import           GHC.Generics            (Generic) -import           GHC.TypeLits            (KnownSymbol, symbolVal) -import           Network.URI.Encode      as URI -import           Text.Regex.TDFA         ((=~)) -import           Witherable              (mapMaybe) - -import           Data.String -import           Network.URI             as NativeUri +import           Data.Aeson         (FromJSON (..), Options (..), +                                     SumEncoding (UntaggedValue), +                                     defaultOptions, genericParseJSON) +import qualified Data.Map.Strict    as M +import qualified Data.Text          as T +import           GHC.TypeLits       (KnownSymbol, symbolVal) +import           Network.URI        (URI (..), URIAuth (..), parseURI) +import qualified Network.URI.Encode as URI  data Substitution =      Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } @@ -56,7 +46,7 @@ extractDomain url =  parseUri :: Text -> Maybe (Text, Text, Text)  parseUri uri = -  case parseURI (unpack uri) of +  case parseURI (toString uri) of      Nothing -> Nothing      Just parsedUri -> case uriAuthority parsedUri of          Nothing -> Nothing @@ -84,15 +74,15 @@ data SubstError =  applySubsts :: KnownSymbol s    => Proxy s -> SchemaSet -> Text -> Either SubstError Text  applySubsts s substs uri =  do -  when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri) +  when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri)     $ Left VarsDisallowed    parts@(schema, _, _) <- note NotALink $ parseUri uri    let rules = filter ((==) schema . fst) substs -  case fmap (applySubst parts . snd) rules of -    []  -> Left (SchemaDoesNotExist schema) -    results@(_:_) -> case mapMaybe rightToMaybe results of +  case nonEmpty (map (applySubst parts . snd) rules) of +    Nothing  -> Left (SchemaDoesNotExist schema) +    Just results -> case rights (toList results) of        suc:_ -> Right suc        _     -> minimum results @@ -104,14 +94,14 @@ applySubsts s substs uri =  do           (fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs))        case rule of          DomainSubstitution table _  -> do -          prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain)) +          prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain))                         $ M.lookup domain table            pure (prefix <> rest)          Prefixed {..}            | domain `elem` blocked -> Left IsBlocked -          | domain `elem` allowed || pack "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri +          | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri            | otherwise -> Right (prefix <> URI.encodeText uri)          Allowed _ domains -> if domain `elem` domains -                    || pack "streamproxy.rc3.world" `T.isSuffixOf` domain +                    || toText "streamproxy.rc3.world" `T.isSuffixOf` domain            then Right uri            else Left (DomainIsBlocked domains) diff --git a/lib/Util.hs b/lib/Util.hs index ffd9faa..1ffbbe5 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -6,31 +6,24 @@  -- concerns itself with wrangling haskell's string types  module Util    ( mkProxy -  , showText    , PrettyPrint(..)    , printPretty    , naiveEscapeHTML    , layerIsEmpty    ) where +import           Universum +  import           Data.Aeson as Aeson -import           Data.Proxy (Proxy (..)) -import           Data.Set   (Set)  import qualified Data.Set   as S -import           Data.Text  (Text)  import qualified Data.Text  as T  import           Tiled      (Layer (layerData), PropertyValue (..),                               Tileset (tilesetName), layerName, mkTiledId) -  -- | helper function to create proxies  mkProxy :: a -> Proxy a  mkProxy = const Proxy --- | haskell's many string types are FUN … -showText :: Show a => a -> Text -showText = T.pack . show -  -- | a class to address all the string conversions necessary  -- when using Show to much that just uses Text instead  class PrettyPrint a where @@ -44,7 +37,7 @@ instance PrettyPrint Text where  instance PrettyPrint Aeson.Value where    prettyprint = \case      Aeson.String s -> prettyprint s -    v              -> (T.pack . show) v +    v              -> show v  instance PrettyPrint t => PrettyPrint (Set t) where    prettyprint = prettyprint . S.toList @@ -53,8 +46,8 @@ instance PrettyPrint PropertyValue where    prettyprint = \case      StrProp str     -> str      BoolProp bool   -> if bool then "true" else "false" -    IntProp int     -> showText int -    FloatProp float -> showText float +    IntProp int     -> show int +    FloatProp float -> show float  -- | here since Unit is sometimes used as dummy type  instance PrettyPrint () where @@ -70,7 +63,7 @@ instance PrettyPrint a => PrettyPrint [a] where    prettyprint = T.intercalate ", " . fmap prettyprint  printPretty :: PrettyPrint a => a -> IO () -printPretty = putStr . T.unpack . prettyprint +printPretty = putStr . toString . prettyprint  -- | for long lists which shouldn't be printed out in their entirety diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs index 36c0df7..e4815fe 100644 --- a/lib/WriteRepo.hs +++ b/lib/WriteRepo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds           #-}  {-# LANGUAGE LambdaCase          #-}  {-# LANGUAGE ScopedTypeVariables #-} @@ -5,14 +6,11 @@  -- | Module for writing an already linted map Repository back out again.  module WriteRepo (writeAdjustedRepository) where +import           Universum +  import           CheckDir               (DirResult (..), resultIsFatal) -import           CheckMap               (MapResult (..)) -import           Control.Monad          (forM_, unless) -import           Control.Monad.Extra    (ifM) +import           CheckMap               (MapResult (..), ResultKind (..))  import           Data.Aeson             (encodeFile) -import           Data.Map.Strict        (toList) -import           Data.Maybe             (mapMaybe) -import           Data.Set               (Set)  import qualified Data.Set               as S  import           LintConfig             (LintConfig (configDontCopyAssets),                                           LintConfig') @@ -27,7 +25,7 @@ import           Types                  (Dep (Local)) -writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult -> IO ExitCode +writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode  writeAdjustedRepository config inPath outPath result    | resultIsFatal config result =        pure (ExitFailure 1) @@ -36,7 +34,7 @@ writeAdjustedRepository config inPath outPath result          createDirectoryIfMissing True outPath          -- write out all maps -        forM_ (toList $ dirresultMaps result) $ \(path,out) -> do +        forM_ (toPairs $ dirresultMaps result) $ \(path,out) -> do            createDirectoryIfMissing True (takeDirectory (outPath </> path))            encodeFile (outPath </> path) $ mapresultAdjusted out @@ -51,7 +49,7 @@ writeAdjustedRepository config inPath outPath result                         Local path -> Just . normalise mapdir $ path                         _          -> Nothing)                       $ mapresultDepends mapresult) -                . toList $ dirresultMaps result +                . toPairs $ dirresultMaps result            -- copy all assets            forM_ localdeps $ \path -> | 
