{-# LANGUAGE ImportQualifiedPost #-}

{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}

{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-}

module Hint.Match(readMatch) where

import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSSA)

import Util

import Timing

import Data.Set qualified as Set

import Refact.Types qualified as R

import Control.Monad

import Data.Tuple.Extra

import Data.Maybe

import Config.Type

import Data.Generics.Uniplate.DataOnly

import GHC.Data.Bag

import GHC.Hs

import GHC.Types.SrcLoc

import GHC.Types.SourceText

import GHC.Types.Name.Reader

import GHC.Types.Name.Occurrence

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)) =

-- In a GHC parse tree, raw sections aren't valid application terms.

-- To be suitable as application terms, they must be enclosed in

-- parentheses.

-- If a == b then

-- x is 'a', op is '==' and y is 'b' and,

let lSec = addParen (L l (SectionL noExtField x op)) -- (a == )

rSec = addParen (L l (SectionR noExtField op y)) -- ( == b)

in (first (lSec :) <$> dotVersion y) ++ (first (rSec :) <$> dotVersion x) -- [([(a ==)], b), ([(b == )], a])].

dotVersion _ = []

findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]

findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList

[ (idea (hintRuleSeverity m) (hintRuleName m) (reLoc x) (reLoc 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 (toSSA x) subst (unsafePrettyPrint tpl)

]

-- | A list of root expressions, with their associated names

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{}) = [] -- Often rules contain things that HLint would rewrite.

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

-- Need to check free vars before unqualification, but after subst

-- (with 'e') need to unqualify before substitution (with 'res').

let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp noExtField fun rhs)

| otherwise = rhs

(e, (tpl, substNoParens)) = 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

-- Check no unexpected new free variables.

-- Check it isn't going to get broken by QuasiQuotes as per #483. If

-- we have lambdas we might be moving, and QuasiQuotes, we might

-- inadvertantly break free vars because quasi quotes don't show

-- what free vars they make use of.

guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuoteExpr $ universe x)

guard $ checkSide (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst u

guard $ checkDefine declName parent rhs

(u, tpl) <- pure $ if any ((== noSrcSpan) . locA . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)

tpl <- pure $ unqualify sa sb (addBracket parent $ performSpecial tpl)

pure ( res, tpl, hintRuleNotes,

[ (s, toSSA pos') | (s, pos) <- fromSubst u, locA (getLoc pos) /= noSrcSpan

, let pos' = if s `elem` substNoParens then fromParen pos else pos

]

)

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 -- Just a hint for proof stuff

isType "Atom" x = isAtom x

isType "WHNF" x = isWHNF x

isType "Wildcard" 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 "LitString" (L _ (HsLit _ HsString{})) = 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 _ _ x)) )) = Just x

asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ x))))) = Just 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) :: LHsExpr GhcPs

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 :: LocatedN RdrName -> LocatedN 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 = nlHsPar 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{}))) =

noLocA (HsAppTy noExtField t (noLocA (HsParTy noAnn x)))

f x = x