{-# 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 Maybe String
forall a. Maybe a
Nothing
    case Either ParseError ModuleEx
x of
        Left (ParseError SrcSpan
sl String
msg String
_) ->
            (String, [Setting]) -> IO (String, [Setting])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"# Parse error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcSpan -> String
showSrcSpan SrcSpan
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg, [])
        Right ModuleEx{ghcModule :: ModuleEx -> Located HsModule
ghcModule=Located HsModule
m} -> do
            let xs :: [Setting]
xs = (LHsDecl GhcPs -> [Setting]) -> [LHsDecl GhcPs] -> [Setting]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [Setting]
findSetting (HsModule -> [LHsDecl GhcPs]
hsmodDecls (HsModule -> [LHsDecl GhcPs]) -> HsModule -> [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ Located HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc Located HsModule
m)
                s :: String
s = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String
"# hints found in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Setting -> [String]) -> [Setting] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Setting -> [String]
renderSetting [Setting]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"# no hints found" | [Setting] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Setting]
xs]
            (String, [Setting]) -> IO (String, [Setting])
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (HsExtendInstances (LHsExpr GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", rhs: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (HsExtendInstances (LHsExpr GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"]
renderSetting (Infix FixityInfo
x) =
    [String
"- fixity: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (FixitySig GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (FixitySig GhcPs -> String) -> FixitySig GhcPs -> String
forall a b. (a -> b) -> a -> b
$ FixityInfo -> FixitySig GhcPs
toFixitySig FixityInfo
x)]
renderSetting Setting
_ = []

findSetting :: LHsDecl GhcPs -> [Setting]
findSetting :: LHsDecl GhcPs -> [Setting]
findSetting (L SrcSpan
_ (ValD XValD GhcPs
_ HsBind GhcPs
x)) = HsBind GhcPs -> [Setting]
findBind HsBind GhcPs
x
findSetting (L SrcSpan
_ (InstD XInstD GhcPs
_ (ClsInstD XClsInstD GhcPs
_ ClsInstDecl{LHsBinds GhcPs
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds :: LHsBinds GhcPs
cid_binds}))) =
    (GenLocated SrcSpan (HsBind GhcPs) -> [Setting])
-> [GenLocated SrcSpan (HsBind GhcPs)] -> [Setting]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBind GhcPs -> [Setting]
findBind (HsBind GhcPs -> [Setting])
-> (GenLocated SrcSpan (HsBind GhcPs) -> HsBind GhcPs)
-> GenLocated SrcSpan (HsBind GhcPs)
-> [Setting]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (HsBind GhcPs) -> HsBind GhcPs
forall l e. GenLocated l e -> e
unLoc) ([GenLocated SrcSpan (HsBind GhcPs)] -> [Setting])
-> [GenLocated SrcSpan (HsBind GhcPs)] -> [Setting]
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcPs -> [GenLocated SrcSpan (HsBind GhcPs)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcPs
cid_binds
findSetting (L SrcSpan
_ (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ FixitySig GhcPs
x))) = (FixityInfo -> Setting) -> [FixityInfo] -> [Setting]
forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> Setting
Infix ([FixityInfo] -> [Setting]) -> [FixityInfo] -> [Setting]
forall a b. (a -> b) -> a -> b
$ FixitySig GhcPs -> [FixityInfo]
fromFixitySig FixitySig GhcPs
x
findSetting LHsDecl 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 [] (HsExpr GhcPs -> [Setting]) -> HsExpr GhcPs -> [Setting]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
var_rhs
findBind FunBind{Located (IdP GhcPs)
fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id :: Located (IdP 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 (GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located (IdP GhcPs)
GenLocated SrcSpan RdrName
fun_id) [] (HsExpr GhcPs -> [Setting]) -> HsExpr GhcPs -> [Setting]
forall a b. (a -> b) -> a -> b
$ XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcPs
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 -> Located [LMatch p body]
mg_alts=L SrcSpan
_ [L SrcSpan
_ 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 SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [] LHsExpr GhcPs
x)], grhssLocalBinds :: forall p body. GRHSs p body -> LHsLocalBinds p
grhssLocalBinds=L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)}}]})
    = if [Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
[Located (Pat GhcPs)]
m_pats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ps then IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name ([String]
vs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
ps) (HsExpr GhcPs -> [Setting]) -> HsExpr GhcPs -> [Setting]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
x else []
    where ps :: [String]
ps = [GenLocated SrcSpan RdrName -> String
rdrNameStr Located (IdP GhcPs)
GenLocated SrcSpan RdrName
x | L SrcSpan
_ (VarPat XVarPat GhcPs
_ Located (IdP GhcPs)
x) <- [LPat GhcPs]
[Located (Pat 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]
vs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
"_hlint"]) (HsExpr GhcPs -> [Setting]) -> HsExpr GhcPs -> [Setting]
forall a b. (a -> b) -> a -> b
$
    XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
NoExtField
noExtField LHsExpr GhcPs
x (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExtField
noExtField (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
NoExtField
noExtField LHsExpr GhcPs
y (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
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 (HintRule -> Setting) -> HintRule -> Setting
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 []
        Scope
forall a. Monoid a => a
mempty (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
lhs) (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
rhs) Maybe (HsExtendInstances (LHsExpr GhcPs))
forall a. Maybe a
Nothing]
    where
        lhs :: LHsExpr GhcPs
lhs = LHsExpr GhcPs -> LHsExpr GhcPs
fromParen (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (HsExpr GhcPs -> HsExpr GhcPs) -> HsExpr GhcPs -> HsExpr GhcPs
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 ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (HsExpr GhcPs -> LHsExpr GhcPs)
-> [HsExpr GhcPs] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc ([HsExpr GhcPs] -> [LHsExpr GhcPs])
-> [HsExpr GhcPs] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (RdrName -> GenLocated SrcSpan RdrName
forall e. e -> Located e
noLoc IdP GhcPs
RdrName
name) HsExpr GhcPs -> [HsExpr GhcPs] -> [HsExpr GhcPs]
forall a. a -> [a] -> [a]
: ((String, HsExpr GhcPs) -> HsExpr GhcPs)
-> [(String, HsExpr GhcPs)] -> [HsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (String, HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a, b) -> b
snd [(String, HsExpr GhcPs)]
rep

        rep :: [(String, HsExpr GhcPs)]
rep = [String] -> [HsExpr GhcPs] -> [(String, HsExpr GhcPs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vs ([HsExpr GhcPs] -> [(String, HsExpr GhcPs)])
-> [HsExpr GhcPs] -> [(String, HsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ (Char -> HsExpr GhcPs) -> String -> [HsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (String -> HsExpr GhcPs
mkVar (String -> HsExpr GhcPs)
-> (Char -> String) -> Char -> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Char
'a'..]
        f :: HsExpr GhcPs -> HsExpr GhcPs
f (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x) | Just HsExpr GhcPs
y <- String -> [(String, HsExpr GhcPs)] -> Maybe (HsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (GenLocated SrcSpan RdrName -> String
rdrNameStr Located (IdP GhcPs)
GenLocated SrcSpan RdrName
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 = XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
NoExtField
noExtField LHsExpr GhcPs
x (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExtField
noExtField LHsExpr GhcPs
y
        f HsExpr GhcPs
x = HsExpr GhcPs
x


mkVar :: String -> HsExpr GhcPs
mkVar :: String -> HsExpr GhcPs
mkVar = XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (GenLocated SrcSpan RdrName -> HsExpr GhcPs)
-> (String -> GenLocated SrcSpan RdrName) -> String -> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpan RdrName
forall e. e -> Located e
noLoc (RdrName -> GenLocated SrcSpan RdrName)
-> (String -> RdrName) -> String -> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Unqual (OccName -> RdrName) -> (String -> OccName) -> String -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc