{-# 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
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
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