{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
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
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]
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