Skip to content
Snippets Groups Projects
Commit 11417fc1 authored by stuebinm's avatar stuebinm
Browse files

walint: some marginally nicer code

parent 52d0d9df
No related branches found
No related tags found
No related merge requests found
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where module Main where
import Universum import Universum
import Data.Aeson (eitherDecode, encode) import Data.Aeson (eitherDecodeFileStrict', encode)
import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.KeyMap (coercionToHashMap) 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 WithCli (HasArguments, withCli)
import CheckDir (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph)) import CheckDir (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph))
import Control.Monad (when) import Control.Monad (when)
import LintConfig (LintConfig (..), patchConfig) import LintConfig (LintConfig (..), patchConfig)
import System.Exit (ExitCode (ExitFailure))
import Types (Level (..)) import Types (Level (..))
import Util (printPretty) import Util (printPretty)
import WriteRepo (writeAdjustedRepository)
import Text.Dot (showDot)
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import qualified Version as V (version) import qualified Version as V (version)
import WriteRepo (writeAdjustedRepository)
-- | the options this cli tool can take -- | the options this cli tool can take
data Options = Options data Options = Options
...@@ -55,50 +51,46 @@ main :: IO () ...@@ -55,50 +51,46 @@ main :: IO ()
main = withCli run main = withCli run
run :: Options -> IO () run :: Options -> IO ()
run options = do run Options { .. } = do
aesonWarning aesonWarning
when (version options) $ do if version then
putStrLn V.version putStrLn V.version
exitSuccess else do
let repo = fromMaybe "." repository
let repo = fromMaybe "." (repository options) let entry = fromMaybe "main.json" entrypoint
let entry = fromMaybe "main.json" (entrypoint options) let level = fromMaybe Suggestion lintlevel
let level = fromMaybe Suggestion (lintlevel options) configFile' <- case configFile of
Nothing -> do
lintconfig <- case configFile options of hPutStrLn stderr ("option --config-file=FILEPATH required" :: Text)
Nothing -> error "Need a config file!" exitFailure
Just path -> LB.readFile path >>= \res -> Just path -> pure path
case eitherDecode res :: Either String (LintConfig Identity) of
Left err -> error $ "config file invalid: " <> toText err lintconfig <- eitherDecodeFileStrict' configFile' >>= \case
Right file -> pure (patchConfig file (config options)) Left err -> error $ "config file invalid: " <> toText err
Right file -> pure (patchConfig file config)
lints <- recursiveCheckDir lintconfig repo entry
lints <- recursiveCheckDir lintconfig repo entry
if | dot options ->
putStrLn (showDot $ dirresultGraph lints) if json
| json options -> then putText
printLB $ decodeUtf8 (if pretty then encodePretty lints else encode lints)
$ if pretty options then encodePretty lints else encode lints else printPretty (level, lints)
| otherwise -> printPretty (level, lints)
case out of
case out options of Nothing
Nothing -> exitWith $ if resultIsFatal lintconfig lints then ExitFailure 1 else ExitSuccess | resultIsFatal lintconfig lints -> exitWith (ExitFailure 1)
Just outpath -> do | otherwise -> exitSuccess
c <- writeAdjustedRepository lintconfig repo outpath lints Just outpath -> do
unless (json options) $ c <- writeAdjustedRepository lintconfig repo outpath lints
case c of unless json $
ExitFailure 1 -> putTextLn "\nMap failed linting!" case c of
ExitFailure 2 -> putTextLn "\nOutpath already exists, not writing anything." ExitFailure 1 ->
_ -> pass putTextLn "\nMap failed linting!"
exitWith c 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
-- if Aesons's internal map and HashMap are the same type, then coercionToHashMap -- if Aesons's internal map and HashMap are the same type, then coercionToHashMap
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment