From 11417fc194673decbfcb6e8b7e3da0af203feff1 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sun, 6 Mar 2022 16:21:24 +0100
Subject: [PATCH] walint: some marginally nicer code
---
src/Main.hs | 102 ++++++++++++++++++++++++----------------------------
1 file changed, 47 insertions(+), 55 deletions(-)
diff --git a/src/Main.hs b/src/Main.hs
index bf39564..b2002bf 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,32 +1,28 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Universum
-import Data.Aeson (eitherDecode, encode)
+import Data.Aeson (eitherDecodeFileStrict', encode)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.KeyMap (coercionToHashMap)
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.IO as T
import WithCli (HasArguments, withCli)
import CheckDir (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph))
import Control.Monad (when)
import LintConfig (LintConfig (..), patchConfig)
+import System.Exit (ExitCode (ExitFailure))
import Types (Level (..))
import Util (printPretty)
-import WriteRepo (writeAdjustedRepository)
-import Text.Dot (showDot)
-
-import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import qualified Version as V (version)
+import WriteRepo (writeAdjustedRepository)
-- | the options this cli tool can take
data Options = Options
@@ -55,50 +51,46 @@ main :: IO ()
main = withCli run
run :: Options -> IO ()
-run options = do
+run Options { .. } = do
aesonWarning
- when (version options) $ do
+ if version then
putStrLn V.version
- exitSuccess
-
- let repo = fromMaybe "." (repository options)
- let entry = fromMaybe "main.json" (entrypoint options)
- let level = fromMaybe Suggestion (lintlevel options)
-
- lintconfig <- case configFile options of
- Nothing -> error "Need a config file!"
- Just path -> LB.readFile path >>= \res ->
- case eitherDecode res :: Either String (LintConfig Identity) of
- Left err -> error $ "config file invalid: " <> toText err
- Right file -> pure (patchConfig file (config options))
-
- lints <- recursiveCheckDir lintconfig repo entry
-
- if | dot options ->
- putStrLn (showDot $ dirresultGraph lints)
- | json options ->
- printLB
- $ if pretty options then encodePretty lints else encode lints
- | otherwise -> printPretty (level, lints)
-
- case out options of
- Nothing -> exitWith $ if resultIsFatal lintconfig lints then ExitFailure 1 else ExitSuccess
- Just outpath -> do
- c <- writeAdjustedRepository lintconfig repo outpath lints
- unless (json options) $
- case c of
- ExitFailure 1 -> putTextLn "\nMap failed linting!"
- ExitFailure 2 -> putTextLn "\nOutpath already exists, not writing anything."
- _ -> pass
- exitWith c
-
-
-
-
--- | haskell's many string types are FUN …
-printLB :: LB.ByteString -> IO ()
-printLB a = T.putStrLn $ T.decodeUtf8 $ LB.toStrict a
+ else do
+ let repo = fromMaybe "." repository
+ let entry = fromMaybe "main.json" entrypoint
+ let level = fromMaybe Suggestion lintlevel
+ configFile' <- case configFile of
+ Nothing -> do
+ hPutStrLn stderr ("option --config-file=FILEPATH required" :: Text)
+ exitFailure
+ Just path -> pure path
+
+ lintconfig <- eitherDecodeFileStrict' configFile' >>= \case
+ Left err -> error $ "config file invalid: " <> toText err
+ Right file -> pure (patchConfig file config)
+
+ lints <- recursiveCheckDir lintconfig repo entry
+
+ if json
+ then putText
+ $ decodeUtf8 (if pretty then encodePretty lints else encode lints)
+ else printPretty (level, lints)
+
+ case out of
+ Nothing
+ | resultIsFatal lintconfig lints -> exitWith (ExitFailure 1)
+ | otherwise -> exitSuccess
+ Just outpath -> do
+ c <- writeAdjustedRepository lintconfig repo outpath lints
+ unless json $
+ case c of
+ ExitFailure 1 ->
+ putTextLn "\nMap failed linting!"
+ ExitFailure 2 ->
+ putTextLn "\nOutpath already exists, not writing anything."
+ _ -> pass
+ exitWith c
-- if Aesons's internal map and HashMap are the same type, then coercionToHashMap
--
GitLab