content: {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
  {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-}
  
  {-
  The matching does a fairly simple unification between the two terms, treating
  any single letter variable on the left as a free variable. After the matching
  we substitute, transform and check the side conditions. We also "see through"
  both ($) and (.) functions on the right.
  
  TRANSFORM PATTERNS
  _noParen_ - don't bracket this particular item
  
  SIDE CONDITIONS
  (&&), (||), not - boolean connectives
  isAtom x - does x never need brackets
  isFoo x - is the root constructor of x a "Foo"
  notEq x y - are x and y not equal
  notIn xs ys - are all x variables not in ys expressions
  noTypeCheck, noQuickCheck - no semantics, a hint for testing only
  
  ($) AND (.)
  We see through ($)/(.) by expanding it if nothing else matches.
  We also see through (.) by translating rules that have (.) equivalents
  to separate rules. For example:
  
  concat (map f x) ==> concatMap f x
  -- we spot both these rules can eta reduce with respect to x
  concat . map f ==> concatMap f
  -- we use the associativity of (.) to add
  concat . map f . x ==> concatMap f . x
  -- currently 36 of 169 rules have (.) equivalents
  
  We see through (.) if the RHS is dull using id, e.g.
  
  not (not x) ==> x
  not . not ==> id
  not . not . x ==> x
  -}
  
  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.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 []
  
  -- Find a dot version of this rule, return the sequence of app
  -- prefixes, and the var.
  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 _ = []
  
  ---------------------------------------------------------------------
  -- PERFORM THE MATCHING
  
  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 <- 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
           ]
         )
  
  ---------------------------------------------------------------------
  -- SIDE CONDITIONS
  
  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
  
  -- Does the result look very much like the declaration?
  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
  
  ---------------------------------------------------------------------
  -- TRANSFORMATION
  
  -- If it has '_noParen_', remove the brackets (if exist).
  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
  
  -- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.
  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
  
  -- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a
  -- need to bracket type applications in  This doesn't come up in HSE
  -- because the pretty printer inserts them.
  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
  