{-# 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,toSS)

-- import Language.Haskell.GhclibParserEx.Dump
-- import GHC.Utils.Outputable

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.DataOnly

import GHC.Data.Bag
import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Types.Basic
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
-- import Debug.Trace

readMatch :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch [HintRule]
settings = [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas ((HintRule -> [HintRule]) -> [HintRule] -> [HintRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HintRule -> [HintRule]
readRule [HintRule]
settings)

readRule :: HintRule -> [HintRule]
readRule :: HintRule -> [HintRule]
readRule m :: HintRule
m@HintRule{ hintRuleLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS=(LHsExpr GhcPs -> LHsExpr GhcPs
forall from. Data from => from -> from
stripLocs (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> HsExtendInstances (LHsExpr GhcPs)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances -> LHsExpr GhcPs
hintRuleLHS)
                    , hintRuleRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS=(LHsExpr GhcPs -> LHsExpr GhcPs
forall from. Data from => from -> from
stripLocs (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> HsExtendInstances (LHsExpr GhcPs)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances -> LHsExpr GhcPs
hintRuleRHS)
                    , hintRuleSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide=((LHsExpr GhcPs -> LHsExpr GhcPs
forall from. Data from => from -> from
stripLocs (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> HsExtendInstances (LHsExpr GhcPs)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances (HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) -> Maybe (LHsExpr GhcPs)
hintRuleSide)
                    } =
   (:) HintRule
m{ hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
hintRuleLHS
        , hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
hintRuleRHS
        , hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsExpr GhcPs)
hintRuleSide } ([HintRule] -> [HintRule]) -> [HintRule] -> [HintRule]
forall a b. (a -> b) -> a -> b
$ do
    ([LHsExpr GhcPs]
l, String
v1) <- LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion LHsExpr GhcPs
hintRuleLHS
    ([LHsExpr GhcPs]
r, String
v2) <- LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion LHsExpr GhcPs
hintRuleRHS

    Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ String
v1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcPs]
l) Bool -> Bool -> Bool
&& ([LHsExpr GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| [LHsExpr GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Bool -> Bool -> Bool
&& String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember String
v1 ((OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString ([LHsExpr GhcPs] -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars ([LHsExpr GhcPs] -> Set OccName) -> [LHsExpr GhcPs] -> Set OccName
forall a b. (a -> b) -> a -> b
$ Maybe (LHsExpr GhcPs) -> [LHsExpr GhcPs]
forall a. Maybe a -> [a]
maybeToList Maybe (LHsExpr GhcPs)
hintRuleSide [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs]
l [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs]
r))
    if Bool -> Bool
not ([LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcPs]
r) then
      [ HintRule
m{ hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [LHsExpr GhcPs]
l), hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [LHsExpr GhcPs]
r), hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsExpr GhcPs)
hintRuleSide }
      , HintRule
m{ hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps ([LHsExpr GhcPs]
l [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [String -> LHsExpr GhcPs
strToVar String
v1])), hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps ([LHsExpr GhcPs]
r [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [String -> LHsExpr GhcPs
strToVar String
v1])), hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsExpr GhcPs)
hintRuleSide } ]
      else if [LHsExpr GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then
            [ HintRule
m{ hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [LHsExpr GhcPs]
l), hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (String -> LHsExpr GhcPs
strToVar String
"id"), hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsExpr GhcPs)
hintRuleSide }
            , HintRule
m{ hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps ([LHsExpr GhcPs]
l[LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++[String -> LHsExpr GhcPs
strToVar String
v1])), hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (String -> LHsExpr GhcPs
strToVar String
v1), hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsExpr GhcPs)
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 :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v) | String -> Bool
isUnifyVar String
v = [([], String
v)]
dotVersion (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
ls LHsExpr GhcPs
rs)) = ([LHsExpr GhcPs] -> [LHsExpr GhcPs])
-> ([LHsExpr GhcPs], String) -> ([LHsExpr GhcPs], String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (LHsExpr GhcPs
ls LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:) (([LHsExpr GhcPs], String) -> ([LHsExpr GhcPs], String))
-> [([LHsExpr GhcPs], String)] -> [([LHsExpr GhcPs], String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
rs)
dotVersion (L SrcSpan
l (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
op LHsExpr GhcPs
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 :: LHsExpr GhcPs
lSec = LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL NoExtField
XSectionL GhcPs
noExtField LHsExpr GhcPs
x LHsExpr GhcPs
op)) -- (a == )
      rSec :: LHsExpr GhcPs
rSec = LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
op LHsExpr GhcPs
y)) -- ( == b)
  in (([LHsExpr GhcPs] -> [LHsExpr GhcPs])
-> ([LHsExpr GhcPs], String) -> ([LHsExpr GhcPs], String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (LHsExpr GhcPs
lSec LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:) (([LHsExpr GhcPs], String) -> ([LHsExpr GhcPs], String))
-> [([LHsExpr GhcPs], String)] -> [([LHsExpr GhcPs], String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion LHsExpr GhcPs
y) [([LHsExpr GhcPs], String)]
-> [([LHsExpr GhcPs], String)] -> [([LHsExpr GhcPs], String)]
forall a. [a] -> [a] -> [a]
++ (([LHsExpr GhcPs] -> [LHsExpr GhcPs])
-> ([LHsExpr GhcPs], String) -> ([LHsExpr GhcPs], String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (LHsExpr GhcPs
rSec LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:) (([LHsExpr GhcPs], String) -> ([LHsExpr GhcPs], String))
-> [([LHsExpr GhcPs], String)] -> [([LHsExpr GhcPs], String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion LHsExpr GhcPs
x) -- [([(a ==)], b), ([(b == )], a])].
dotVersion LHsExpr GhcPs
_ = []

---------------------------------------------------------------------
-- PERFORM THE MATCHING

findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas [HintRule]
matches Scope
s ModuleEx
_ LHsDecl GhcPs
decl = String -> String -> [Idea] -> [Idea]
forall a. String -> String -> a -> a
timed String
"Hint" String
"Match apply" ([Idea] -> [Idea]) -> [Idea] -> [Idea]
forall a b. (a -> b) -> a -> b
$ [Idea] -> [Idea]
forall a. [a] -> [a]
forceList
    [ (Severity
-> String
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
Severity
-> String
-> Located a
-> Located b
-> [Refactoring SrcSpan]
-> Idea
idea (HintRule -> Severity
hintRuleSeverity HintRule
m) (HintRule -> String
hintRuleName HintRule
m) LHsExpr GhcPs
x LHsExpr GhcPs
y [Refactoring SrcSpan
r]){ideaNote :: [Note]
ideaNote=[Note]
notes}
    | (String
name, LHsExpr GhcPs
expr) <- LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
findDecls LHsDecl GhcPs
decl
    , (Maybe (Int, LHsExpr GhcPs)
parent,LHsExpr GhcPs
x) <- LHsExpr GhcPs -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
forall a.
Data a =>
a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
universeParentExp LHsExpr GhcPs
expr
    , HintRule
m <- [HintRule]
matches, Just (LHsExpr GhcPs
y, LHsExpr GhcPs
tpl, [Note]
notes, [(String, SrcSpan)]
subst) <- [Scope
-> String
-> HintRule
-> Maybe (Int, LHsExpr GhcPs)
-> LHsExpr GhcPs
-> Maybe
     (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, SrcSpan)])
matchIdea Scope
s String
name HintRule
m Maybe (Int, LHsExpr GhcPs)
parent LHsExpr GhcPs
x]
    , let r :: Refactoring SrcSpan
r = RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
R.Replace RType
R.Expr (LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
x) [(String, SrcSpan)]
subst (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
tpl)
    ]

-- | A list of root expressions, with their associated names
findDecls :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
findDecls :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
findDecls x :: LHsDecl GhcPs
x@(L SrcSpan
_ (InstD XInstD GhcPs
_ (ClsInstD XClsInstD GhcPs
_ ClsInstDecl{LHsBinds GhcPs
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds :: LHsBinds GhcPs
cid_binds}))) =
    [(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ LHsBind GhcPs -> Maybe String
bindName LHsBind GhcPs
xs, LHsExpr GhcPs
x) | LHsBind GhcPs
xs <- LHsBinds GhcPs -> [LHsBind GhcPs]
forall a. Bag a -> [a]
bagToList LHsBinds GhcPs
cid_binds, LHsExpr GhcPs
x <- LHsBind GhcPs -> [LHsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi LHsBind GhcPs
xs]
findDecls (L SrcSpan
_ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.
findDecls LHsDecl GhcPs
x = (LHsExpr GhcPs -> (String, LHsExpr GhcPs))
-> [LHsExpr GhcPs] -> [(String, LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> Maybe String
declName LHsDecl GhcPs
x,) ([LHsExpr GhcPs] -> [(String, LHsExpr GhcPs)])
-> [LHsExpr GhcPs] -> [(String, LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> [LHsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi LHsDecl GhcPs
x

matchIdea :: Scope
           -> String
           -> HintRule
           -> Maybe (Int, LHsExpr GhcPs)
           -> LHsExpr GhcPs
           -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, R.SrcSpan)])
matchIdea :: Scope
-> String
-> HintRule
-> Maybe (Int, LHsExpr GhcPs)
-> LHsExpr GhcPs
-> Maybe
     (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, SrcSpan)])
matchIdea Scope
sb String
declName HintRule{String
[Note]
Maybe (HsExtendInstances (LHsExpr GhcPs))
HsExtendInstances (LHsExpr GhcPs)
Scope
Severity
hintRuleScope :: HintRule -> Scope
hintRuleNotes :: HintRule -> [Note]
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: Scope
hintRuleNotes :: [Note]
hintRuleName :: String
hintRuleSeverity :: Severity
hintRuleName :: HintRule -> String
hintRuleSeverity :: HintRule -> Severity
hintRuleSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
..} Maybe (Int, LHsExpr GhcPs)
parent LHsExpr GhcPs
x = do
  let lhs :: LHsExpr GhcPs
lhs = HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS
      rhs :: LHsExpr GhcPs
rhs = HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS
      sa :: Scope
sa  = Scope
hintRuleScope
      nm :: Located RdrName -> Located RdrName -> Bool
nm Located RdrName
a Located RdrName
b = (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool
scopeMatch (Scope
sa, Located RdrName
a) (Scope
sb, Located RdrName
b)
  (Subst (LHsExpr GhcPs)
u, Maybe (LHsExpr GhcPs)
extra) <- (Located RdrName -> Located RdrName -> Bool)
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp Located RdrName -> Located RdrName -> Bool
nm Bool
True LHsExpr GhcPs
lhs LHsExpr GhcPs
x
  Subst (LHsExpr GhcPs)
u <- (LHsExpr GhcPs -> LHsExpr GhcPs -> Bool)
-> Subst (LHsExpr GhcPs) -> Maybe (Subst (LHsExpr GhcPs))
forall a. (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq Subst (LHsExpr GhcPs)
u

  -- Need to check free vars before unqualification, but after subst
  -- (with 'e') need to unqualify before substitution (with 'res').
  let rhs' :: LHsExpr GhcPs
rhs' | Just LHsExpr GhcPs
fun <- Maybe (LHsExpr GhcPs)
extra = LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
fun LHsExpr GhcPs
rhs)
           | Bool
otherwise = LHsExpr GhcPs
rhs
      (LHsExpr GhcPs
e, (LHsExpr GhcPs
tpl, [String]
substNoParens)) = Subst (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
substitute Subst (LHsExpr GhcPs)
u LHsExpr GhcPs
rhs'
      noParens :: [String]
noParens = [LHsExpr GhcPs -> String
varToStr (LHsExpr GhcPs -> String) -> LHsExpr GhcPs -> String
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
x | L SrcSpan
_ (HsApp XApp GhcPs
_ (LHsExpr GhcPs -> String
varToStr -> String
"_noParen_") LHsExpr GhcPs
x) <- LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
tpl]

  Subst (LHsExpr GhcPs)
u <- Subst (LHsExpr GhcPs) -> Maybe (Subst (LHsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> Subst (LHsExpr GhcPs) -> Subst (LHsExpr GhcPs)
removeParens [String]
noParens Subst (LHsExpr GhcPs)
u)

  let res :: LHsExpr GhcPs
res = LHsExpr GhcPs -> LHsExpr GhcPs
addBracketTy (Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
addBracket Maybe (Int, LHsExpr GhcPs)
parent (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) -> LHsExpr GhcPs
forall a b. (a, b) -> a
fst ((LHsExpr GhcPs, (LHsExpr GhcPs, [String])) -> LHsExpr GhcPs)
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Subst (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
substitute Subst (LHsExpr GhcPs)
u (LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
forall a b. (a -> b) -> a -> b
$ Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs
unqualify Scope
sa Scope
sb LHsExpr GhcPs
rhs')
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
e Set OccName -> Set OccName -> Set OccName
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ (OccName -> Bool) -> Set OccName -> Set OccName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (OccName -> Bool) -> OccName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isUnifyVar (String -> Bool) -> (OccName -> String) -> OccName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString) (LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
rhs')) Set OccName -> Set OccName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
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.
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ((LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isLambda ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
lhs) Bool -> Bool -> Bool
|| Bool -> Bool
not ((LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuote ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x)

  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide (HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances (HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSide) ([(String, LHsExpr GhcPs)] -> Bool)
-> [(String, LHsExpr GhcPs)] -> Bool
forall a b. (a -> b) -> a -> b
$ (String
"original", LHsExpr GhcPs
x) (String, LHsExpr GhcPs)
-> [(String, LHsExpr GhcPs)] -> [(String, LHsExpr GhcPs)]
forall a. a -> [a] -> [a]
: (String
"result", LHsExpr GhcPs
res) (String, LHsExpr GhcPs)
-> [(String, LHsExpr GhcPs)] -> [(String, LHsExpr GhcPs)]
forall a. a -> [a] -> [a]
: Subst (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)]
forall a. Subst a -> [(String, a)]
fromSubst Subst (LHsExpr GhcPs)
u
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
checkDefine String
declName Maybe (Int, LHsExpr GhcPs)
parent LHsExpr GhcPs
rhs

  (Subst (LHsExpr GhcPs)
u, LHsExpr GhcPs
tpl) <- (Subst (LHsExpr GhcPs), LHsExpr GhcPs)
-> Maybe (Subst (LHsExpr GhcPs), LHsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Subst (LHsExpr GhcPs), LHsExpr GhcPs)
 -> Maybe (Subst (LHsExpr GhcPs), LHsExpr GhcPs))
-> (Subst (LHsExpr GhcPs), LHsExpr GhcPs)
-> Maybe (Subst (LHsExpr GhcPs), LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ if ((String, LHsExpr GhcPs) -> Bool)
-> [(String, LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
noSrcSpan) (SrcSpan -> Bool)
-> ((String, LHsExpr GhcPs) -> SrcSpan)
-> (String, LHsExpr GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsExpr GhcPs -> SrcSpan)
-> ((String, LHsExpr GhcPs) -> LHsExpr GhcPs)
-> (String, LHsExpr GhcPs)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a, b) -> b
snd) (Subst (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)]
forall a. Subst a -> [(String, a)]
fromSubst Subst (LHsExpr GhcPs)
u) then (Subst (LHsExpr GhcPs)
forall a. Monoid a => a
mempty, LHsExpr GhcPs
res) else (Subst (LHsExpr GhcPs)
u, LHsExpr GhcPs
tpl)
  LHsExpr GhcPs
tpl <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs
unqualify Scope
sa Scope
sb (LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial LHsExpr GhcPs
tpl)

  (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, SrcSpan)])
-> Maybe
     (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, SrcSpan)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( LHsExpr GhcPs
res, LHsExpr GhcPs
tpl, [Note]
hintRuleNotes,
         [ (String
s, LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
pos') | (String
s, LHsExpr GhcPs
pos) <- Subst (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)]
forall a. Subst a -> [(String, a)]
fromSubst Subst (LHsExpr GhcPs)
u, LHsExpr GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcPs
pos SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
noSrcSpan
                          , let pos' :: LHsExpr GhcPs
pos' = if String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
substNoParens then LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
pos else LHsExpr GhcPs
pos
         ]
       )

---------------------------------------------------------------------
-- SIDE CONDITIONS

checkSide :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide Maybe (LHsExpr GhcPs)
x [(String, LHsExpr GhcPs)]
bind = Bool -> (LHsExpr GhcPs -> Bool) -> Maybe (LHsExpr GhcPs) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True LHsExpr GhcPs -> Bool
bool Maybe (LHsExpr GhcPs)
x
    where
      bool :: LHsExpr GhcPs -> Bool
      bool :: LHsExpr GhcPs -> Bool
bool (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
op LHsExpr GhcPs
y))
        | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
op String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"&&" = LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
x Bool -> Bool -> Bool
&& LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
y
        | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
op String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"||" = LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
x Bool -> Bool -> Bool
|| LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
y
        | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
op String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"==" = LHsExpr GhcPs -> LHsExpr GhcPs
expr (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 LHsExpr GhcPs
x) LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
`astEq` LHsExpr GhcPs -> LHsExpr GhcPs
expr (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 LHsExpr GhcPs
y)
      bool (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"not" = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
y
      bool (L SrcSpan
_ (HsPar XPar GhcPs
_ LHsExpr GhcPs
x)) = LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
x

      bool (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
cond (LHsExpr GhcPs -> LHsExpr GhcPs
sub -> LHsExpr GhcPs
y)))
        | Char
'i' : Char
's' : String
typ <- LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
cond = String -> LHsExpr GhcPs -> Bool
isType String
typ LHsExpr GhcPs
y
      bool (L SrcSpan
_ (HsApp XApp GhcPs
_ (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
cond (LHsExpr GhcPs -> LHsExpr GhcPs
sub -> LHsExpr GhcPs
x))) (LHsExpr GhcPs -> LHsExpr GhcPs
sub -> LHsExpr GhcPs
y)))
          | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
cond String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"notIn" = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> LHsExpr GhcPs
forall from. Data from => from -> from
stripLocs LHsExpr GhcPs
x) HsExtendInstances (LHsExpr GhcPs)
-> [HsExtendInstances (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> [LHsExpr GhcPs] -> [HsExtendInstances (LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> HsExtendInstances (LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs
forall from. Data from => from -> from
stripLocs) (LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
y) | LHsExpr GhcPs
x <- LHsExpr GhcPs -> [LHsExpr GhcPs]
list LHsExpr GhcPs
x, LHsExpr GhcPs
y <- LHsExpr GhcPs -> [LHsExpr GhcPs]
list LHsExpr GhcPs
y]
          | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
cond String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"notEq" = Bool -> Bool
not (LHsExpr GhcPs
x LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
`astEq` LHsExpr GhcPs
y)
      bool LHsExpr GhcPs
x | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"noTypeCheck" = Bool
True
      bool LHsExpr GhcPs
x | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"noQuickCheck" = Bool
True
      bool LHsExpr GhcPs
x = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Hint.Match.checkSide, unknown side condition: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
x

      expr :: LHsExpr GhcPs -> LHsExpr GhcPs
      expr :: LHsExpr GhcPs -> LHsExpr GhcPs
expr (L SrcSpan
_ (HsApp XApp GhcPs
_ (LHsExpr GhcPs -> String
varToStr -> String
"subst") LHsExpr GhcPs
x)) = LHsExpr GhcPs -> LHsExpr GhcPs
sub (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 LHsExpr GhcPs
x
      expr LHsExpr GhcPs
x = LHsExpr GhcPs
x

      isType :: String -> LHsExpr GhcPs -> Bool
isType String
"Compare" LHsExpr GhcPs
x = Bool
True -- Just a hint for proof stuff
      isType String
"Atom" LHsExpr GhcPs
x = LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
x
      isType String
"WHNF" LHsExpr GhcPs
x = LHsExpr GhcPs -> Bool
isWHNF LHsExpr GhcPs
x
      isType String
"Wildcard" LHsExpr GhcPs
x = (LHsRecField GhcPs (LHsExpr GhcPs) -> Bool)
-> [LHsRecField GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsRecField GhcPs (LHsExpr GhcPs) -> Bool
isFieldPun (LHsExpr GhcPs -> [LHsRecField GhcPs (LHsExpr GhcPs)]
forall from to. Biplate from to => from -> [to]
universeBi LHsExpr GhcPs
x) Bool -> Bool -> Bool
|| (HsRecFields GhcPs (LHsExpr GhcPs) -> Bool)
-> [HsRecFields GhcPs (LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsRecFields GhcPs (LHsExpr GhcPs) -> Bool
hasFieldsDotDot (LHsExpr GhcPs -> [HsRecFields GhcPs (LHsExpr GhcPs)]
forall from to. Biplate from to => from -> [to]
universeBi LHsExpr GhcPs
x)
      isType String
"Nat" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = Bool
True
      isType String
"Pos" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>  Integer
0 = Bool
True
      isType String
"Neg" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
0 = Bool
True
      isType String
"NegZero" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = Bool
True
      isType String
"LitInt" (L SrcSpan
_ (HsLit XLitE GhcPs
_ HsInt{})) = Bool
True
      isType String
"LitInt" (L SrcSpan
_ (HsOverLit XOverLitE GhcPs
_ (OverLit XOverLit GhcPs
_ HsIntegral{} HsExpr GhcPs
_))) = Bool
True
      isType String
"LitString" (L SrcSpan
_ (HsLit XLitE GhcPs
_ HsString{})) = Bool
True
      isType String
"Var" (L SrcSpan
_ HsVar{}) = Bool
True
      isType String
"App" (L SrcSpan
_ HsApp{}) = Bool
True
      isType String
"InfixApp" (L SrcSpan
_ x :: HsExpr GhcPs
x@OpApp{}) = Bool
True
      isType String
"Paren" (L SrcSpan
_ x :: HsExpr GhcPs
x@HsPar{}) = Bool
True
      isType String
"Tuple" (L SrcSpan
_ ExplicitTuple{}) = Bool
True

      isType String
typ (L SrcSpan
_ HsExpr GhcPs
x) =
        let top :: String
top = Constr -> String
showConstr (HsExpr GhcPs -> Constr
forall a. Data a => a -> Constr
toConstr HsExpr GhcPs
x) in
        String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
top

      asInt :: LHsExpr GhcPs -> Maybe Integer
      asInt :: LHsExpr GhcPs -> Maybe Integer
asInt (L SrcSpan
_ (HsPar XPar GhcPs
_ LHsExpr GhcPs
x)) = LHsExpr GhcPs -> Maybe Integer
asInt LHsExpr GhcPs
x
      asInt (L SrcSpan
_ (NegApp XNegApp GhcPs
_ LHsExpr GhcPs
x SyntaxExpr GhcPs
_)) = Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> Maybe Integer
asInt LHsExpr GhcPs
x
      asInt (L SrcSpan
_ (HsLit XLitE GhcPs
_ (HsInt XHsInt GhcPs
_ (IL SourceText
_ Bool
_ Integer
x)) )) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
x
      asInt (L SrcSpan
_ (HsOverLit XOverLitE GhcPs
_ (OverLit XOverLit GhcPs
_ (HsIntegral (IL SourceText
_ Bool
_ Integer
x)) HsExpr GhcPs
_))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
x
      asInt LHsExpr GhcPs
_ = Maybe Integer
forall a. Maybe a
Nothing

      list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
      list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
list (L SrcSpan
_ (ExplicitList XExplicitList GhcPs
_ Maybe (SyntaxExpr GhcPs)
_ [LHsExpr GhcPs]
xs)) = [LHsExpr GhcPs]
xs
      list LHsExpr GhcPs
x = [LHsExpr GhcPs
x]

      sub :: LHsExpr GhcPs -> LHsExpr GhcPs
      sub :: LHsExpr GhcPs -> LHsExpr GhcPs
sub = (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
transform LHsExpr GhcPs -> LHsExpr GhcPs
f
        where f :: LHsExpr GhcPs -> LHsExpr GhcPs
f (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x) | Just LHsExpr GhcPs
y <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, LHsExpr GhcPs)]
bind = LHsExpr GhcPs
y
              f LHsExpr GhcPs
x = LHsExpr GhcPs
x

-- Does the result look very much like the declaration?
checkDefine :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
checkDefine :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
checkDefine String
declName Maybe (Int, LHsExpr GhcPs)
Nothing LHsExpr GhcPs
y =
  let funOrOp :: LHsExpr p -> LHsExpr p
funOrOp LHsExpr p
expr = case LHsExpr p
expr of
        L SrcSpan
_ (HsApp XApp p
_ LHsExpr p
fun LHsExpr p
_) -> LHsExpr p -> LHsExpr p
funOrOp LHsExpr p
fun
        L SrcSpan
_ (OpApp XOpApp p
_ LHsExpr p
_ LHsExpr p
op LHsExpr p
_) -> LHsExpr p -> LHsExpr p
funOrOp LHsExpr p
op
        LHsExpr p
other -> LHsExpr p
other
   in String
declName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= LHsExpr GhcPs -> String
varToStr ((Located RdrName -> Located RdrName)
-> LHsExpr GhcPs -> LHsExpr GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Located RdrName -> Located RdrName
unqual (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
forall p. LHsExpr p -> LHsExpr p
funOrOp LHsExpr GhcPs
y)
checkDefine String
_ Maybe (Int, LHsExpr GhcPs)
_ LHsExpr GhcPs
_ = Bool
True

---------------------------------------------------------------------
-- TRANSFORMATION

-- If it has '_noParen_', remove the brackets (if exist).
performSpecial :: LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial :: LHsExpr GhcPs -> LHsExpr GhcPs
performSpecial = (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
transform LHsExpr GhcPs -> LHsExpr GhcPs
fNoParen
  where
    fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
    fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fNoParen (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
e LHsExpr GhcPs
x)) | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_noParen_" = LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
x
    fNoParen LHsExpr GhcPs
x = LHsExpr GhcPs
x

-- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.
unqualify :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs
unqualify :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs
unqualify Scope
from Scope
to = (Located RdrName -> Located RdrName)
-> LHsExpr GhcPs -> LHsExpr GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Located RdrName -> Located RdrName
f
  where
    f :: Located RdrName -> Located RdrName
    f :: Located RdrName -> Located RdrName
f x :: Located RdrName
x@(L SrcSpan
_ (Unqual OccName
s)) | String -> Bool
isUnifyVar (OccName -> String
occNameString OccName
s) = Located RdrName
x
    f Located RdrName
x = (Scope, Located RdrName) -> Scope -> Located RdrName
scopeMove (Scope
from, Located RdrName
x) Scope
to

addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
addBracket (Just (Int
i, LHsExpr GhcPs
p)) LHsExpr GhcPs
c | Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld Int
i LHsExpr GhcPs
p LHsExpr GhcPs
c = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
c
addBracket Maybe (Int, LHsExpr GhcPs)
_ LHsExpr GhcPs
x = LHsExpr GhcPs
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 :: LHsExpr GhcPs -> LHsExpr GhcPs
addBracketTy= (LHsType GhcPs -> LHsType GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LHsType GhcPs -> LHsType GhcPs
f
  where
    f :: LHsType GhcPs -> LHsType GhcPs
    f :: LHsType GhcPs -> LHsType GhcPs
f (L SrcSpan
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t x :: LHsType GhcPs
x@(L SrcSpan
_ HsAppTy{}))) =
      HsType GhcPs -> LHsType GhcPs
forall e. e -> Located e
noLoc (XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
XAppTy GhcPs
noExtField LHsType GhcPs
t (HsType GhcPs -> LHsType GhcPs
forall e. e -> Located e
noLoc (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExtField
XParTy GhcPs
noExtField LHsType GhcPs
x)))
    f LHsType GhcPs
x = LHsType GhcPs
x