{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Config.Compute(computeSettings) where
import HSE.All
import GHC.Util
import Config.Type
import Fixity
import Data.Generics.Uniplate.Data
import GHC.Hs hiding (Warning)
import RdrName
import Name
import Bag
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import SrcLoc
import Prelude
computeSettings :: ParseFlags -> FilePath -> IO (String, [Setting])
computeSettings flags file = do
x <- parseModuleEx flags file Nothing
case x of
Left (ParseError sl msg _) ->
pure ("# Parse error " ++ showSrcSpan' sl ++ ": " ++ msg, [])
Right ModuleEx{ghcModule=m} -> do
let xs = concatMap findSetting (hsmodDecls $ unLoc m)
s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting xs ++ ["# no hints found" | null xs]
pure (s,xs)
renderSetting :: Setting -> [String]
renderSetting (SettingMatchExp HintRule{..}) =
["- warn: {lhs: " ++ show (unsafePrettyPrint hintRuleLHS) ++ ", rhs: " ++ show (unsafePrettyPrint hintRuleRHS) ++ "}"]
renderSetting (Infix x) =
["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)]
renderSetting _ = []
findSetting :: LHsDecl GhcPs -> [Setting]
findSetting (L _ (ValD _ x)) = findBind x
findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
concatMap (findBind . unLoc) $ bagToList cid_binds
findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x
findSetting x = []
findBind :: HsBind GhcPs -> [Setting]
findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs
findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches
findBind _ = []
findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]})
= if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
where ps = [occNameString $ occName $ unLoc x | L _ (VarPat _ x) <- m_pats]
findExp name vs HsLam{} = []
findExp name vs HsVar{} = []
findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint"
findExp name vs bod = [SettingMatchExp $
HintRule Warning defaultHintName []
mempty (extendInstances lhs) (extendInstances $ fromParen' rhs) Nothing]
where
lhs = fromParen' $ noLoc $ transform f bod
rhs = apps' $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep
rep = zip vs $ map (mkVar . pure) ['a'..]
f (HsVar _ x) | Just y <- lookup (occNameString $ occName $ unLoc x) rep = y
f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y
f x = x
mkVar :: String -> HsExpr GhcPs
mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc