{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-}
module Hint.Match(readMatch') where
import Hint.Type (ModuleEx,Idea,idea',ideaNote,toSS')
import Util
import Timing
import qualified Data.Set as Set
import qualified Refact.Types as R
import Control.Monad
import Data.Tuple.Extra
import Data.Maybe
import Config.Type
import Data.Generics.Uniplate.Operations
import Bag
import GHC.Hs
import SrcLoc
import BasicTypes
import RdrName
import OccName
import Data.Data
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
readMatch' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch' settings = findIdeas' (concatMap readRule' settings)
readRule' :: HintRule -> [HintRule]
readRule' m@HintRule{ hintRuleLHS=(stripLocs' . unextendInstances -> hintRuleLHS)
, hintRuleRHS=(stripLocs' . unextendInstances -> hintRuleRHS)
, hintRuleSide=((stripLocs' . unextendInstances <$>) -> hintRuleSide)
} =
(:) m{ hintRuleLHS=extendInstances hintRuleLHS
, hintRuleRHS=extendInstances hintRuleRHS
, hintRuleSide=extendInstances <$> hintRuleSide } $ do
(l, v1) <- dotVersion' hintRuleLHS
(r, v2) <- dotVersion' hintRuleRHS
guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleSide ++ l ++ r))
if not (null r) then
[ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (dotApps' r), hintRuleSide=extendInstances <$> hintRuleSide }
, m{ hintRuleLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleSide=extendInstances <$> hintRuleSide } ]
else if length l > 1 then
[ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (strToVar "id"), hintRuleSide=extendInstances <$> hintRuleSide }
, m{ hintRuleLHS=extendInstances (dotApps' (l++[strToVar v1])), hintRuleRHS=extendInstances (strToVar v1), hintRuleSide=extendInstances <$> hintRuleSide}]
else []
dotVersion' :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion' (view' -> Var_' v) | isUnifyVar v = [([], v)]
dotVersion' (L _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs)
dotVersion' (L l (OpApp _ x op y)) =
let lSec = addParen' (cL l (SectionL noExtField x op))
rSec = addParen' (cL l (SectionR noExtField op y))
in (first (lSec :) <$> dotVersion' y) ++ (first (rSec :) <$> dotVersion' x)
dotVersion' _ = []
findIdeas' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas' matches s _ decl = timed "Hint" "Match apply" $ forceList
[ (idea' (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}
| (name, expr) <- findDecls' decl
, (parent,x) <- universeParentExp' expr
, m <- matches, Just (y, tpl, notes, subst) <- [matchIdea' s name m parent x]
, let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint tpl)
]
findDecls' :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
findDecls' x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
[(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs]
findDecls' (L _ RuleD{}) = []
findDecls' x = map (fromMaybe "" $ declName x,) $ childrenBi x
matchIdea' :: Scope
-> String
-> HintRule
-> Maybe (Int, LHsExpr GhcPs)
-> LHsExpr GhcPs
-> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, R.SrcSpan)])
matchIdea' sb declName HintRule{..} parent x = do
let lhs = unextendInstances hintRuleLHS
rhs = unextendInstances hintRuleRHS
sa = hintRuleScope
nm a b = scopeMatch (sa, a) (sb, b)
(u, extra) <- unifyExp nm True lhs x
u <- validSubst' astEq u
let rhs' | Just fun <- extra = rebracket1' $ noLoc (HsApp noExtField fun rhs)
| otherwise = rhs
(e, tpl) = substitute' u rhs'
noParens = [varToStr $ fromParen' x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]
u <- pure (removeParens noParens u)
let res = addBracketTy' (addBracket' parent $ performSpecial' $ fst $ substitute' u $ unqualify' sa sb rhs')
guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs')) `Set.isSubsetOf` freeVars' x
guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x)
guard $ checkSide' (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst' u
guard $ checkDefine' declName parent res
(u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst' u) then (mempty, res) else (u, tpl)
tpl <- pure $ unqualify' sa sb (performSpecial' tpl)
pure (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])
checkSide' :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide' x bind = maybe True bool x
where
bool :: LHsExpr GhcPs -> Bool
bool (L _ (OpApp _ x op y))
| varToStr op == "&&" = bool x && bool y
| varToStr op == "||" = bool x || bool y
| varToStr op == "==" = expr (fromParen1' x) `astEq` expr (fromParen1' y)
bool (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y
bool (L _ (HsPar _ x)) = bool x
bool (L _ (HsApp _ cond (sub -> y)))
| 'i' : 's' : typ <- varToStr cond = isType typ y
bool (L _ (HsApp _ (L _ (HsApp _ cond (sub -> x))) (sub -> y)))
| varToStr cond == "notIn" = and [extendInstances (stripLocs' x) `notElem` map (extendInstances . stripLocs') (universe y) | x <- list x, y <- list y]
| varToStr cond == "notEq" = not (x `astEq` y)
bool x | varToStr x == "noTypeCheck" = True
bool x | varToStr x == "noQuickCheck" = True
bool x = error $ "Hint.Match.checkSide', unknown side condition: " ++ unsafePrettyPrint x
expr :: LHsExpr GhcPs -> LHsExpr GhcPs
expr (L _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1' x
expr x = x
isType "Compare" x = True
isType "Atom" x = isAtom' x
isType "WHNF" x = isWHNF x
isType "Wildcard" x = any isFieldPun (universeBi x) || any hasFieldsDotDot (universeBi x)
isType "Nat" (asInt -> Just x) | x >= 0 = True
isType "Pos" (asInt -> Just x) | x > 0 = True
isType "Neg" (asInt -> Just x) | x < 0 = True
isType "NegZero" (asInt -> Just x) | x <= 0 = True
isType "LitInt" (L _ (HsLit _ HsInt{})) = True
isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True
isType "Var" (L _ HsVar{}) = True
isType "App" (L _ HsApp{}) = True
isType "InfixApp" (L _ x@OpApp{}) = True
isType "Paren" (L _ x@HsPar{}) = True
isType "Tuple" (L _ ExplicitTuple{}) = True
isType typ (L _ x) =
let top = showConstr (toConstr x) in
typ == top
asInt :: LHsExpr GhcPs -> Maybe Integer
asInt (L _ (HsPar _ x)) = asInt x
asInt (L _ (NegApp _ x _)) = negate <$> asInt x
asInt (L _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x
asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x
asInt _ = Nothing
list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
list (L _ (ExplicitList _ _ xs)) = xs
list x = [x]
sub :: LHsExpr GhcPs -> LHsExpr GhcPs
sub = transform f
where f (view' -> Var_' x) | Just y <- lookup x bind = y
f x = x
checkDefine' :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
checkDefine' declName Nothing y =
let funOrOp expr = case expr of
L _ (HsApp _ fun _) -> funOrOp fun
L _ (OpApp _ _ op _) -> funOrOp op
other -> other
in declName /= varToStr (transformBi unqual' $ funOrOp y)
checkDefine' _ _ _ = True
performSpecial' :: LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial' = transform fNoParen
where
fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fNoParen (L _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x
fNoParen x = x
unqualify' :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs
unqualify' from to = transformBi f
where
f :: Located RdrName -> Located RdrName
f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x
f x = scopeMove (from, x) to
addBracket' :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
addBracket' (Just (i, p)) c | needBracketOld' i p c = noLoc $ HsPar noExtField c
addBracket' _ x = x
addBracketTy' :: LHsExpr GhcPs -> LHsExpr GhcPs
addBracketTy'= transformBi f
where
f :: LHsType GhcPs -> LHsType GhcPs
f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =
noLoc (HsAppTy noExtField t (noLoc (HsParTy noExtField x)))
f x = x