{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards, FlexibleContexts, ScopedTypeVariables #-}
module Hint.Match(readMatch) where
import Control.Applicative
import Data.List.Extra
import Data.Maybe
import Config.Type
import Hint.Type
import Control.Monad
import Data.Tuple.Extra
import HSE.Unify
import Util
import Timing
import qualified Data.Set as Set
import Prelude
import qualified Refact.Types as R
fmapAn = fmap (const an)
readMatch :: [HintRule] -> DeclHint
readMatch settings = findIdeas (concatMap readRule settings)
readRule :: HintRule -> [HintRule]
readRule m@HintRule{hintRuleLHS=(fmapAn -> hintRuleLHS), hintRuleRHS=(fmapAn -> hintRuleRHS), hintRuleSide=(fmap fmapAn -> hintRuleSide)} =
(:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ do
(l,v1) <- dotVersion hintRuleLHS
(r,v2) <- dotVersion hintRuleRHS
guard $ v1 == v2 && l /= [] && (length l > 1 || length r > 1) && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r)
if r /= [] then
[m{hintRuleLHS=dotApps l, hintRuleRHS=dotApps r, hintRuleSide=hintRuleSide}
,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=dotApps (r++[toNamed v1]), hintRuleSide=hintRuleSide}]
else if length l > 1 then
[m{hintRuleLHS=dotApps l, hintRuleRHS=toNamed "id", hintRuleSide=hintRuleSide}
,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=toNamed v1, hintRuleSide=hintRuleSide}]
else []
dotVersion :: Exp_ -> [([Exp_], String)]
dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)]
dotVersion (App l ls rs) = first (ls :) <$> dotVersion (fromParen rs)
dotVersion (InfixApp l x op y) = (first (LeftSection l x op :) <$> dotVersion y) ++
(first (RightSection l op y:) <$> dotVersion x)
dotVersion _ = []
findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [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, not $ isParen x
, m <- matches, Just (y,notes, subst) <- [matchIdea s decl m parent x]
, let r = R.Replace R.Expr (toSS x) subst (prettyPrint $ hintRuleRHS m) ]
findDecls :: Decl_ -> [Decl_]
findDecls x@InstDecl{} = children x
findDecls RulePragmaDecl{} = []
findDecls x = [x]
matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_, [Note], [(String, R.SrcSpan)])
matchIdea s decl HintRule{..} parent x = do
let nm a b = scopeMatch (hintRuleScope,a) (s,b)
u <- unifyExp nm True hintRuleLHS x
u <- validSubst (=~=) u
let e = substitute u hintRuleRHS
res = addBracket parent $ performSpecial $ substitute u $ unqualify hintRuleScope s hintRuleRHS
guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar) (freeVars hintRuleRHS))
`Set.isSubsetOf` freeVars x
guard $ not (any isLambda $ universe hintRuleLHS) || not (any isQuasiQuote $ universe x)
guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : fromSubst u
guard $ checkDefine decl parent res
return (res, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, ann pos /= an])
checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool
checkSide x bind = maybe True bool x
where
bool :: Exp_ -> Bool
bool (InfixApp _ x op y)
| opExp op ~= "&&" = bool x && bool y
| opExp op ~= "||" = bool x || bool y
| opExp op ~= "==" = expr (fromParen1 x) =~= expr (fromParen1 y)
bool (App _ x y) | x ~= "not" = not $ bool y
bool (Paren _ x) = bool x
bool (App _ cond (sub -> y))
| 'i':'s':typ <- fromNamed cond = isType typ y
bool (App _ (App _ cond (sub -> x)) (sub -> y))
| cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y]
| cond ~= "notEq" = x /=~= y
bool x | x ~= "noTypeCheck" = True
bool x | x ~= "noQuickCheck" = True
bool x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x
expr :: Exp_ -> Exp_
expr (App _ (fromNamed -> "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 isFieldWildcard $ universeS 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 ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ
isType typ x = head (words $ show x) == typ
asInt :: Exp_ -> Maybe Integer
asInt (Paren _ x) = asInt x
asInt (NegApp _ x) = negate <$> asInt x
asInt (Lit _ (Int _ x _)) = Just x
asInt _ = Nothing
list :: Exp_ -> [Exp_]
list (List _ xs) = xs
list x = [x]
sub :: Exp_ -> Exp_
sub = transform f
where f (view -> Var_ x) | Just y <- lookup x bind = y
f x = x
checkDefine :: Decl_ -> Maybe (Int, Exp_) -> Exp_ -> Bool
checkDefine x Nothing y = fromNamed x /= fromNamed (transformBi unqual $ head $ fromApps y)
checkDefine _ _ _ = True
performSpecial :: Exp_ -> Exp_
performSpecial = transform fNoParen . fEval
where
fEval (App _ e x) | e ~= "_eval_" = reduce x
fEval x = x
fNoParen (App _ e x) | e ~= "_noParen_" = fromParen x
fNoParen x = x
unqualify :: Scope -> Scope -> Exp_ -> Exp_
unqualify from to = transformBi f
where
f x@(UnQual _ (Ident _ s)) | isUnifyVar s = x
f x = scopeMove (from,x) to
addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_
addBracket (Just (i,p)) c | needBracketOld i p c = Paren an c
addBracket _ x = x