{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}
module Config.Yaml(
ConfigYaml,
readFileConfigYaml,
settingsFromConfigYaml
) where
import Config.Type
import Data.Yaml
import Data.Either
import Data.Maybe
import Data.List.Extra
import Data.Tuple.Extra
import Control.Monad.Extra
import Control.Exception.Extra
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as Map
import Data.Generics.Uniplate.Data
import HSE.All
import Fixity
import Extension
import Module
import Data.Functor
import Data.Semigroup
import Timing
import Prelude
import Bag
import qualified Lexer as GHC
import qualified ErrUtils
import qualified Outputable
import GHC.Hs
import SrcLoc
import qualified RdrName as GHC
import qualified OccName as GHC
import GHC.Util (baseDynFlags, Scope,scopeCreate)
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Data.Char
readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml
readFileConfigYaml file contents = timedIO "Config" file $ do
val <- case contents of
Nothing -> decodeFileEither file
Just src -> pure $ decodeEither' $ BS.pack src
case val of
Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n " ++ displayException e
Right v -> pure v
newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (Semigroup,Monoid,Show)
data ConfigItem
= ConfigPackage Package
| ConfigGroup Group
| ConfigSetting [Setting]
deriving Show
data Package = Package
{packageName :: String
,packageModules :: [HsExtendInstances (LImportDecl GhcPs)]
} deriving Show
data Group = Group
{groupName :: String
,groupEnabled :: Bool
,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]
,groupRules :: [Either HintRule Classify]
} deriving Show
data Val = Val
Value
[(String, Value)]
newVal :: Value -> Val
newVal x = Val x [("root", x)]
getVal :: Val -> Value
getVal (Val x _) = x
addVal :: String -> Value -> Val -> Val
addVal key v (Val focus path) = Val v $ (key,v) : path
parseFail :: Val -> String -> Parser a
parseFail (Val focus path) msg = fail $
"Error when decoding YAML, " ++ msg ++ "\n" ++
"Along path: " ++ unwords steps ++ "\n" ++
"When at: " ++ fst (word1 $ show focus) ++ "\n" ++
dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts)
where
(steps, contexts) = unzip $ reverse path
dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...")
parseArray :: Val -> Parser [Val]
parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWithFrom (\i x -> addVal (show i) x v) 0 $ V.toList xs
parseArray v = pure [v]
parseObject :: Val -> Parser (Map.HashMap T.Text Value)
parseObject (getVal -> Object x) = pure x
parseObject v = parseFail v "Expected an Object"
parseObject1 :: Val -> Parser (String, Val)
parseObject1 v = do
mp <- parseObject v
case Map.keys mp of
[T.unpack -> s] -> (s,) <$> parseField s v
_ -> parseFail v $ "Expected exactly one key but got " ++ show (Map.size mp)
parseString :: Val -> Parser String
parseString (getVal -> String x) = pure $ T.unpack x
parseString v = parseFail v "Expected a String"
parseInt :: Val -> Parser Int
parseInt (getVal -> s@Number{}) = parseJSON s
parseInt v = parseFail v "Expected an Int"
parseArrayString :: Val -> Parser [String]
parseArrayString = parseArray >=> mapM parseString
maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)
maybeParse parseValue Nothing = pure Nothing
maybeParse parseValue (Just value) = Just <$> parseValue value
parseBool :: Val -> Parser Bool
parseBool (getVal -> Bool b) = pure b
parseBool v = parseFail v "Expected a Bool"
parseField :: String -> Val -> Parser Val
parseField s v = do
x <- parseFieldOpt s v
case x of
Nothing -> parseFail v $ "Expected a field named " ++ s
Just v -> pure v
parseFieldOpt :: String -> Val -> Parser (Maybe Val)
parseFieldOpt s v = do
mp <- parseObject v
case Map.lookup (T.pack s) mp of
Nothing -> pure Nothing
Just x -> pure $ Just $ addVal s x v
allowFields :: Val -> [String] -> Parser ()
allowFields v allow = do
mp <- parseObject v
let bad = map T.unpack (Map.keys mp) \\ allow
when (bad /= []) $
parseFail v $ "Not allowed keys: " ++ unwords bad
parseGHC :: (ParseFlags -> String -> GHC.ParseResult v) -> Val -> Parser v
parseGHC parser v = do
x <- parseString v
case parser defaultParseFlags{extensions=configExtensions} x of
GHC.POk _ x -> pure x
GHC.PFailed ps ->
let (_, errs) = GHC.getMessages ps baseDynFlags
errMsg = head (bagToList errs)
msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg
in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
instance FromJSON ConfigYaml where
parseJSON Null = pure mempty
parseJSON x = parseConfigYaml $ newVal x
parseConfigYaml :: Val -> Parser ConfigYaml
parseConfigYaml v = do
vs <- parseArray v
fmap ConfigYaml $ forM vs $ \o -> do
(s, v) <- parseObject1 o
case s of
"package" -> ConfigPackage <$> parsePackage v
"group" -> ConfigGroup <$> parseGroup v
"arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v
"fixity" -> ConfigSetting <$> parseFixity v
"smell" -> ConfigSetting <$> parseSmell v
_ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o
_ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r))
_ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction"
parsePackage :: Val -> Parser Package
parsePackage v = do
packageName <- parseField "name" v >>= parseString
packageModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode)
allowFields v ["name","modules"]
pure Package{..}
parseFixity :: Val -> Parser [Setting]
parseFixity v = parseArray v >>= concatMapM (parseGHC parseDeclGhcWithMode >=> f)
where
f (L _ (SigD _ (FixSig _ x))) = pure $ map Infix $ fromFixitySig x
f _ = parseFail v "Expected fixity declaration"
parseSmell :: Val -> Parser [Setting]
parseSmell v = do
smellName <- parseField "type" v >>= parseString
smellType <- require v "Expected SmellType" $ getSmellType smellName
smellLimit <- parseField "limit" v >>= parseInt
pure [SettingSmell smellType smellLimit]
where
require :: Val -> String -> Maybe a -> Parser a
require _ _ (Just a) = pure a
require val err Nothing = parseFail val err
parseGroup :: Val -> Parser Group
parseGroup v = do
groupName <- parseField "name" v >>= parseString
groupEnabled <- parseFieldOpt "enabled" v >>= maybe (pure True) parseBool
groupImports <- parseFieldOpt "imports" v >>= maybe (pure []) (parseArray >=> mapM parseImport)
groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM parseRule
allowFields v ["name","enabled","imports","rules"]
pure Group{..}
where
parseImport v = do
x <- parseString v
case word1 x of
("package", x) -> pure $ Left x
_ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v
ruleToGroup :: [Either HintRule Classify] -> Group
ruleToGroup = Group "" True []
parseRule :: Val -> Parser [Either HintRule Classify]
parseRule v = do
(severity, v) <- parseSeverityKey v
isRule <- isJust <$> parseFieldOpt "lhs" v
if isRule then do
hintRuleNotes <- parseFieldOpt "note" v >>= maybe (pure []) (fmap (map asNote) . parseArrayString)
lhs <- parseField "lhs" v >>= parseGHC parseExpGhcWithMode
rhs <- parseField "rhs" v >>= parseGHC parseExpGhcWithMode
hintRuleSide <- parseFieldOpt "side" v >>= maybe (pure Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode)
hintRuleName <- parseFieldOpt "name" v >>= maybe (pure $ guessName lhs rhs) parseString
allowFields v ["lhs","rhs","note","name","side"]
let hintRuleScope = mempty
pure [Left HintRule{hintRuleSeverity=severity,hintRuleLHS=extendInstances lhs,hintRuleRHS=extendInstances rhs, ..}]
else do
names <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString
within <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)
pure [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names]
parseRestrict :: RestrictType -> Val -> Parser Restrict
parseRestrict restrictType v = do
def <- parseFieldOpt "default" v
case def of
Just def -> do
b <- parseBool def
allowFields v ["default"]
pure $ Restrict restrictType b [] [] [] [] Nothing
Nothing -> do
restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString
restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)
restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString
restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString
restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString
allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"]
pure Restrict{restrictDefault=True,..}
parseWithin :: Val -> Parser [(String, String)]
parseWithin v = do
x <- parseGHC parseExpGhcWithMode v
case x of
L _ (HsVar _ (L _ (GHC.Unqual x))) -> pure $ f "" (GHC.occNameString x)
L _ (HsVar _ (L _ (GHC.Qual mod x))) -> pure $ f (moduleNameString mod) (GHC.occNameString x)
_ -> parseFail v "Bad classification rule"
where
f mod name@(c:_) | isUpper c = [(mod,name),(mod ++ ['.' | mod /= ""] ++ name, "")]
f mod name = [(mod, name)]
parseSeverityKey :: Val -> Parser (Severity, Val)
parseSeverityKey v = do
(s, v) <- parseObject1 v
case getSeverity s of
Just sev -> pure (sev, v)
_ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s
guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String
guessName lhs rhs
| n:_ <- rs \\ ls = "Use " ++ n
| n:_ <- ls \\ rs = "Redundant " ++ n
| otherwise = defaultHintName
where
(ls, rs) = both f (lhs, rhs)
f :: LHsExpr GhcPs -> [String]
f x = [y | L _ (HsVar _ (L _ x)) <- universe x, let y = GHC.occNameString $ GHC.rdrNameOcc x, not $ isUnifyVar y, y /= "."]
asNote :: String -> Note
asNote "IncreasesLaziness" = IncreasesLaziness
asNote "DecreasesLaziness" = DecreasesLaziness
asNote (word1 -> ("RemovesError",x)) = RemovesError x
asNote (word1 -> ("ValidInstance",x)) = uncurry ValidInstance $ word1 x
asNote (word1 -> ("RequiresExtension",x)) = RequiresExtension x
asNote x = Note x
settingsFromConfigYaml :: [ConfigYaml] -> [Setting]
settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f groups
where
packages = [x | ConfigPackage x <- configs]
groups = [x | ConfigGroup x <- configs]
settings = concat [x | ConfigSetting x <- configs]
packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageModules) | Package{..} <- packages]
groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups]
f Group{..}
| Map.lookup groupName groupMap == Just False = []
| otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope'}) SettingClassify) groupRules
where
scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports)
asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope
asScope' packages xs = scopeCreate (HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)
where
f (Right x) = [x]
f (Left x) | Just pkg <- Map.lookup x packages = pkg
| otherwise = error $ "asScope' failed to do lookup, " ++ x