{-# 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 -> FilePath -> IO (FilePath, [Setting])
computeSettings ParseFlags
flags FilePath
file = do
    Either ParseError ModuleEx
x <- ParseFlags
-> FilePath -> Maybe FilePath -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags FilePath
file Maybe FilePath
forall a. Maybe a
Nothing
    case Either ParseError ModuleEx
x of
        Left (ParseError SrcSpan
sl FilePath
msg FilePath
_) ->
            (FilePath, [Setting]) -> IO (FilePath, [Setting])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
"# Parse error " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SrcSpan -> FilePath
showSrcSpan SrcSpan
sl FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 :: FilePath
s = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath
"# hints found in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (Setting -> [FilePath]) -> [Setting] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Setting -> [FilePath]
renderSetting [Setting]
xs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"# no hints found" | [Setting] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Setting]
xs]
            (FilePath, [Setting]) -> IO (FilePath, [Setting])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
s,[Setting]
xs)


renderSetting :: Setting -> [String]
-- Only need to convert the subset of Setting we generate
renderSetting :: Setting -> [FilePath]
renderSetting (SettingMatchExp HintRule{FilePath
[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 -> FilePath
hintRuleSeverity :: HintRule -> Severity
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: Scope
hintRuleNotes :: [Note]
hintRuleName :: FilePath
hintRuleSeverity :: Severity
..}) =
    [FilePath
"- warn: {lhs: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (HsExtendInstances (LHsExpr GhcPs) -> FilePath
forall a. Outputable a => a -> FilePath
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", rhs: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (HsExtendInstances (LHsExpr GhcPs) -> FilePath
forall a. Outputable a => a -> FilePath
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"}"]
renderSetting (Infix FixityInfo
x) =
    [FilePath
"- fixity: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (FixitySig GhcPs -> FilePath
forall a. Outputable a => a -> FilePath
unsafePrettyPrint (FixitySig GhcPs -> FilePath) -> FixitySig GhcPs -> FilePath
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 -> [FilePath] -> 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 -> [FilePath] -> 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 NoExtField
XLam GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches
findBind HsBind GhcPs
_ = []

findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp :: IdP GhcPs -> [FilePath] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name [FilePath]
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
== [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
ps then IdP GhcPs -> [FilePath] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name ([FilePath]
vs[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++[FilePath]
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 :: [FilePath]
ps = [GenLocated SrcSpan RdrName -> FilePath
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 [FilePath]
vs HsLam{} = []
findExp IdP GhcPs
name [FilePath]
vs HsVar{} = []
findExp IdP GhcPs
name [FilePath]
vs (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
dot LHsExpr GhcPs
y) | LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
dot = IdP GhcPs -> [FilePath] -> HsExpr GhcPs -> [Setting]
findExp IdP GhcPs
name ([FilePath]
vs[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++[FilePath
"_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 NoExtField
XApp GhcPs
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 NoExtField
XPar GhcPs
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 NoExtField
XApp GhcPs
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
$ FilePath -> HsExpr GhcPs
mkVar FilePath
"_hlint"

findExp IdP GhcPs
name [FilePath]
vs HsExpr GhcPs
bod = [HintRule -> Setting
SettingMatchExp (HintRule -> Setting) -> HintRule -> Setting
forall a b. (a -> b) -> a -> b
$
        Severity
-> FilePath
-> [Note]
-> Scope
-> HsExtendInstances (LHsExpr GhcPs)
-> HsExtendInstances (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
-> HintRule
HintRule Severity
Warning FilePath
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 NoExtField
XVar GhcPs
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]
: ((FilePath, HsExpr GhcPs) -> HsExpr GhcPs)
-> [(FilePath, HsExpr GhcPs)] -> [HsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a, b) -> b
snd [(FilePath, HsExpr GhcPs)]
rep

        rep :: [(FilePath, HsExpr GhcPs)]
rep = [FilePath] -> [HsExpr GhcPs] -> [(FilePath, HsExpr GhcPs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
vs ([HsExpr GhcPs] -> [(FilePath, HsExpr GhcPs)])
-> [HsExpr GhcPs] -> [(FilePath, HsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ (Char -> HsExpr GhcPs) -> FilePath -> [HsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> HsExpr GhcPs
mkVar (FilePath -> HsExpr GhcPs)
-> (Char -> FilePath) -> Char -> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath
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 <- FilePath -> [(FilePath, HsExpr GhcPs)] -> Maybe (HsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (GenLocated SrcSpan RdrName -> FilePath
rdrNameStr Located (IdP GhcPs)
GenLocated SrcSpan RdrName
x) [(FilePath, 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 NoExtField
XApp GhcPs
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 NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
y
        f HsExpr GhcPs
x = HsExpr GhcPs
x


mkVar :: String -> HsExpr GhcPs
mkVar :: FilePath -> HsExpr GhcPs
mkVar = XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (GenLocated SrcSpan RdrName -> HsExpr GhcPs)
-> (FilePath -> GenLocated SrcSpan RdrName)
-> FilePath
-> 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)
-> (FilePath -> RdrName) -> FilePath -> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Unqual (OccName -> RdrName)
-> (FilePath -> OccName) -> FilePath -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OccName
mkVarOcc