{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}

module Config.Yaml(
    ConfigYaml,
    ConfigYamlBuiltin (..),
    ConfigYamlUser (..),
    readFileConfigYaml,
    settingsFromConfigYaml,
    isBuiltinYaml,
    ) where

#if defined(MIN_VERSION_aeson)
#if MIN_VERSION_aeson(2,0,0)
#define AESON 2
#else
#define AESON 1
#endif
#else
#define AESON 2
#endif

import GHC.Driver.Ppr
import GHC.Driver.Errors.Types
import GHC.Types.Error hiding (Severity)

import Config.Type
import Data.Either.Extra
import Data.Maybe
import Data.List.Extra
import Data.Tuple.Extra
import Control.Monad.Extra
import Data.Text qualified as T
import Data.Vector qualified as V
import Data.ByteString.Char8 qualified as BS
import Data.HashMap.Strict qualified as Map
import Data.Generics.Uniplate.DataOnly
import GHC.All
import Fixity
import Extension
import GHC.Unit.Module
import Data.Functor
import Data.Monoid
import Data.Semigroup
import Timing
import Prelude

import GHC.Data.Bag
import GHC.Parser.Lexer
import GHC.Utils.Error hiding (Severity)
import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence
import GHC.Util (baseDynFlags, Scope, scopeCreate)
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Data.Char
#if AESON == 2
import Data.Aeson.KeyMap (toHashMapText)
#endif

#ifdef HS_YAML

import Data.YAML (Pos)
import Data.YAML.Aeson (encode1Strict, decode1Strict)
import Data.Aeson hiding (encode)
import Data.Aeson.Types (Parser)
import Data.ByteString qualified as BSS

decodeFileEither :: FilePath -> IO (Either (Pos, String) ConfigYaml)
decodeFileEither path = decode1Strict <$> BSS.readFile path

decodeEither' :: BSS.ByteString -> Either (Pos, String) ConfigYaml
decodeEither' = decode1Strict

displayException :: (Pos, String) -> String
displayException = show

encode :: Value -> BSS.ByteString
encode = encode1Strict

#else

import Data.Yaml
import Control.Exception.Extra

#endif

#if AESON == 1
toHashMapText :: a -> a
toHashMapText = id
#endif

-- | Read a config file in YAML format. Takes a filename, and optionally the contents.
--   Fails if the YAML doesn't parse or isn't valid HLint YAML
readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml
readFileConfigYaml :: String -> Maybe String -> IO ConfigYaml
readFileConfigYaml String
file Maybe String
contents = forall a. String -> String -> IO a -> IO a
timedIO String
"Config" String
file forall a b. (a -> b) -> a -> b
$ do
    Either ParseException ConfigYaml
val <- case Maybe String
contents of
        Maybe String
Nothing ->
            if String -> Bool
isBuiltinYaml String
file
                then forall b c a. (b -> c) -> Either a b -> Either a c
mapRight ConfigYamlBuiltin -> ConfigYaml
getConfigYamlBuiltin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
file
                else forall b c a. (b -> c) -> Either a b -> Either a c
mapRight ConfigYamlUser -> ConfigYaml
getConfigYamlUser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
file
        Just String
src -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            if String -> Bool
isBuiltinYaml String
file
                then forall b c a. (b -> c) -> Either a b -> Either a c
mapRight ConfigYamlBuiltin -> ConfigYaml
getConfigYamlBuiltin forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
src
                else forall b c a. (b -> c) -> Either a b -> Either a c
mapRight ConfigYamlUser -> ConfigYaml
getConfigYamlUser forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
src
    case Either ParseException ConfigYaml
val of
        Left ParseException
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to read YAML configuration file " forall a. [a] -> [a] -> [a]
++ String
file forall a. [a] -> [a] -> [a]
++ String
"\n  " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException ParseException
e
        Right ConfigYaml
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigYaml
v

isBuiltinYaml :: FilePath -> Bool
isBuiltinYaml :: String -> Bool
isBuiltinYaml = (forall a. Eq a => a -> a -> Bool
== String
"data/hlint.yaml")

---------------------------------------------------------------------
-- YAML DATA TYPE

newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (NonEmpty ConfigYaml -> ConfigYaml
ConfigYaml -> ConfigYaml -> ConfigYaml
forall b. Integral b => b -> ConfigYaml -> ConfigYaml
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ConfigYaml -> ConfigYaml
$cstimes :: forall b. Integral b => b -> ConfigYaml -> ConfigYaml
sconcat :: NonEmpty ConfigYaml -> ConfigYaml
$csconcat :: NonEmpty ConfigYaml -> ConfigYaml
<> :: ConfigYaml -> ConfigYaml -> ConfigYaml
$c<> :: ConfigYaml -> ConfigYaml -> ConfigYaml
Semigroup,Semigroup ConfigYaml
ConfigYaml
[ConfigYaml] -> ConfigYaml
ConfigYaml -> ConfigYaml -> ConfigYaml
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ConfigYaml] -> ConfigYaml
$cmconcat :: [ConfigYaml] -> ConfigYaml
mappend :: ConfigYaml -> ConfigYaml -> ConfigYaml
$cmappend :: ConfigYaml -> ConfigYaml -> ConfigYaml
mempty :: ConfigYaml
$cmempty :: ConfigYaml
Monoid,Int -> ConfigYaml -> ShowS
[ConfigYaml] -> ShowS
ConfigYaml -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigYaml] -> ShowS
$cshowList :: [ConfigYaml] -> ShowS
show :: ConfigYaml -> String
$cshow :: ConfigYaml -> String
showsPrec :: Int -> ConfigYaml -> ShowS
$cshowsPrec :: Int -> ConfigYaml -> ShowS
Show)

data ConfigItem
    = ConfigPackage Package
    | ConfigGroup Group
    | ConfigSetting [Setting]
      deriving Int -> ConfigItem -> ShowS
[ConfigItem] -> ShowS
ConfigItem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigItem] -> ShowS
$cshowList :: [ConfigItem] -> ShowS
show :: ConfigItem -> String
$cshow :: ConfigItem -> String
showsPrec :: Int -> ConfigItem -> ShowS
$cshowsPrec :: Int -> ConfigItem -> ShowS
Show

data Package = Package
    {Package -> String
packageName :: String
    ,Package -> [HsExtendInstances (LImportDecl GhcPs)]
packageModules :: [HsExtendInstances (LImportDecl GhcPs)]
    } deriving Int -> Package -> ShowS
[Package] -> ShowS
Package -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Package] -> ShowS
$cshowList :: [Package] -> ShowS
show :: Package -> String
$cshow :: Package -> String
showsPrec :: Int -> Package -> ShowS
$cshowsPrec :: Int -> Package -> ShowS
Show

data Group = Group
    {Group -> String
groupName :: String
    ,Group -> Bool
groupEnabled :: Bool
    ,Group -> [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
    ,Group -> [Either HintRule Classify]
groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty
    } deriving Int -> Group -> ShowS
[Group] -> ShowS
Group -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Group] -> ShowS
$cshowList :: [Group] -> ShowS
show :: Group -> String
$cshow :: Group -> String
showsPrec :: Int -> Group -> ShowS
$cshowsPrec :: Int -> Group -> ShowS
Show


---------------------------------------------------------------------
-- YAML PARSING LIBRARY

data Val = Val
    Value -- the actual value I'm focused on
    [(String, Value)] -- the path of values I followed (for error messages)

newVal :: Value -> Val
newVal :: Value -> Val
newVal Value
x = Value -> [(String, Value)] -> Val
Val Value
x [(String
"root", Value
x)]

getVal :: Val -> Value
getVal :: Val -> Value
getVal (Val Value
x [(String, Value)]
_) = Value
x

addVal :: String -> Value -> Val -> Val
addVal :: String -> Value -> Val -> Val
addVal String
key Value
v (Val Value
focus [(String, Value)]
path) = Value -> [(String, Value)] -> Val
Val Value
v forall a b. (a -> b) -> a -> b
$ (String
key,Value
v) forall a. a -> [a] -> [a]
: [(String, Value)]
path

-- | Failed when parsing some value, give an informative error message.
parseFail :: Val -> String -> Parser a
parseFail :: forall a. Val -> String -> Parser a
parseFail (Val Value
focus [(String, Value)]
path) String
msg = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
    String
"Error when decoding YAML, " forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
    String
"Along path: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
steps forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
    String
"When at: " forall a. [a] -> [a] -> [a]
++ forall a b. (a, b) -> a
fst (String -> (String, String)
word1 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Value
focus) forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
    -- aim to show a smallish but relevant context
    ByteString -> String
dotDot (forall a. a -> Maybe a -> a
fromMaybe (forall a. ToJSON a => a -> ByteString
encode Value
focus) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ByteString
x -> ByteString -> Int
BS.length ByteString
x forall a. Ord a => a -> a -> Bool
> Int
250) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> ByteString
encode [Value]
contexts)
    where
        ([String]
steps, [Value]
contexts) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [(String, Value)]
path
        dotDot :: ByteString -> String
dotDot ByteString
x = let (ByteString
a,ByteString
b) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
250 ByteString
x in ByteString -> String
BS.unpack ByteString
a forall a. [a] -> [a] -> [a]
++ (if ByteString -> Bool
BS.null ByteString
b then String
"" else String
"...")

parseArray :: Val -> Parser [Val]
parseArray :: Val -> Parser [Val]
parseArray v :: Val
v@(Val -> Value
getVal -> Array Array
xs) = forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Val -> Parser [Val]
parseArray forall a b. (a -> b) -> a -> b
$ forall a b c. Enum a => (a -> b -> c) -> a -> [b] -> [c]
zipWithFrom (\Integer
i Value
x -> String -> Value -> Val -> Val
addVal (forall a. Show a => a -> String
show Integer
i) Value
x Val
v) Integer
0 forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Array
xs
parseArray Val
v = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Val
v]

parseObject :: Val -> Parser (Map.HashMap T.Text Value)
parseObject :: Val -> Parser (HashMap Text Value)
parseObject (Val -> Value
getVal -> Object Object
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall v. KeyMap v -> HashMap Text v
toHashMapText Object
x)
parseObject Val
v = forall a. Val -> String -> Parser a
parseFail Val
v String
"Expected an Object"

parseObject1 :: Val -> Parser (String, Val)
parseObject1 :: Val -> Parser (String, Val)
parseObject1 Val
v = do
    HashMap Text Value
mp <- Val -> Parser (HashMap Text Value)
parseObject Val
v
    case forall k v. HashMap k v -> [k]
Map.keys HashMap Text Value
mp of
        [Text -> String
T.unpack -> String
s] -> (String
s,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Val -> Parser Val
parseField String
s Val
v
        [Text]
_ -> forall a. Val -> String -> Parser a
parseFail Val
v forall a b. (a -> b) -> a -> b
$ String
"Expected exactly one key but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall k v. HashMap k v -> Int
Map.size HashMap Text Value
mp)

parseString :: Val -> Parser String
parseString :: Val -> Parser String
parseString (Val -> Value
getVal -> String Text
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x
parseString Val
v = forall a. Val -> String -> Parser a
parseFail Val
v String
"Expected a String"

parseInt :: Val -> Parser Int
parseInt :: Val -> Parser Int
parseInt (Val -> Value
getVal -> s :: Value
s@Number{}) = forall a. FromJSON a => Value -> Parser a
parseJSON Value
s
parseInt Val
v = forall a. Val -> String -> Parser a
parseFail Val
v String
"Expected an Int"

parseArrayString :: Val -> Parser [String]
parseArrayString :: Val -> Parser [String]
parseArrayString = Val -> Parser [Val]
parseArray forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Val -> Parser String
parseString

maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)
maybeParse :: forall a. (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)
maybeParse Val -> Parser a
parseValue Maybe Val
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
maybeParse Val -> Parser a
parseValue (Just Val
value) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser a
parseValue Val
value

maybeParseEnum :: [(T.Text, a)] -> Maybe Val -> Parser (Maybe a)
maybeParseEnum :: forall a. [(Text, a)] -> Maybe Val -> Parser (Maybe a)
maybeParseEnum [(Text, a)]
_ Maybe Val
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
maybeParseEnum [(Text, a)]
dict (Just Val
val) = case Val -> Value
getVal Val
val of
  String Text
str | Just a
x <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
str [(Text, a)]
dict -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
  Value
_ -> forall a. Val -> String -> Parser a
parseFail Val
val forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"expected '" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"', '" (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, a)]
dict) forall a. Semigroup a => a -> a -> a
<> Text
"'"

parseBool :: Val -> Parser Bool
parseBool :: Val -> Parser Bool
parseBool (Val -> Value
getVal -> Bool Bool
b) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
parseBool Val
v = forall a. Val -> String -> Parser a
parseFail Val
v String
"Expected a Bool"

parseField :: String -> Val -> Parser Val
parseField :: String -> Val -> Parser Val
parseField String
s Val
v = do
    Maybe Val
x <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
s Val
v
    case Maybe Val
x of
        Maybe Val
Nothing -> forall a. Val -> String -> Parser a
parseFail Val
v forall a b. (a -> b) -> a -> b
$ String
"Expected a field named " forall a. [a] -> [a] -> [a]
++ String
s
        Just Val
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
v

parseFieldOpt :: String -> Val -> Parser (Maybe Val)
parseFieldOpt :: String -> Val -> Parser (Maybe Val)
parseFieldOpt String
s Val
v = do
    HashMap Text Value
mp <- Val -> Parser (HashMap Text Value)
parseObject Val
v
    case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (String -> Text
T.pack String
s) HashMap Text Value
mp of
        Maybe Value
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just Value
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Value -> Val -> Val
addVal String
s Value
x Val
v

allowFields :: Val -> [String] -> Parser ()
allowFields :: Val -> [String] -> Parser ()
allowFields Val
v [String]
allow = do
    HashMap Text Value
mp <- Val -> Parser (HashMap Text Value)
parseObject Val
v
    let bad :: [String]
bad = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack (forall k v. HashMap k v -> [k]
Map.keys HashMap Text Value
mp) forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
allow
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
bad forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$
        forall a. Val -> String -> Parser a
parseFail Val
v
          forall a b. (a -> b) -> a -> b
$ String
"Not allowed keys: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
bad
          forall a. [a] -> [a] -> [a]
++ String
", Allowed keys: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
allow

parseGHC :: (ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC :: forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult v
parser Val
v = do
    String
x <- Val -> Parser String
parseString Val
v
    case ParseFlags -> String -> ParseResult v
parser ParseFlags
defaultParseFlags{enabledExtensions :: [Extension]
enabledExtensions=[Extension]
configExtensions, disabledExtensions :: [Extension]
disabledExtensions=[]} String
x of
        POk PState
_ v
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure v
x
        PFailed PState
ps ->
          let errMsg :: MsgEnvelope GhcMessage
errMsg = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bag a -> [a]
bagToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Messages e -> Bag (MsgEnvelope e)
getMessages forall a b. (a -> b) -> a -> b
$ PsMessage -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> b
snd (PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
ps)
              msg :: String
msg = DynFlags -> SDoc -> String
showSDoc DynFlags
baseDynFlags forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault MsgEnvelope GhcMessage
errMsg
          in forall a. Val -> String -> Parser a
parseFail Val
v forall a b. (a -> b) -> a -> b
$ String
"Failed to parse " forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ String
", when parsing:\n " forall a. [a] -> [a] -> [a]
++ String
x

---------------------------------------------------------------------
-- YAML TO DATA TYPE

newtype ConfigYamlBuiltin = ConfigYamlBuiltin { ConfigYamlBuiltin -> ConfigYaml
getConfigYamlBuiltin :: ConfigYaml }
  deriving (NonEmpty ConfigYamlBuiltin -> ConfigYamlBuiltin
ConfigYamlBuiltin -> ConfigYamlBuiltin -> ConfigYamlBuiltin
forall b. Integral b => b -> ConfigYamlBuiltin -> ConfigYamlBuiltin
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ConfigYamlBuiltin -> ConfigYamlBuiltin
$cstimes :: forall b. Integral b => b -> ConfigYamlBuiltin -> ConfigYamlBuiltin
sconcat :: NonEmpty ConfigYamlBuiltin -> ConfigYamlBuiltin
$csconcat :: NonEmpty ConfigYamlBuiltin -> ConfigYamlBuiltin
<> :: ConfigYamlBuiltin -> ConfigYamlBuiltin -> ConfigYamlBuiltin
$c<> :: ConfigYamlBuiltin -> ConfigYamlBuiltin -> ConfigYamlBuiltin
Semigroup, Semigroup ConfigYamlBuiltin
ConfigYamlBuiltin
[ConfigYamlBuiltin] -> ConfigYamlBuiltin
ConfigYamlBuiltin -> ConfigYamlBuiltin -> ConfigYamlBuiltin
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ConfigYamlBuiltin] -> ConfigYamlBuiltin
$cmconcat :: [ConfigYamlBuiltin] -> ConfigYamlBuiltin
mappend :: ConfigYamlBuiltin -> ConfigYamlBuiltin -> ConfigYamlBuiltin
$cmappend :: ConfigYamlBuiltin -> ConfigYamlBuiltin -> ConfigYamlBuiltin
mempty :: ConfigYamlBuiltin
$cmempty :: ConfigYamlBuiltin
Monoid)

newtype ConfigYamlUser = ConfigYamlUser { ConfigYamlUser -> ConfigYaml
getConfigYamlUser :: ConfigYaml }
  deriving (NonEmpty ConfigYamlUser -> ConfigYamlUser
ConfigYamlUser -> ConfigYamlUser -> ConfigYamlUser
forall b. Integral b => b -> ConfigYamlUser -> ConfigYamlUser
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ConfigYamlUser -> ConfigYamlUser
$cstimes :: forall b. Integral b => b -> ConfigYamlUser -> ConfigYamlUser
sconcat :: NonEmpty ConfigYamlUser -> ConfigYamlUser
$csconcat :: NonEmpty ConfigYamlUser -> ConfigYamlUser
<> :: ConfigYamlUser -> ConfigYamlUser -> ConfigYamlUser
$c<> :: ConfigYamlUser -> ConfigYamlUser -> ConfigYamlUser
Semigroup, Semigroup ConfigYamlUser
ConfigYamlUser
[ConfigYamlUser] -> ConfigYamlUser
ConfigYamlUser -> ConfigYamlUser -> ConfigYamlUser
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ConfigYamlUser] -> ConfigYamlUser
$cmconcat :: [ConfigYamlUser] -> ConfigYamlUser
mappend :: ConfigYamlUser -> ConfigYamlUser -> ConfigYamlUser
$cmappend :: ConfigYamlUser -> ConfigYamlUser -> ConfigYamlUser
mempty :: ConfigYamlUser
$cmempty :: ConfigYamlUser
Monoid)

instance FromJSON ConfigYamlBuiltin where
    parseJSON :: Value -> Parser ConfigYamlBuiltin
parseJSON Value
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    parseJSON Value
x = ConfigYaml -> ConfigYamlBuiltin
ConfigYamlBuiltin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Val -> Parser ConfigYaml
parseConfigYaml Bool
True (Value -> Val
newVal Value
x)

instance FromJSON ConfigYamlUser where
  parseJSON :: Value -> Parser ConfigYamlUser
parseJSON Value
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  parseJSON Value
x = ConfigYaml -> ConfigYamlUser
ConfigYamlUser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Val -> Parser ConfigYaml
parseConfigYaml Bool
False (Value -> Val
newVal Value
x)

parseConfigYaml :: Bool -> Val -> Parser ConfigYaml
parseConfigYaml :: Bool -> Val -> Parser ConfigYaml
parseConfigYaml Bool
isBuiltin Val
v = do
    [Val]
vs <- Val -> Parser [Val]
parseArray Val
v
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ConfigItem] -> ConfigYaml
ConfigYaml forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Val]
vs forall a b. (a -> b) -> a -> b
$ \Val
o -> do
        (String
s, Val
v) <- Val -> Parser (String, Val)
parseObject1 Val
o
        case String
s of
            String
"package" -> Package -> ConfigItem
ConfigPackage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser Package
parsePackage Val
v
            String
"group" -> Group -> ConfigItem
ConfigGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Val -> Parser Group
parseGroup Bool
isBuiltin Val
v
            String
"arguments" -> [Setting] -> ConfigItem
ConfigSetting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> Setting
SettingArgument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser [String]
parseArrayString Val
v
            String
"fixity" -> [Setting] -> ConfigItem
ConfigSetting forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser [Setting]
parseFixity Val
v
            String
"smell" -> [Setting] -> ConfigItem
ConfigSetting forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser [Setting]
parseSmell Val
v
            String
_ | forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ String -> Maybe Severity
getSeverity String
s -> Group -> ConfigItem
ConfigGroup forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either HintRule Classify] -> Group
ruleToGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Val -> Parser [Either HintRule Classify]
parseRule Bool
isBuiltin Val
o
            String
_ | Just RestrictType
r <- String -> Maybe RestrictType
getRestrictType String
s -> [Setting] -> ConfigItem
ConfigSetting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Restrict -> Setting
SettingRestrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Parser [Val]
parseArray Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RestrictType -> Val -> Parser Restrict
parseRestrict RestrictType
r))
            String
_ -> forall a. Val -> String -> Parser a
parseFail Val
v String
"Expecting an object with a 'package' or 'group' key, a hint or a restriction"


parsePackage :: Val -> Parser Package
parsePackage :: Val -> Parser Package
parsePackage Val
v = do
    String
packageName <- String -> Val -> Parser Val
parseField String
"name" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> Parser String
parseString
    [HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
packageModules <- String -> Val -> Parser Val
parseField String
"modules" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> Parser [Val]
parseArray forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> HsExtendInstances a
extendInstances forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode)
    Val -> [String] -> Parser ()
allowFields Val
v [String
"name",String
"modules"]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Package{String
[HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
packageModules :: [HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
packageName :: String
packageModules :: [HsExtendInstances (LImportDecl GhcPs)]
packageName :: String
..}

parseFixity :: Val -> Parser [Setting]
parseFixity :: Val -> Parser [Setting]
parseFixity Val
v = Val -> Parser [Val]
parseArray Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {l}. GenLocated l (HsDecl GhcPs) -> Parser [Setting]
f)
    where
        f :: GenLocated l (HsDecl GhcPs) -> Parser [Setting]
f (L l
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ FixitySig GhcPs
x))) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> Setting
Infix forall a b. (a -> b) -> a -> b
$ FixitySig GhcPs -> [FixityInfo]
fromFixitySig FixitySig GhcPs
x
        f GenLocated l (HsDecl GhcPs)
_ = forall a. Val -> String -> Parser a
parseFail Val
v String
"Expected fixity declaration"

parseSmell :: Val -> Parser [Setting]
parseSmell :: Val -> Parser [Setting]
parseSmell Val
v = do
  String
smellName <- String -> Val -> Parser Val
parseField String
"type" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> Parser String
parseString
  SmellType
smellType <- forall a. Val -> String -> Maybe a -> Parser a
require Val
v String
"Expected SmellType"  forall a b. (a -> b) -> a -> b
$ String -> Maybe SmellType
getSmellType String
smellName
  Int
smellLimit <- String -> Val -> Parser Val
parseField String
"limit" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> Parser Int
parseInt
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [SmellType -> Int -> Setting
SettingSmell SmellType
smellType Int
smellLimit]
    where
      require :: Val -> String -> Maybe a -> Parser a
      require :: forall a. Val -> String -> Maybe a -> Parser a
require Val
_ String
_ (Just a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      require Val
val String
err Maybe a
Nothing = forall a. Val -> String -> Parser a
parseFail Val
val String
err

parseGroup :: Bool -> Val -> Parser Group
parseGroup :: Bool -> Val -> Parser Group
parseGroup Bool
isBuiltin Val
v = do
    String
groupName <- String -> Val -> Parser Val
parseField String
"name" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> Parser String
parseString
    Bool
groupEnabled <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"enabled" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) Val -> Parser Bool
parseBool
    [Either
   String
   (HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs)))]
groupImports <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"imports" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Val -> Parser [Val]
parseArray forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Val
-> Parser
     (Either
        String
        (HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs))))
parseImport)
    [Either HintRule Classify]
groupRules <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"rules" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Val -> Parser [Val]
parseArray forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Bool -> Val -> Parser [Either HintRule Classify]
parseRule Bool
isBuiltin)
    Val -> [String] -> Parser ()
allowFields Val
v [String
"name",String
"enabled",String
"imports",String
"rules"]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Group{Bool
String
[Either
   String
   (HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs)))]
[Either HintRule Classify]
groupRules :: [Either HintRule Classify]
groupImports :: [Either
   String
   (HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs)))]
groupEnabled :: Bool
groupName :: String
groupRules :: [Either HintRule Classify]
groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupEnabled :: Bool
groupName :: String
..}
    where
        parseImport :: Val
-> Parser
     (Either
        String
        (HsExtendInstances (GenLocated SrcSpanAnnA (ImportDecl GhcPs))))
parseImport Val
v = do
            String
x <- Val -> Parser String
parseString Val
v
            case String -> (String, String)
word1 String
x of
                 (String
"package", String
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
x
                 (String, String)
_ -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> HsExtendInstances a
extendInstances forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode Val
v

ruleToGroup :: [Either HintRule Classify] -> Group
ruleToGroup :: [Either HintRule Classify] -> Group
ruleToGroup = String
-> Bool
-> [Either String (HsExtendInstances (LImportDecl GhcPs))]
-> [Either HintRule Classify]
-> Group
Group String
"" Bool
True []

parseRule :: Bool -> Val -> Parser [Either HintRule Classify]
parseRule :: Bool -> Val -> Parser [Either HintRule Classify]
parseRule Bool
isBuiltin Val
v = do
    (Severity
severity, Val
v) <- Val -> Parser (Severity, Val)
parseSeverityKey Val
v
    Bool
isRule <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"lhs" Val
v
    if Bool
isRule then do
        [Note]
hintRuleNotes <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"note" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map String -> Note
asNote) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Parser [String]
parseArrayString)
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs <- String -> Val -> Parser Val
parseField String
"lhs" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs <- String -> Val -> Parser Val
parseField String
"rhs" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode
        Maybe (HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
hintRuleSide <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"side" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> HsExtendInstances a
extendInstances) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode)
        String
hintRuleName <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"name" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs -> String
guessName GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs) Val -> Parser String
parseString

        Val -> [String] -> Parser ()
allowFields Val
v [String
"lhs",String
"rhs",String
"note",String
"name",String
"side"]
        let hintRuleScope :: Scope
hintRuleScope = forall a. Monoid a => a
mempty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall a b. a -> Either a b
Left HintRule {hintRuleSeverity :: Severity
hintRuleSeverity = Severity
severity, hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS = forall a. a -> HsExtendInstances a
extendInstances GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs, hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS = forall a. a -> HsExtendInstances a
extendInstances GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs, String
[Note]
Maybe (HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
Scope
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleScope :: Scope
hintRuleNotes :: [Note]
hintRuleName :: String
hintRuleScope :: Scope
hintRuleName :: String
hintRuleSide :: Maybe (HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
hintRuleNotes :: [Note]
..}
            forall a. a -> [a] -> [a]
: [forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Classify
Classify Severity
severity String
hintRuleName String
"" String
"" | Bool -> Bool
not Bool
isBuiltin]
     else do
        [String]
names <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"name" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Val -> Parser [String]
parseArrayString
        [(String, String)]
within <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"within" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String
"",String
"")]) (Val -> Parser [Val]
parseArray forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Val -> Parser [(String, String)]
parseWithin)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Classify
Classify Severity
severity String
n String
a String
b | (String
a,String
b) <- [(String, String)]
within, String
n <- [String
"" | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
names] forall a. [a] -> [a] -> [a]
++ [String]
names]

parseRestrict :: RestrictType -> Val -> Parser Restrict
parseRestrict :: RestrictType -> Val -> Parser Restrict
parseRestrict RestrictType
restrictType Val
v = do
    Maybe Val
def <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"default" Val
v
    case Maybe Val
def of
        Just Val
def -> do
            Bool
b <- Val -> Parser Bool
parseBool Val
def
            Val -> [String] -> Parser ()
allowFields Val
v [String
"default"]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RestrictType
-> Bool
-> [String]
-> [String]
-> Alt Maybe Bool
-> Alt Maybe RestrictImportStyle
-> Alt Maybe QualifiedStyle
-> [(String, String)]
-> RestrictIdents
-> Maybe String
-> Restrict
Restrict RestrictType
restrictType Bool
b [] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty [] RestrictIdents
NoRestrictIdents forall a. Maybe a
Nothing
        Maybe Val
Nothing -> do
            [String]
restrictName <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"name" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Val -> Parser [String]
parseArrayString
            [(String, String)]
restrictWithin <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"within" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String
"",String
"")]) (Val -> Parser [Val]
parseArray forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Val -> Parser [(String, String)]
parseWithin)
            [String]
restrictAs <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"as" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Val -> Parser [String]
parseArrayString
            Alt Maybe Bool
restrictAsRequired <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"asRequired" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)
maybeParse Val -> Parser Bool
parseBool
            Alt Maybe RestrictImportStyle
restrictImportStyle <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"importStyle" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Text, a)] -> Maybe Val -> Parser (Maybe a)
maybeParseEnum
              [ (Text
"qualified"          , RestrictImportStyle
ImportStyleQualified)
              , (Text
"unqualified"        , RestrictImportStyle
ImportStyleUnqualified)
              , (Text
"explicit"           , RestrictImportStyle
ImportStyleExplicit)
              , (Text
"explicitOrQualified", RestrictImportStyle
ImportStyleExplicitOrQualified)
              , (Text
"unrestricted"       , RestrictImportStyle
ImportStyleUnrestricted)
              ]
            Alt Maybe QualifiedStyle
restrictQualifiedStyle <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"qualifiedStyle" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Text, a)] -> Maybe Val -> Parser (Maybe a)
maybeParseEnum
              [ (Text
"pre"         , QualifiedStyle
QualifiedStylePre)
              , (Text
"post"        , QualifiedStyle
QualifiedStylePost)
              , (Text
"unrestricted", QualifiedStyle
QualifiedStyleUnrestricted)
              ]


            Maybe Val
restrictBadIdents <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"badidents" Val
v
            Maybe Val
restrictOnlyAllowedIdents <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"only" Val
v
            RestrictIdents
restrictIdents <-
                case (Maybe Val
restrictBadIdents, Maybe Val
restrictOnlyAllowedIdents) of
                    (Just Val
badIdents, Maybe Val
Nothing) -> [String] -> RestrictIdents
ForbidIdents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser [String]
parseArrayString Val
badIdents
                    (Maybe Val
Nothing, Just Val
onlyIdents) -> [String] -> RestrictIdents
OnlyIdents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Parser [String]
parseArrayString Val
onlyIdents
                    (Maybe Val
Nothing, Maybe Val
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RestrictIdents
NoRestrictIdents
                    (Maybe Val, Maybe Val)
_ -> forall a. Val -> String -> Parser a
parseFail Val
v String
"The following options are mutually exclusive: badidents, only"

            Maybe String
restrictMessage <- String -> Val -> Parser (Maybe Val)
parseFieldOpt String
"message" Val
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)
maybeParse Val -> Parser String
parseString
            Val -> [String] -> Parser ()
allowFields Val
v forall a b. (a -> b) -> a -> b
$
                [String
"name", String
"within", String
"message"] forall a. [a] -> [a] -> [a]
++
                if RestrictType
restrictType forall a. Eq a => a -> a -> Bool
== RestrictType
RestrictModule
                    then [String
"as", String
"asRequired", String
"importStyle", String
"qualifiedStyle", String
"badidents", String
"only"]
                    else []
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Restrict{restrictDefault :: Bool
restrictDefault=Bool
True,[String]
[(String, String)]
Maybe String
Alt Maybe Bool
Alt Maybe QualifiedStyle
Alt Maybe RestrictImportStyle
RestrictIdents
RestrictType
restrictMessage :: Maybe String
restrictIdents :: RestrictIdents
restrictWithin :: [(String, String)]
restrictQualifiedStyle :: Alt Maybe QualifiedStyle
restrictImportStyle :: Alt Maybe RestrictImportStyle
restrictAsRequired :: Alt Maybe Bool
restrictAs :: [String]
restrictName :: [String]
restrictType :: RestrictType
restrictMessage :: Maybe String
restrictIdents :: RestrictIdents
restrictQualifiedStyle :: Alt Maybe QualifiedStyle
restrictImportStyle :: Alt Maybe RestrictImportStyle
restrictAsRequired :: Alt Maybe Bool
restrictAs :: [String]
restrictWithin :: [(String, String)]
restrictName :: [String]
restrictType :: RestrictType
..}

parseWithin :: Val -> Parser [(String, String)] -- (module, decl)
parseWithin :: Val -> Parser [(String, String)]
parseWithin Val
v = do
    String
s <- Val -> Parser String
parseString Val
v
    if Char
'*' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String
s, String
"")]
        else do
            GenLocated SrcSpanAnnA (HsExpr GhcPs)
x <- forall v.
(ParseFlags -> String -> ParseResult v) -> Val -> Parser v
parseGHC ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode Val
v
            case GenLocated SrcSpanAnnA (HsExpr GhcPs)
x of
                L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ (Unqual OccName
x))) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> String -> [(String, String)]
f String
"" (OccName -> String
occNameString OccName
x)
                L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ (Qual ModuleName
mod OccName
x))) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> String -> [(String, String)]
f (ModuleName -> String
moduleNameString ModuleName
mod) (OccName -> String
occNameString OccName
x)
                GenLocated SrcSpanAnnA (HsExpr GhcPs)
_ -> forall a. Val -> String -> Parser a
parseFail Val
v String
"Bad classification rule"
            where
                f :: String -> String -> [(String, String)]
f String
mod name :: String
name@(Char
c:String
_) | Char -> Bool
isUpper Char
c = [(String
mod,String
name),(String
mod forall a. [a] -> [a] -> [a]
++ [Char
'.' | String
mod forall a. Eq a => a -> a -> Bool
/= String
""] forall a. [a] -> [a] -> [a]
++ String
name, String
"")]
                f String
mod String
name = [(String
mod, String
name)]

parseSeverityKey :: Val -> Parser (Severity, Val)
parseSeverityKey :: Val -> Parser (Severity, Val)
parseSeverityKey Val
v = do
    (String
s, Val
v) <- Val -> Parser (String, Val)
parseObject1 Val
v
    case String -> Maybe Severity
getSeverity String
s of
        Just Severity
sev -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Severity
sev, Val
v)
        Maybe Severity
_ -> forall a. Val -> String -> Parser a
parseFail Val
v forall a b. (a -> b) -> a -> b
$ String
"Key should be a severity (e.g. warn/error/suggest) but got " forall a. [a] -> [a] -> [a]
++ String
s


guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String
guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String
guessName LHsExpr GhcPs
lhs LHsExpr GhcPs
rhs
    | String
n:[String]
_ <- [String]
rs forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
ls = String
"Use " forall a. [a] -> [a] -> [a]
++ String
n
    | String
n:[String]
_ <- [String]
ls forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
rs = String
"Redundant " forall a. [a] -> [a] -> [a]
++ String
n
    | Bool
otherwise = String
defaultHintName
    where
        ([String]
ls, [String]
rs) = forall a b. (a -> b) -> (a, a) -> (b, b)
both LHsExpr GhcPs -> [String]
f (LHsExpr GhcPs
lhs, LHsExpr GhcPs
rhs)
        f :: LHsExpr GhcPs -> [String]
        f :: LHsExpr GhcPs -> [String]
f LHsExpr GhcPs
x = [String
y | L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
x)) <- forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x, let y :: String
y = RdrName -> String
occNameStr RdrName
x, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ String -> Bool
isUnifyVar String
y, String
y forall a. Eq a => a -> a -> Bool
/= String
"."]


asNote :: String -> Note
asNote :: String -> Note
asNote String
"IncreasesLaziness" = Note
IncreasesLaziness
asNote String
"DecreasesLaziness" = Note
DecreasesLaziness
asNote (String -> (String, String)
word1 -> (String
"RemovesError",String
x)) = String -> Note
RemovesError String
x
asNote (String -> (String, String)
word1 -> (String
"ValidInstance",String
x)) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Note
ValidInstance forall a b. (a -> b) -> a -> b
$ String -> (String, String)
word1 String
x
asNote (String -> (String, String)
word1 -> (String
"RequiresExtension",String
x)) = String -> Note
RequiresExtension String
x
asNote String
x = String -> Note
Note String
x


---------------------------------------------------------------------
-- SETTINGS

settingsFromConfigYaml :: [ConfigYaml] -> [Setting]
settingsFromConfigYaml :: [ConfigYaml] -> [Setting]
settingsFromConfigYaml (forall a. Monoid a => [a] -> a
mconcat -> ConfigYaml [ConfigItem]
configs) = [Setting]
settings forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Group -> [Setting]
f [Group]
groups
    where
        packages :: [Package]
packages = [Package
x | ConfigPackage Package
x <- [ConfigItem]
configs]
        groups :: [Group]
groups = [Group
x | ConfigGroup Group
x <- [ConfigItem]
configs]
        settings :: [Setting]
settings = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Setting]
x | ConfigSetting [Setting]
x <- [ConfigItem]
configs]
        packageMap' :: HashMap String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
packageMap' = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) [(String
packageName, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HsExtendInstances a -> a
unextendInstances [HsExtendInstances (LImportDecl GhcPs)]
packageModules) | Package{String
[HsExtendInstances (LImportDecl GhcPs)]
packageModules :: [HsExtendInstances (LImportDecl GhcPs)]
packageName :: String
packageModules :: Package -> [HsExtendInstances (LImportDecl GhcPs)]
packageName :: Package -> String
..} <- [Package]
packages]
        groupMap :: HashMap String Bool
groupMap = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith (\Bool
new Bool
old -> Bool
new) [(String
groupName, Bool
groupEnabled) | Group{Bool
String
[Either String (HsExtendInstances (LImportDecl GhcPs))]
[Either HintRule Classify]
groupRules :: [Either HintRule Classify]
groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupEnabled :: Bool
groupName :: String
groupRules :: Group -> [Either HintRule Classify]
groupImports :: Group -> [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupEnabled :: Group -> Bool
groupName :: Group -> String
..} <- [Group]
groups]

        f :: Group -> [Setting]
f Group{Bool
String
[Either String (HsExtendInstances (LImportDecl GhcPs))]
[Either HintRule Classify]
groupRules :: [Either HintRule Classify]
groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupEnabled :: Bool
groupName :: String
groupRules :: Group -> [Either HintRule Classify]
groupImports :: Group -> [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupEnabled :: Group -> Bool
groupName :: Group -> String
..}
            | forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup String
groupName HashMap String Bool
groupMap forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False = []
            | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\HintRule
r -> HintRule -> Setting
SettingMatchExp HintRule
r{hintRuleScope :: Scope
hintRuleScope=Scope
scope'}) Classify -> Setting
SettingClassify) [Either HintRule Classify]
groupRules
            where
              scope' :: Scope
scope'= HashMap String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [Either String (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
-> Scope
asScope' HashMap String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
packageMap' (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HsExtendInstances a -> a
unextendInstances) [Either String (HsExtendInstances (LImportDecl GhcPs))]
groupImports)

asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope
asScope' :: HashMap String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [Either String (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
-> Scope
asScope' HashMap String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
packages [Either String (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
xs = HsModule GhcPs -> Scope
scopeCreate (forall p.
XCModule p
-> Maybe (XRec p ModuleName)
-> Maybe (XRec p [LIE p])
-> [LImportDecl p]
-> [LHsDecl p]
-> HsModule p
HsModule (EpAnn AnnsModule
-> LayoutInfo GhcPs
-> Maybe (LocatedP (WarningTxt GhcPs))
-> Maybe (LHsDoc GhcPs)
-> XModulePs
XModulePs forall ann. EpAnn ann
EpAnnNotUsed forall pass. LayoutInfo pass
NoLayoutInfo forall a. Maybe a
Nothing forall a. Maybe a
Nothing) forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either String (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
f [Either String (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
xs) [])
    where
        f :: Either String (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
f (Right GenLocated SrcSpanAnnA (ImportDecl GhcPs)
x) = [GenLocated SrcSpanAnnA (ImportDecl GhcPs)
x]
        f (Left String
x) | Just [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
pkg <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup String
x HashMap String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
packages = [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
pkg
                   | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"asScope' failed to do lookup, " forall a. [a] -> [a] -> [a]
++ String
x