blob: fbe139baa6483d2508438bfe2e11f985c1fd6308 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Module for writing an already linted map Repository back out again.
module WriteRepo where
import CheckDir (DirResult (..), resultIsFatal)
import CheckMap (MapResult (..))
import Control.Monad (forM_, unless)
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')
import Paths (normalise)
import System.Directory.Extra (copyFile, createDirectoryIfMissing)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory)
import qualified System.FilePath as FP
import System.FilePath.Posix ((</>))
import Types (Dep (Local))
writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult -> IO ExitCode
writeAdjustedRepository config inPath outPath result
| resultIsFatal config result =
pure (ExitFailure 1)
| not (configDontCopyAssets config) =
pure (ExitSuccess)
| otherwise = do
createDirectoryIfMissing True outPath
-- write out all maps
mapM_
(\(path,out) -> encodeFile (outPath </> path) $ mapresultAdjusted out)
(toList $ dirresultMaps result)
unless (configDontCopyAssets config) $ do
-- collect asset dependencies of maps
-- TODO: its kinda weird doing that here, tbh
let localdeps :: Set FilePath =
S.fromList . concatMap
(\(mappath,mapresult) ->
let mapdir = takeDirectory mappath in
mapMaybe (\case
Local path -> Just . normalise mapdir $ path
_ -> Nothing)
$ mapresultDepends mapresult)
. toList $ dirresultMaps result
-- copy all assets
forM_ localdeps $ \path ->
let
assetPath = FP.normalise $ inPath </> path
newPath = FP.normalise $ outPath </> path
in do
-- putStrLn $ "copying " <> assetPath <> " → " <> newPath
copyFile assetPath newPath
pure ExitSuccess
|
