{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}

{-
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
_eval_ - perform deep evaluation, must be used at the top of a RHS
_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 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 HsSyn
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

readMatch' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]
readMatch' settings :: [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{ hintRuleGhcLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS=(LHsExpr GhcPs -> LHsExpr GhcPs
forall from. (Data from, HasSrcSpan 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
hintRuleGhcLHS)
                    , hintRuleGhcRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS=(LHsExpr GhcPs -> LHsExpr GhcPs
forall from. (Data from, HasSrcSpan 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
hintRuleGhcRHS)
                    , hintRuleGhcSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleGhcSide=((LHsExpr GhcPs -> LHsExpr GhcPs
forall from. (Data from, HasSrcSpan 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)
hintRuleGhcSide)
                    } =
   (:) HintRule
m{ hintRuleGhcLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
hintRuleGhcLHS
        , hintRuleGhcRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
hintRuleGhcRHS
        , hintRuleGhcSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleGhcSide=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)
hintRuleGhcSide } ([HintRule] -> [HintRule]) -> [HintRule] -> [HintRule]
forall a b. (a -> b) -> a -> b
$ do
    (l :: [LHsExpr GhcPs]
l, v1 :: String
v1) <- LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion' LHsExpr GhcPs
hintRuleGhcLHS
    (r :: [LHsExpr GhcPs]
r, v2 :: String
v2) <- LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]
dotVersion' LHsExpr GhcPs
hintRuleGhcRHS

    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
> 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
> 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)
hintRuleGhcSide [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{ hintRuleGhcLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps' [LHsExpr GhcPs]
l), hintRuleGhcRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps' [LHsExpr GhcPs]
r), hintRuleGhcSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleGhcSide=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)
hintRuleGhcSide }
      , HintRule
m{ hintRuleGhcLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS=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])), hintRuleGhcRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS=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])), hintRuleGhcSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleGhcSide=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)
hintRuleGhcSide } ]
      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
> 1 then
            [ HintRule
m{ hintRuleGhcLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps' [LHsExpr GhcPs]
l), hintRuleGhcRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (String -> LHsExpr GhcPs
strToVar "id"), hintRuleGhcSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleGhcSide=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)
hintRuleGhcSide }
            , HintRule
m{ hintRuleGhcLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS=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])), hintRuleGhcRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS=LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances (String -> LHsExpr GhcPs
strToVar String
v1), hintRuleGhcSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleGhcSide=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)
hintRuleGhcSide}]
      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_' v :: String
v) | String -> Bool
isUnifyVar String
v = [([], String
v)]
dotVersion' (LL _ (HsApp _ ls 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' (LL l :: SrcSpan
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 :: LHsExpr GhcPs
lSec = LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets' a => a -> a
addParen' (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL NoExt
XSectionL GhcPs
noExt LHsExpr GhcPs
x LHsExpr GhcPs
op)) -- (a == )
      rSec :: LHsExpr GhcPs
rSec = LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets' a => a -> a
addParen' (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExt
XSectionR GhcPs
noExt 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' _ = []

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

findIdeas' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]
findIdeas' matches :: [HintRule]
matches s :: Scope'
s _ decl :: LHsDecl GhcPs
decl = String -> String -> [Idea] -> [Idea]
forall a. String -> String -> a -> a
timed "Hint" "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.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
Severity -> String -> a -> 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}
    | (name :: String
name, expr :: LHsExpr GhcPs
expr) <- LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
findDecls' LHsDecl GhcPs
decl
    , (parent :: Maybe (Int, LHsExpr GhcPs)
parent,x :: 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 (y :: LHsExpr GhcPs
y, tpl :: LHsExpr GhcPs
tpl, notes :: [Note]
notes, subst :: [(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 e. HasSrcSpan e => e -> 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@(LL _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
    [(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (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 <- Bag (LHsBind GhcPs) -> [LHsBind GhcPs]
forall a. Bag a -> [a]
bagToList Bag (LHsBind GhcPs)
cid_binds, LHsExpr GhcPs
x <- LHsBind GhcPs -> [LHsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi LHsBind GhcPs
xs]
findDecls' (LL _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.
findDecls' x :: 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 "" (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' sb :: Scope'
sb declName :: String
declName HintRule{..} parent :: Maybe (Int, LHsExpr GhcPs)
parent x :: LHsExpr GhcPs
x = do
  let lhs :: LHsExpr GhcPs
lhs = HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcLHS
      rhs :: LHsExpr GhcPs
rhs = HsExtendInstances (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HsExtendInstances a -> a
unextendInstances HsExtendInstances (LHsExpr GhcPs)
hintRuleGhcRHS
      sa :: Scope'
sa  = HsExtendInstances Scope' -> Scope'
forall a. HsExtendInstances a -> a
unextendInstances HsExtendInstances Scope'
hintRuleGhcScope
      nm :: Located RdrName -> Located RdrName -> Bool
nm a :: Located RdrName
a b :: 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 <- (Located RdrName -> Located RdrName -> Bool)
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (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 (e :: LHsExpr GhcPs
e, tpl :: LHsExpr GhcPs
tpl) = Subst' (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute' Subst' (LHsExpr GhcPs)
u LHsExpr GhcPs
rhs
      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) -> LHsExpr GhcPs
forall a b. (a, b) -> a
fst ((LHsExpr GhcPs, LHsExpr GhcPs) -> LHsExpr GhcPs)
-> (LHsExpr GhcPs, LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Subst' (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute' Subst' (LHsExpr GhcPs)
u (LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
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))
hintRuleGhcSide) ([(String, LHsExpr GhcPs)] -> Bool)
-> [(String, LHsExpr GhcPs)] -> Bool
forall a b. (a -> b) -> a -> b
$ ("original", LHsExpr GhcPs
x) (String, LHsExpr GhcPs)
-> [(String, LHsExpr GhcPs)] -> [(String, LHsExpr GhcPs)]
forall a. a -> [a] -> [a]
: ("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
res

  (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, SrcSpan)])
-> Maybe
     (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, SrcSpan)])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs
res, LHsExpr GhcPs
tpl, [Note]
hintRuleNotes, [(String
s, LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
pos) | (s :: String
s, pos :: LHsExpr GhcPs
pos) <- Subst' (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)]
forall a. Subst' a -> [(String, a)]
fromSubst' Subst' (LHsExpr GhcPs)
u, LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
pos SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
noSrcSpan])

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

checkSide' :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide' :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool
checkSide' x :: Maybe (LHsExpr GhcPs)
x bind :: [(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 (LL _ (OpApp _ x op y))
        | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
op String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "&&" = 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
== "||" = 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
== "==" = 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 (LL _ (HsApp _ x y)) | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "not" = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
y
      bool (LL _ (HsPar _ x)) = LHsExpr GhcPs -> Bool
bool LHsExpr GhcPs
x

      bool (LL _ (HsApp _ cond (sub -> y)))
        | 'i' : 's' : typ :: String
typ <- LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
cond = String -> LHsExpr GhcPs -> Bool
isType String
typ LHsExpr GhcPs
y
      bool (LL _ (HsApp _ (LL _ (HsApp _ cond (sub -> x))) (sub -> y)))
          | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
cond String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "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, HasSrcSpan 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, HasSrcSpan 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
== "notEq" = Bool -> Bool
not (LHsExpr GhcPs
x LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
`astEq` LHsExpr GhcPs
y)
      bool x :: LHsExpr GhcPs
x | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "noTypeCheck" = Bool
True
      bool x :: LHsExpr GhcPs
x | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "noQuickCheck" = Bool
True
      bool x :: LHsExpr GhcPs
x = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ "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 (LL _ (HsApp _ (varToStr -> "subst") 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 x :: LHsExpr GhcPs
x = LHsExpr GhcPs
x

      isType :: String -> LHsExpr GhcPs -> Bool
isType "Compare" x :: LHsExpr GhcPs
x = Bool
True -- Just a hint for proof stuff
      isType "Atom" x :: LHsExpr GhcPs
x = LHsExpr GhcPs -> Bool
forall a. Brackets' a => a -> Bool
isAtom' LHsExpr GhcPs
x
      isType "WHNF" x :: LHsExpr GhcPs
x = LHsExpr GhcPs -> Bool
isWHNF LHsExpr GhcPs
x
      isType "Wildcard" x :: 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 "Nat" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just x :: Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = Bool
True
      isType "Pos" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just x :: Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>  0 = Bool
True
      isType "Neg" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just x :: Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  0 = Bool
True
      isType "NegZero" (LHsExpr GhcPs -> Maybe Integer
asInt -> Just x :: Integer
x) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = Bool
True
      isType "LitInt" (LL _ (HsLit _ HsInt{})) = Bool
True
      isType "LitInt" (LL _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = Bool
True
      isType "Var" (LL _ HsVar{}) = Bool
True
      isType "App" (LL _ HsApp{}) = Bool
True
      isType "InfixApp" (LL _ x :: SrcSpanLess (LHsExpr GhcPs)
x@OpApp{}) = Bool
True
      isType "Paren" (LL _ x :: SrcSpanLess (LHsExpr GhcPs)
x@HsPar{}) = Bool
True
      isType "Tuple" (LL _ ExplicitTuple{}) = Bool
True

      isType typ :: String
typ (LL _ x :: SrcSpanLess (LHsExpr GhcPs)
x) =
        let top :: String
top = Constr -> String
showConstr (HsExpr GhcPs -> Constr
forall a. Data a => a -> Constr
toConstr SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
x) in
        String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
top
      isType _ _ = Bool
False -- {-# COMPLETE LL#-}

      asInt :: LHsExpr GhcPs -> Maybe Integer
      asInt :: LHsExpr GhcPs -> Maybe Integer
asInt (LL _ (HsPar _ x)) = LHsExpr GhcPs -> Maybe Integer
asInt LHsExpr GhcPs
x
      asInt (LL _ (NegApp _ x _)) = 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 (LL _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ if Bool
neg then -Integer
x else Integer
x
      asInt (LL _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ if Bool
neg then -Integer
x else Integer
x
      asInt _ = Maybe Integer
forall a. Maybe a
Nothing

      list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
      list :: LHsExpr GhcPs -> [LHsExpr GhcPs]
list (LL _ (ExplicitList _ _ xs)) = [LHsExpr GhcPs]
xs
      list x :: 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_' x :: String
x) | Just y :: 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 x :: 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' declName :: String
declName Nothing y :: LHsExpr GhcPs
y =
  let funOrOp :: LHsExpr p -> LHsExpr p
funOrOp expr :: LHsExpr p
expr = case LHsExpr p
expr of
        LL _ (HsApp _ fun _) -> LHsExpr p -> LHsExpr p
funOrOp LHsExpr p
fun
        LL _ (OpApp _ _ op _) -> LHsExpr p -> LHsExpr p
funOrOp LHsExpr p
op
        other :: 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' _ _ _ = Bool
True

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

-- If it has '_eval_' do evaluation on it.
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 (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs
fEval
  where
    fEval, fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
    fEval :: LHsExpr GhcPs -> LHsExpr GhcPs
fEval (LL _ (HsApp _ e x)) | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "_eval_" = LHsExpr GhcPs -> LHsExpr GhcPs
reduce' LHsExpr GhcPs
x
    fEval x :: LHsExpr GhcPs
x = LHsExpr GhcPs
x
    fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fNoParen (LL _ (HsApp _ e x)) | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "_noParen_" = LHsExpr GhcPs -> LHsExpr GhcPs
fromParen' LHsExpr GhcPs
x
    fNoParen x :: 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' from :: Scope'
from to :: 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 _ (Unqual s :: OccName
s)) | String -> Bool
isUnifyVar (OccName -> String
occNameString OccName
s) = Located RdrName
x
    f x :: 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 (i :: Int
i, p :: LHsExpr GhcPs
p)) c :: LHsExpr GhcPs
c | Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld' Int
i LHsExpr GhcPs
p LHsExpr GhcPs
c = SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr 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 NoExt
XPar GhcPs
noExt LHsExpr GhcPs
c
addBracket' _ x :: 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 (LL _ (HsAppTy _ t x@(LL _ HsAppTy{}))) =
      SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExt
XAppTy GhcPs
noExt LHsType GhcPs
t (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExt
XParTy GhcPs
noExt LHsType GhcPs
x)))
    f x :: LHsType GhcPs
x = LHsType GhcPs
x