{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards, FlexibleContexts, ScopedTypeVariables #-}
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 HsSyn
import SrcLoc
import BasicTypes
import RdrName
import OccName
import Data.Data
import GHC.Util
readMatch' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch' settings = findIdeas' (concatMap readRule' settings)
readRule' :: HintRule -> [HintRule]
readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unwrap -> hintRuleGhcLHS)
, hintRuleGhcRHS=(stripLocs' . unwrap -> hintRuleGhcRHS)
, hintRuleGhcSide=((stripLocs' . unwrap <$>) -> hintRuleGhcSide)
} =
(:) m{ hintRuleGhcLHS=wrap hintRuleGhcLHS
, hintRuleGhcRHS=wrap hintRuleGhcRHS
, hintRuleGhcSide=wrap <$> hintRuleGhcSide } $ do
(l, v1) <- dotVersion' hintRuleGhcLHS
(r, v2) <- dotVersion' hintRuleGhcRHS
guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleGhcSide ++ l ++ r))
if not (null r) then
[ m{ hintRuleGhcLHS=wrap (dotApps' l), hintRuleGhcRHS=wrap (dotApps' r), hintRuleGhcSide=wrap <$> hintRuleGhcSide }
, m{ hintRuleGhcLHS=wrap (dotApps' (l ++ [strToVar' v1])), hintRuleGhcRHS=wrap (dotApps' (r ++ [strToVar' v1])), hintRuleGhcSide=wrap <$> hintRuleGhcSide } ]
else if length l > 1 then
[ m{ hintRuleGhcLHS=wrap (dotApps' l), hintRuleGhcRHS=wrap (strToVar' "id"), hintRuleGhcSide=wrap <$> hintRuleGhcSide }
, m{ hintRuleGhcLHS=wrap (dotApps' (l++[strToVar' v1])), hintRuleGhcRHS=wrap (strToVar' v1), hintRuleGhcSide=wrap <$> hintRuleGhcSide}]
else []
dotVersion' :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion' (view' -> Var_' v) | isUnifyVar v = [([], v)]
dotVersion' (LL _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs)
dotVersion' (LL l (OpApp _ x op y)) =
let lSec = addParen' (cL l (SectionL noExt x op))
rSec = addParen' (cL l (SectionR noExt 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}
| decl <- findDecls' decl
, (parent,x) <- universeParentExp' decl
, m <- matches, Just (y, notes, subst) <- [matchIdea' s decl m parent x]
, let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint $ unwrap (hintRuleGhcRHS m))
]
findDecls' :: LHsDecl GhcPs -> [LHsDecl GhcPs]
findDecls' x@(LL _ InstD{}) = children x
findDecls' (LL _ RuleD{}) = []
findDecls' x = [x]
matchIdea' :: Scope'
-> LHsDecl GhcPs
-> HintRule
-> Maybe (Int, LHsExpr GhcPs)
-> LHsExpr GhcPs
-> Maybe (LHsExpr GhcPs, [Note], [(String, R.SrcSpan)])
matchIdea' sb decl HintRule{..} parent x = do
let lhs = unwrap hintRuleGhcLHS
rhs = unwrap hintRuleGhcRHS
sa = unwrap hintRuleGhcScope
nm a b = scopeMatch' (sa, a) (sb, b)
u <- unifyExp' nm True lhs x
u <- validSubst' eqNoLoc' u
let e = substitute' u rhs
res = addBracketTy' (addBracket' parent $ performSpecial' $ 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' (unwrap <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u
guard $ checkDefine' decl parent res
return (res, 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 (LL _ (OpApp _ x op y))
| varToStr' op == "&&" = bool x && bool y
| varToStr' op == "||" = bool x || bool y
| varToStr' op == "==" = expr (fromParen1' x) `eqNoLoc'` expr (fromParen1' y)
bool (LL _ (HsApp _ x y)) | varToStr' x == "not" = not $ bool y
bool (LL _ (HsPar _ x)) = bool x
bool (LL _ (HsApp _ cond (sub -> y)))
| 'i' : 's' : typ <- varToStr' cond = isType typ y
bool (LL _ (HsApp _ (LL _ (HsApp _ cond (sub -> x))) (sub -> y)))
| varToStr' cond == "notIn" = and [wrap (stripLocs' x) `notElem` map (wrap . stripLocs') (universe y) | x <- list x, y <- list y]
| varToStr' cond == "notEq" = not (x `eqNoLoc'` 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 (LL _ (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" (LL _ (HsLit _ HsInt{})) = True
isType "LitInt" (LL _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True
isType "Var" (LL _ HsVar{}) = True
isType "App" (LL _ HsApp{}) = True
isType "InfixApp" (LL _ x@OpApp{}) = True
isType "Paren" (LL _ x@HsPar{}) = True
isType "Tuple" (LL _ ExplicitTuple{}) = True
isType typ (LL _ x) =
let top = showConstr (toConstr x) in
typ == top
isType _ _ = False
asInt :: LHsExpr GhcPs -> Maybe Integer
asInt (LL _ (HsPar _ x)) = asInt x
asInt (LL _ (NegApp _ x _)) = negate <$> asInt x
asInt (LL _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x
asInt (LL _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x
asInt _ = Nothing
list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
list (LL _ (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' :: LHsDecl GhcPs -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
checkDefine' x Nothing y = declName x /= Just (varToStr' (transformBi unqual' $ head $ fromApps' y))
checkDefine' _ _ _ = True
performSpecial' :: LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial' = transform fNoParen . fEval
where
fEval, fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fEval (LL _ (HsApp _ e x)) | varToStr' e == "_eval_" = reduce' x
fEval x = x
fNoParen (LL _ (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 noExt c
addBracket' _ x = x
addBracketTy' :: LHsExpr GhcPs -> LHsExpr GhcPs
addBracketTy'= transformBi f
where
f :: LHsType GhcPs -> LHsType GhcPs
f (LL _ (HsAppTy _ t x@(LL _ HsAppTy{}))) =
noLoc (HsAppTy noExt t (noLoc (HsParTy noExt x)))
f x = x