{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- | Given a file, guess settings from it by looking at the hints.
module Config.Compute(computeSettings) where

import GHC.All
import GHC.Util
import Config.Type
import Fixity
import Data.Generics.Uniplate.DataOnly
import GHC.Hs hiding (Warning)
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Data.Bag
import GHC.Types.SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Prelude


-- | Given a source file, guess some hints that might apply.
--   Returns the text of the hints (if you want to save it down) along with the settings to be used.
computeSettings :: ParseFlags -> FilePath -> IO (String, [Setting])
computeSettings :: ParseFlags -> String -> IO (String, [Setting])
computeSettings ParseFlags
flags String
file = do
    Either ParseError ModuleEx
x <- ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags String
file forall a. Maybe a
Nothing
    case Either ParseError ModuleEx
x of
        Left (ParseError SrcSpan
sl String
msg String
_) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"# Parse error " forall a. [a] -> [a] -> [a]
++ SrcSpan -> String
showSrcSpan SrcSpan
sl forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg, [])
        Right ModuleEx{ghcModule :: ModuleEx -> Located (HsModule GhcPs)
ghcModule=Located (HsModule GhcPs)
m} -> do
            let xs :: [Setting]
xs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LocatedA (HsDecl GhcPs) -> [Setting]
findSetting (forall p. HsModule p -> [LHsDecl p]
hsmodDecls forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
m)
                s :: String
s = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ [String
"# hints found in " forall a. [a] -> [a] -> [a]
++ String
file] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Setting -> [String]
renderSetting [Setting]
xs forall a. [a] -> [a] -> [a]
++ [String
"# no hints found" | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Setting]
xs]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
s,[Setting]
xs)


renderSetting :: Setting -> [String]
-- Only need to convert the subset of Setting we generate
renderSetting :: Setting -> [String]
renderSetting (SettingMatchExp HintRule{String
[Note]
Maybe (HsExtendInstances (LHsExpr GhcPs))
HsExtendInstances (LHsExpr GhcPs)
Scope
Severity
hintRuleSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: HintRule -> Scope
hintRuleNotes :: HintRule -> [Note]
hintRuleName :: HintRule -> String
hintRuleSeverity :: HintRule -> Severity
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: Scope
hintRuleNotes :: [Note]
hintRuleName :: String
hintRuleSeverity :: Severity
..}) =
    [String
"- warn: {lhs: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS) forall a. [a] -> [a] -> [a]
++ String
", rhs: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS) forall a. [a] -> [a] -> [a]
++ String
"}"]
renderSetting (Infix FixityInfo
x) =
    [String
"- fixity: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Outputable a => a -> String
unsafePrettyPrint forall a b. (a -> b) -> a -> b
$ FixityInfo -> FixitySig GhcPs
toFixitySig FixityInfo
x)]
renderSetting Setting
_ = []

findSetting :: LocatedA (HsDecl GhcPs) -> [Setting]
findSetting :: LocatedA (HsDecl GhcPs) -> [Setting]
findSetting (L SrcSpanAnnA
_ (ValD XValD GhcPs
_ HsBind GhcPs
x)) = HsBind GhcPs -> [Setting]
findBind HsBind GhcPs
x
findSetting (L SrcSpanAnnA
_ (InstD XInstD GhcPs
_ (ClsInstD XClsInstD GhcPs
_ ClsInstDecl{LHsBinds GhcPs
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds :: LHsBinds GhcPs
cid_binds}))) =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBind GhcPs -> [Setting]
findBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList LHsBinds GhcPs
cid_binds
findSetting (L SrcSpanAnnA
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ FixitySig GhcPs
x))) = 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
findSetting LocatedA (HsDecl GhcPs)
x = []


findBind :: HsBind GhcPs -> [Setting]
findBind :: HsBind GhcPs -> [Setting]
findBind VarBind{IdP GhcPs
var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id :: IdP GhcPs
var_id, LHsExpr GhcPs
var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs :: LHsExpr GhcPs
var_rhs} = IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
var_id [] forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
var_rhs
findBind FunBind{LIdP GhcPs
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id :: LIdP GhcPs
fun_id, MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches} = IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp (forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
fun_id) [] forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches
findBind HsBind GhcPs
_ = []

findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name [String]
vs (HsLam XLam GhcPs
_ MG{mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts=L SrcSpanAnnL
_ [L SrcSpanAnnA
_ Match{[LPat GhcPs]
m_pats :: forall p body. Match p body -> [LPat p]
m_pats :: [LPat GhcPs]
m_pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs=[L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
x)], grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds=(EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)}}]})
    = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
m_pats forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ps then IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name ([String]
vsforall a. [a] -> [a] -> [a]
++[String]
ps) forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
x else []
    where ps :: [String]
ps = [GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr LIdP GhcPs
x | L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
x) <- [LPat GhcPs]
m_pats]
findExp IdP GhcPs
name [String]
vs HsLam{} = []
findExp IdP GhcPs
name [String]
vs HsVar{} = []
findExp IdP GhcPs
name [String]
vs (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
dot LHsExpr GhcPs
y) | LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
dot = IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name ([String]
vsforall a. [a] -> [a] -> [a]
++[String
"_hlint"]) forall a b. (a -> b) -> a -> b
$
    forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
x forall a b. (a -> b) -> a -> b
$ forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
y forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ String -> HsExpr GhcPs
mkVar String
"_hlint"

findExp IdP GhcPs
name [String]
vs HsExpr GhcPs
bod = [HintRule -> Setting
SettingMatchExp forall a b. (a -> b) -> a -> b
$
        Severity
-> String
-> [Note]
-> Scope
-> HsExtendInstances (LHsExpr GhcPs)
-> HsExtendInstances (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
-> HintRule
HintRule Severity
Warning String
defaultHintName []
        forall a. Monoid a => a
mempty (forall a. a -> HsExtendInstances a
extendInstances GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs) (forall a. a -> HsExtendInstances a
extendInstances forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs) forall a. Maybe a
Nothing]
    where
        lhs :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall on. Uniplate on => (on -> on) -> on -> on
transform HsExpr GhcPs -> HsExpr GhcPs
f HsExpr GhcPs
bod
        rhs :: LHsExpr GhcPs
rhs = [LHsExpr GhcPs] -> LHsExpr GhcPs
apps forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA IdP GhcPs
name) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String, HsExpr GhcPs)]
rep

        rep :: [(String, HsExpr GhcPs)]
rep = forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> HsExpr GhcPs
mkVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Char
'a'..]
        f :: HsExpr GhcPs -> HsExpr GhcPs
f (HsVar XVar GhcPs
_ LIdP GhcPs
x) | Just HsExpr GhcPs
y <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr LIdP GhcPs
x) [(String, HsExpr GhcPs)]
rep = HsExpr GhcPs
y
        f (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
dol LHsExpr GhcPs
y) | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
dol = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
x forall a b. (a -> b) -> a -> b
$ forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar LHsExpr GhcPs
y
        f HsExpr GhcPs
x = HsExpr GhcPs
x


mkVar :: String -> HsExpr GhcPs
mkVar :: String -> HsExpr GhcPs
mkVar = forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Unqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc