{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}

module GHC.Util.FreeVars (
    vars, varss, pvars,
    Vars (..), FreeVars(..) , AllVars (..)
  ) where

import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence
import GHC.Types.Name
import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Data.Bag (bagToList)

import Data.Generics.Uniplate.DataOnly
import Data.Monoid
import Data.Semigroup
import Data.List.Extra
import Data.Set (Set)
import qualified Data.Set as Set
import Prelude

( ^+ ) :: Set OccName -> Set OccName -> Set OccName
( ^+ ) = Set OccName -> Set OccName -> Set OccName
forall a. Ord a => Set a -> Set a -> Set a
Set.union
( ^- ) :: Set OccName -> Set OccName -> Set OccName
( ^- ) = Set OccName -> Set OccName -> Set OccName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference

-- See [Note : Space leaks lurking here?] below.
data Vars = Vars{Vars -> Set OccName
bound :: Set OccName, Vars -> Set OccName
free :: Set OccName}

-- Useful for debugging.
instance Show Vars where
  show :: Vars -> String
show (Vars Set OccName
bs Set OccName
fs) = String
"bound : " String -> ShowS
forall a. [a] -> [a] -> [a]
++
    [String] -> String
forall a. Show a => a -> String
show ((OccName -> String) -> [OccName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map OccName -> String
occNameString (Set OccName -> [OccName]
forall a. Set a -> [a]
Set.toList Set OccName
bs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", free : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((OccName -> String) -> [OccName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map OccName -> String
occNameString (Set OccName -> [OccName]
forall a. Set a -> [a]
Set.toList Set OccName
fs))

instance Semigroup Vars where
    Vars Set OccName
x1 Set OccName
x2 <> :: Vars -> Vars -> Vars
<> Vars Set OccName
y1 Set OccName
y2 = Set OccName -> Set OccName -> Vars
Vars (Set OccName
x1 Set OccName -> Set OccName -> Set OccName
^+ Set OccName
y1) (Set OccName
x2 Set OccName -> Set OccName -> Set OccName
^+ Set OccName
y2)

instance Monoid Vars where
    mempty :: Vars
mempty = Set OccName -> Set OccName -> Vars
Vars Set OccName
forall a. Set a
Set.empty Set OccName
forall a. Set a
Set.empty
    mconcat :: [Vars] -> Vars
mconcat [Vars]
vs = Set OccName -> Set OccName -> Vars
Vars ([Set OccName] -> Set OccName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set OccName] -> Set OccName) -> [Set OccName] -> Set OccName
forall a b. (a -> b) -> a -> b
$ (Vars -> Set OccName) -> [Vars] -> [Set OccName]
forall a b. (a -> b) -> [a] -> [b]
map Vars -> Set OccName
bound [Vars]
vs) ([Set OccName] -> Set OccName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set OccName] -> Set OccName) -> [Set OccName] -> Set OccName
forall a b. (a -> b) -> a -> b
$ (Vars -> Set OccName) -> [Vars] -> [Set OccName]
forall a b. (a -> b) -> [a] -> [b]
map Vars -> Set OccName
free [Vars]
vs)

-- A type `a` is a model of `AllVars a` if exists a function
-- `allVars` for producing a pair of the bound and free varaiable
-- sets in a value of `a`.
class AllVars a where
    -- | Return the variables, erring on the side of more free
    -- variables.
    allVars :: a -> Vars

-- A type `a` is a model of `FreeVars a` if exists a function
-- `freeVars` for producing a set of free varaiable of a value of
-- `a`.
class FreeVars a where
    -- | Return the variables, erring on the side of more free
    -- variables.
    freeVars :: a -> Set OccName

-- Trivial instances.
instance AllVars Vars  where allVars :: Vars -> Vars
allVars = Vars -> Vars
forall a. a -> a
id
instance FreeVars (Set OccName) where freeVars :: Set OccName -> Set OccName
freeVars = Set OccName -> Set OccName
forall a. a -> a
id
-- [Note : Space leaks lurking here?]
-- ==================================
-- We make use of `foldr`. @cocreature suggests we want bangs on `data
-- Vars` and replace usages of `mconcat` with `foldl`.
instance (AllVars a) => AllVars [a] where  allVars :: [a] -> Vars
allVars = (a -> Vars) -> [a] -> Vars
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap a -> Vars
forall a. AllVars a => a -> Vars
allVars
instance (FreeVars a) => FreeVars [a] where  freeVars :: [a] -> Set OccName
freeVars = [Set OccName] -> Set OccName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set OccName] -> Set OccName)
-> ([a] -> [Set OccName]) -> [a] -> Set OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set OccName) -> [a] -> [Set OccName]
forall a b. (a -> b) -> [a] -> [b]
map a -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars

-- Construct a `Vars` value with no bound vars.
freeVars_ :: (FreeVars a) => a -> Vars
freeVars_ :: a -> Vars
freeVars_ = Set OccName -> Set OccName -> Vars
Vars Set OccName
forall a. Set a
Set.empty (Set OccName -> Vars) -> (a -> Set OccName) -> a -> Vars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars

-- `inFree a b` is the set of free variables in a together with the
-- free variables in b not bound in a.
inFree :: (AllVars a, FreeVars b) => a -> b -> Set OccName
inFree :: a -> b -> Set OccName
inFree a
a b
b = Vars -> Set OccName
free Vars
aa Set OccName -> Set OccName -> Set OccName
^+ (b -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars b
b Set OccName -> Set OccName -> Set OccName
^- Vars -> Set OccName
bound Vars
aa)
    where aa :: Vars
aa = a -> Vars
forall a. AllVars a => a -> Vars
allVars a
a

-- `inVars a b` is a value of `Vars_` with bound variables the union
-- of the bound variables of a and b and free variables the union
-- of the free variables of a and the free variables of b not
-- bound by a.
inVars :: (AllVars a, AllVars b) => a -> b -> Vars
inVars :: a -> b -> Vars
inVars a
a b
b =
  Set OccName -> Set OccName -> Vars
Vars (Vars -> Set OccName
bound Vars
aa Set OccName -> Set OccName -> Set OccName
^+ Vars -> Set OccName
bound Vars
bb) (Vars -> Set OccName
free Vars
aa Set OccName -> Set OccName -> Set OccName
^+ (Vars -> Set OccName
free Vars
bb Set OccName -> Set OccName -> Set OccName
^- Vars -> Set OccName
bound Vars
aa))
    where aa :: Vars
aa = a -> Vars
forall a. AllVars a => a -> Vars
allVars a
a
          bb :: Vars
bb = b -> Vars
forall a. AllVars a => a -> Vars
allVars b
b

-- Get an `OccName` out of a reader name.
unqualNames :: Located RdrName -> [OccName]
unqualNames :: Located RdrName -> [OccName]
unqualNames (L SrcSpan
_ (Unqual OccName
x)) = [OccName
x]
unqualNames (L SrcSpan
_ (Exact Name
x)) = [Name -> OccName
nameOccName Name
x]
unqualNames Located RdrName
_ = []

instance FreeVars (LHsExpr GhcPs) where
  freeVars :: LHsExpr GhcPs -> Set OccName
freeVars (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x)) = [OccName] -> Set OccName
forall a. Ord a => [a] -> Set a
Set.fromList ([OccName] -> Set OccName) -> [OccName] -> Set OccName
forall a b. (a -> b) -> a -> b
$ Located RdrName -> [OccName]
unqualNames Located (IdP GhcPs)
Located RdrName
x -- Variable.
  freeVars (L SrcSpan
_ (HsUnboundVar XUnboundVar GhcPs
_ OccName
x)) = [OccName] -> Set OccName
forall a. Ord a => [a] -> Set a
Set.fromList [OccName
x] -- Unbound variable; also used for "holes".
  freeVars (L SrcSpan
_ (HsLam XLam GhcPs
_ MatchGroup GhcPs (LHsExpr GhcPs)
mg)) = Vars -> Set OccName
free (MatchGroup GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars MatchGroup GhcPs (LHsExpr GhcPs)
mg) -- Lambda abstraction. Currently always a single match.
  freeVars (L SrcSpan
_ (HsLamCase XLamCase GhcPs
_ MG{mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=(L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
ms)})) = Vars -> Set OccName
free ([LMatch GhcPs (LHsExpr GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LMatch GhcPs (LHsExpr GhcPs)]
ms) -- Lambda case
  freeVars (L SrcSpan
_ (HsCase XCase GhcPs
_ LHsExpr GhcPs
of_ MG{mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=(L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
ms)})) = LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
of_ Set OccName -> Set OccName -> Set OccName
^+ Vars -> Set OccName
free ([LMatch GhcPs (LHsExpr GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LMatch GhcPs (LHsExpr GhcPs)]
ms) -- Case expr.
  freeVars (L SrcSpan
_ (HsLet XLet GhcPs
_ LHsLocalBinds GhcPs
binds LHsExpr GhcPs
e)) = LHsLocalBinds GhcPs -> LHsExpr GhcPs -> Set OccName
forall a b. (AllVars a, FreeVars b) => a -> b -> Set OccName
inFree LHsLocalBinds GhcPs
binds LHsExpr GhcPs
e -- Let (rec).
  freeVars (L SrcSpan
_ (HsDo XDo GhcPs
_ HsStmtContext GhcRn
ctxt (L SrcSpan
_ [ExprLStmt GhcPs]
stmts))) = Vars -> Set OccName
free ([ExprLStmt GhcPs] -> Vars
forall a. AllVars a => a -> Vars
allVars [ExprLStmt GhcPs]
stmts) -- Do block.
  freeVars (L SrcSpan
_ (RecordCon XRecordCon GhcPs
_ Located (IdP GhcPs)
_ (HsRecFields [LHsRecField GhcPs (LHsExpr GhcPs)]
flds Maybe (Located Int)
_))) = [Set OccName] -> Set OccName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set OccName] -> Set OccName) -> [Set OccName] -> Set OccName
forall a b. (a -> b) -> a -> b
$ (LHsRecField GhcPs (LHsExpr GhcPs) -> Set OccName)
-> [LHsRecField GhcPs (LHsExpr GhcPs)] -> [Set OccName]
forall a b. (a -> b) -> [a] -> [b]
map LHsRecField GhcPs (LHsExpr GhcPs) -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars [LHsRecField GhcPs (LHsExpr GhcPs)]
flds -- Record construction.
  freeVars (L SrcSpan
_ (RecordUpd XRecordUpd GhcPs
_ LHsExpr GhcPs
e [LHsRecUpdField GhcPs]
flds)) = [Set OccName] -> Set OccName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set OccName] -> Set OccName) -> [Set OccName] -> Set OccName
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. a -> [a] -> [a]
: (LHsRecUpdField GhcPs -> Set OccName)
-> [LHsRecUpdField GhcPs] -> [Set OccName]
forall a b. (a -> b) -> [a] -> [b]
map LHsRecUpdField GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars [LHsRecUpdField GhcPs]
flds -- Record update.
  freeVars (L SrcSpan
_ (HsMultiIf XMultiIf GhcPs
_ [LGRHS GhcPs (LHsExpr GhcPs)]
grhss)) = Vars -> Set OccName
free ([LGRHS GhcPs (LHsExpr GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LGRHS GhcPs (LHsExpr GhcPs)]
grhss) -- Multi-way if.
  freeVars (L SrcSpan
_ (HsBracket XBracket GhcPs
_ (ExpBr XExpBr GhcPs
_ LHsExpr GhcPs
e))) = LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
e
  freeVars (L SrcSpan
_ (HsBracket XBracket GhcPs
_ (VarBr XVarBr GhcPs
_ Bool
_ IdP GhcPs
v))) = [OccName] -> Set OccName
forall a. Ord a => [a] -> Set a
Set.fromList [RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName IdP GhcPs
RdrName
v]

  freeVars (L SrcSpan
_ HsConLikeOut{}) = Set OccName
forall a. Monoid a => a
mempty -- After typechecker.
  freeVars (L SrcSpan
_ HsRecFld{}) = Set OccName
forall a. Monoid a => a
mempty -- Variable pointing to a record selector.
  freeVars (L SrcSpan
_ HsOverLabel{}) = Set OccName
forall a. Monoid a => a
mempty -- Overloaded label. The id of the in-scope fromLabel.
  freeVars (L SrcSpan
_ HsIPVar{}) = Set OccName
forall a. Monoid a => a
mempty -- Implicit parameter.
  freeVars (L SrcSpan
_ HsOverLit{}) = Set OccName
forall a. Monoid a => a
mempty -- Overloaded literal.
  freeVars (L SrcSpan
_ HsLit{}) = Set OccName
forall a. Monoid a => a
mempty -- Simple literal.
  freeVars (L SrcSpan
_ HsRnBracketOut{}) = Set OccName
forall a. Monoid a => a
mempty -- Renamer produces these.
  freeVars (L SrcSpan
_ HsTcBracketOut{}) = Set OccName
forall a. Monoid a => a
mempty -- Typechecker produces these.

  -- freeVars (e@(L _ HsAppType{})) = freeVars $ children e -- Visible type application e.g. f @ Int x y.
  -- freeVars (e@(L _ HsApp{})) = freeVars $ children e -- Application.
  -- freeVars (e@(L _ OpApp{})) = freeVars $ children e -- Operator application.
  -- freeVars (e@(L _ NegApp{})) = freeVars $ children e -- Negation operator.
  -- freeVars (e@(L _ HsPar{})) = freeVars $ children e -- Parenthesized expr.
  -- freeVars (e@(L _ SectionL{})) = freeVars $ children e -- Left section.
  -- freeVars (e@(L _ SectionR{})) = freeVars $ children e -- Right section.
  -- freeVars (e@(L _ ExplicitTuple{})) = freeVars $ children e -- Explicit tuple and sections thereof.
  -- freeVars (e@(L _ ExplicitSum{})) = freeVars $ children e -- Used for unboxed sum types.
  -- freeVars (e@(L _ HsIf{})) = freeVars $ children e -- If.
  -- freeVars (e@(L _ ExplicitList{})) = freeVars $ children e -- Syntactic list e.g. [a, b, c].
  -- freeVars (e@(L _ ExprWithTySig{})) = freeVars $ children e -- Expr with type signature.
  -- freeVars (e@(L _ ArithSeq {})) = freeVars $ children e -- Arithmetic sequence.
  -- freeVars (e@(L _ HsSCC{})) = freeVars $ children e -- Set cost center pragma (expr whose const is to be measured).
  -- freeVars (e@(L _ HsCoreAnn{})) = freeVars $ children e -- Pragma.
  -- freeVars (e@(L _ HsBracket{})) = freeVars $ children e -- Haskell bracket.
  -- freeVars (e@(L _ HsSpliceE{})) = freeVars $ children e -- Template haskell splice expr.
  -- freeVars (e@(L _ HsProc{})) = freeVars $ children e -- Proc notation for arrows.
  -- freeVars (e@(L _ HsStatic{})) = freeVars $ children e -- Static pointers extension.
  -- freeVars (e@(L _ HsArrApp{})) = freeVars $ children e -- Arrow tail or arrow application.
  -- freeVars (e@(L _ HsArrForm{})) = freeVars $ children e -- Come back to it. Arrow tail or arrow application.
  -- freeVars (e@(L _ HsTick{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.
  -- freeVars (e@(L _ HsBinTick{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.
  -- freeVars (e@(L _ HsTickPragma{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.
  -- freeVars (e@(L _ EAsPat{})) = freeVars $ children e -- Expr as pat.
  -- freeVars (e@(L _ EViewPat{})) = freeVars $ children e -- View pattern.
  -- freeVars (e@(L _ ELazyPat{})) = freeVars $ children e -- Lazy pattern.

  freeVars LHsExpr GhcPs
e = [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
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
children LHsExpr GhcPs
e

instance FreeVars (LHsTupArg GhcPs) where
  freeVars :: LHsTupArg GhcPs -> Set OccName
freeVars (L SrcSpan
_ (Present XPresent GhcPs
_ LHsExpr GhcPs
args)) = LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
args
  freeVars LHsTupArg GhcPs
_ = Set OccName
forall a. Monoid a => a
mempty

instance FreeVars (LHsRecField GhcPs (LHsExpr GhcPs)) where
   freeVars :: LHsRecField GhcPs (LHsExpr GhcPs) -> Set OccName
freeVars o :: LHsRecField GhcPs (LHsExpr GhcPs)
o@(L SrcSpan
_ (HsRecField Located (FieldOcc GhcPs)
x LHsExpr GhcPs
_ Bool
True)) = OccName -> Set OccName
forall a. a -> Set a
Set.singleton (OccName -> Set OccName) -> OccName -> Set OccName
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName (RdrName -> OccName) -> RdrName -> OccName
forall a b. (a -> b) -> a -> b
$ Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (Located RdrName -> RdrName) -> Located RdrName -> RdrName
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> Located RdrName
forall pass. FieldOcc pass -> Located RdrName
rdrNameFieldOcc (FieldOcc GhcPs -> Located RdrName)
-> FieldOcc GhcPs -> Located RdrName
forall a b. (a -> b) -> a -> b
$ Located (FieldOcc GhcPs) -> FieldOcc GhcPs
forall l e. GenLocated l e -> e
unLoc Located (FieldOcc GhcPs)
x -- a pun
   freeVars o :: LHsRecField GhcPs (LHsExpr GhcPs)
o@(L SrcSpan
_ (HsRecField Located (FieldOcc GhcPs)
_ LHsExpr GhcPs
x Bool
_)) = LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
x

instance FreeVars (LHsRecUpdField GhcPs) where
  freeVars :: LHsRecUpdField GhcPs -> Set OccName
freeVars (L SrcSpan
_ (HsRecField Located (AmbiguousFieldOcc GhcPs)
_ LHsExpr GhcPs
x Bool
_)) = LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
x

instance AllVars (Located (Pat GhcPs)) where
  allVars :: Located (Pat GhcPs) -> Vars
allVars (L SrcSpan
_ (VarPat XVarPat GhcPs
_ (L SrcSpan
_ IdP GhcPs
x))) = Set OccName -> Set OccName -> Vars
Vars (OccName -> Set OccName
forall a. a -> Set a
Set.singleton (OccName -> Set OccName) -> OccName -> Set OccName
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc IdP GhcPs
RdrName
x) Set OccName
forall a. Set a
Set.empty -- Variable pattern.
  allVars (L SrcSpan
_ (AsPat XAsPat GhcPs
_  Located (IdP GhcPs)
n LPat GhcPs
x)) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars (Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField Located (IdP GhcPs)
n :: LPat GhcPs) Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars LPat GhcPs
Located (Pat GhcPs)
x -- As pattern.
  allVars (L SrcSpan
_ (ConPat XConPat GhcPs
_ Located (ConLikeP GhcPs)
_ (RecCon (HsRecFields [LHsRecField GhcPs (LPat GhcPs)]
flds Maybe (Located Int)
_)))) = [LHsRecField GhcPs (Located (Pat GhcPs))] -> Vars
forall a. AllVars a => a -> Vars
allVars [LHsRecField GhcPs (LPat GhcPs)]
[LHsRecField GhcPs (Located (Pat GhcPs))]
flds
  allVars (L SrcSpan
_ (NPlusKPat XNPlusKPat GhcPs
_ Located (IdP GhcPs)
n Located (HsOverLit GhcPs)
_ HsOverLit GhcPs
_ SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars (Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField Located (IdP GhcPs)
n :: LPat GhcPs) -- n+k pattern.
  allVars (L SrcSpan
_ (ViewPat XViewPat GhcPs
_ LHsExpr GhcPs
e LPat GhcPs
p)) = LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ LHsExpr GhcPs
e Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars LPat GhcPs
Located (Pat GhcPs)
p -- View pattern.

  allVars (L SrcSpan
_ WildPat{}) = Vars
forall a. Monoid a => a
mempty -- Wildcard pattern.
  allVars (L SrcSpan
_ LitPat{}) = Vars
forall a. Monoid a => a
mempty -- Literal pattern.
  allVars (L SrcSpan
_ NPat{}) = Vars
forall a. Monoid a => a
mempty -- Natural pattern.

  -- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes).
  -- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.
  -- allVars p@CoPat{} = allVars $ children p -- Coercion pattern.
  -- allVars p@LazyPat{} = allVars $ children p -- Lazy pattern.
  -- allVars p@ParPat{} = allVars $ children p -- Parenthesized pattern.
  -- allVars p@BangPat{} = allVars $ children p -- Bang pattern.
  -- allVars p@ListPat{} = allVars $ children p -- Syntactic list.
  -- allVars p@TuplePat{} = allVars $ children p -- Tuple sub patterns.
  -- allVars p@SumPat{} = allVars $ children p -- Anonymous sum pattern.

  allVars Located (Pat GhcPs)
p = [Located (Pat GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars ([Located (Pat GhcPs)] -> Vars) -> [Located (Pat GhcPs)] -> Vars
forall a b. (a -> b) -> a -> b
$ Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall on. Uniplate on => on -> [on]
children Located (Pat GhcPs)
p

instance AllVars (LHsRecField GhcPs (Located (Pat GhcPs))) where
   allVars :: LHsRecField GhcPs (Located (Pat GhcPs)) -> Vars
allVars (L SrcSpan
_ (HsRecField Located (FieldOcc GhcPs)
_ Located (Pat GhcPs)
x Bool
_)) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars Located (Pat GhcPs)
x

instance AllVars (LStmt GhcPs (LHsExpr GhcPs)) where
  allVars :: ExprLStmt GhcPs -> Vars
allVars (L SrcSpan
_ (LastStmt XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
expr Maybe Bool
_ SyntaxExpr GhcPs
_)) = LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ LHsExpr GhcPs
expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr.
  allVars (L SrcSpan
_ (BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LPat GhcPs
pat LHsExpr GhcPs
expr)) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars LPat GhcPs
Located (Pat GhcPs)
pat Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ LHsExpr GhcPs
expr -- A generator e.g. x <- [1, 2, 3].
  allVars (L SrcSpan
_ (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) = LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ LHsExpr GhcPs
expr -- A boolean guard e.g. even x.
  allVars (L SrcSpan
_ (LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsLocalBinds GhcPs
binds)) = LHsLocalBinds GhcPs -> Vars
forall a. AllVars a => a -> Vars
allVars LHsLocalBinds GhcPs
binds -- A local declaration e.g. let y = x + 1
  allVars (L SrcSpan
_ (TransStmt XTransStmt GhcPs GhcPs (LHsExpr GhcPs)
_ TransForm
_ [ExprLStmt GhcPs]
stmts [(IdP GhcPs, IdP GhcPs)]
_ LHsExpr GhcPs
using Maybe (LHsExpr GhcPs)
by SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_ HsExpr GhcPs
fmap_)) = [ExprLStmt GhcPs] -> Vars
forall a. AllVars a => a -> Vars
allVars [ExprLStmt GhcPs]
stmts Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ LHsExpr GhcPs
using Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> Vars -> (LHsExpr GhcPs -> Vars) -> Maybe (LHsExpr GhcPs) -> Vars
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Vars
forall a. Monoid a => a
mempty LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ Maybe (LHsExpr GhcPs)
by Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc HsExpr GhcPs
fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.
  allVars (L SrcSpan
_ (RecStmt XRecStmt GhcPs GhcPs (LHsExpr GhcPs)
_ [ExprLStmt GhcPs]
stmts [IdP GhcPs]
_ [IdP GhcPs]
_ SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) = [ExprLStmt GhcPs] -> Vars
forall a. AllVars a => a -> Vars
allVars [ExprLStmt GhcPs]
stmts -- A recursive binding for a group of arrows.

  allVars (L SrcSpan
_ ApplicativeStmt{}) = Vars
forall a. Monoid a => a
mempty -- Generated by the renamer.
  allVars (L SrcSpan
_ ParStmt{}) = Vars
forall a. Monoid a => a
mempty -- Parallel list thing. Come back to it.

instance AllVars (LHsLocalBinds GhcPs) where
  allVars :: LHsLocalBinds GhcPs -> Vars
allVars (L SrcSpan
_ (HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
_))) = [LHsBindLR GhcPs GhcPs] -> Vars
forall a. AllVars a => a -> Vars
allVars (LHsBindsLR GhcPs GhcPs -> [LHsBindLR GhcPs GhcPs]
forall a. Bag a -> [a]
bagToList LHsBindsLR GhcPs GhcPs
binds) -- Value bindings.
  allVars (L SrcSpan
_ (HsIPBinds XHsIPBinds GhcPs GhcPs
_ (IPBinds XIPBinds GhcPs
_ [LIPBind GhcPs]
binds))) = [LIPBind GhcPs] -> Vars
forall a. AllVars a => a -> Vars
allVars [LIPBind GhcPs]
binds -- Implicit parameter bindings.
  allVars (L SrcSpan
_ EmptyLocalBinds{}) =  Vars
forall a. Monoid a => a
mempty -- The case of no local bindings (signals the empty `let` or `where` clause).
  allVars LHsLocalBinds GhcPs
_ = Vars
forall a. Monoid a => a
mempty -- extension points

instance AllVars (LIPBind GhcPs) where
  allVars :: LIPBind GhcPs -> Vars
allVars (L SrcSpan
_ (IPBind XCIPBind GhcPs
_ Either (Located HsIPName) (IdP GhcPs)
_ LHsExpr GhcPs
e)) = LHsExpr GhcPs -> Vars
forall a. FreeVars a => a -> Vars
freeVars_ LHsExpr GhcPs
e

instance AllVars (LHsBind GhcPs) where
  allVars :: LHsBindLR GhcPs GhcPs -> Vars
allVars (L SrcSpan
_ FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id=Located (IdP GhcPs)
n, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=MG{mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=(L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
ms)}}) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars (Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField Located (IdP GhcPs)
n :: LPat GhcPs) Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> [LMatch GhcPs (LHsExpr GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LMatch GhcPs (LHsExpr GhcPs)]
ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e
  allVars (L SrcSpan
_ PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs=LPat GhcPs
n, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs=GRHSs GhcPs (LHsExpr GhcPs)
grhss}) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars LPat GhcPs
Located (Pat GhcPs)
n Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> GRHSs GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars GRHSs GhcPs (LHsExpr GhcPs)
grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e.

  allVars (L SrcSpan
_ (PatSynBind XPatSynBind GhcPs GhcPs
_ PSB{})) = Vars
forall a. Monoid a => a
mempty -- Come back to it.
  allVars (L SrcSpan
_ VarBind{}) = Vars
forall a. Monoid a => a
mempty -- Typechecker.
  allVars (L SrcSpan
_ AbsBinds{}) = Vars
forall a. Monoid a => a
mempty -- Not sure but I think renamer.

instance AllVars (MatchGroup GhcPs (LHsExpr GhcPs)) where
  allVars :: MatchGroup GhcPs (LHsExpr GhcPs) -> Vars
allVars (MG XMG GhcPs (LHsExpr GhcPs)
_ _alts :: GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
_alts@(L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
alts) Origin
_) = Vars -> Vars -> Vars
forall a b. (AllVars a, AllVars b) => a -> b -> Vars
inVars ((Match GhcPs (LHsExpr GhcPs) -> Vars)
-> [Match GhcPs (LHsExpr GhcPs)] -> Vars
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Located (Pat GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars ([Located (Pat GhcPs)] -> Vars)
-> (Match GhcPs (LHsExpr GhcPs) -> [Located (Pat GhcPs)])
-> Match GhcPs (LHsExpr GhcPs)
-> Vars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match GhcPs (LHsExpr GhcPs) -> [Located (Pat GhcPs)]
forall p body. Match p body -> [LPat p]
m_pats) [Match GhcPs (LHsExpr GhcPs)]
ms) ([GRHSs GhcPs (LHsExpr GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars ((Match GhcPs (LHsExpr GhcPs) -> GRHSs GhcPs (LHsExpr GhcPs))
-> [Match GhcPs (LHsExpr GhcPs)] -> [GRHSs GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map Match GhcPs (LHsExpr GhcPs) -> GRHSs GhcPs (LHsExpr GhcPs)
forall p body. Match p body -> GRHSs p body
m_grhss [Match GhcPs (LHsExpr GhcPs)]
ms))
    where ms :: [Match GhcPs (LHsExpr GhcPs)]
ms = (LMatch GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs))
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [Match GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LMatch GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs)
forall l e. GenLocated l e -> e
unLoc [LMatch GhcPs (LHsExpr GhcPs)]
alts

instance AllVars (LMatch GhcPs (LHsExpr GhcPs)) where
  allVars :: LMatch GhcPs (LHsExpr GhcPs) -> Vars
allVars (L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_ FunRhs {mc_fun :: forall p. HsMatchContext p -> LIdP p
mc_fun=LIdP (NoGhcTc GhcPs)
name} [LPat GhcPs]
pats GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars (Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField Located (IdP GhcPs)
LIdP (NoGhcTc GhcPs)
name :: LPat GhcPs) Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> [Located (Pat GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LPat GhcPs]
[Located (Pat GhcPs)]
pats Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> GRHSs GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars GRHSs GhcPs (LHsExpr GhcPs)
grhss -- A pattern matching on an argument of a function binding.
  allVars (L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_ (StmtCtxt HsStmtContext (NoGhcTc GhcPs)
ctxt) [LPat GhcPs]
pats GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = HsStmtContext GhcPs -> Vars
forall a. AllVars a => a -> Vars
allVars HsStmtContext GhcPs
HsStmtContext (NoGhcTc GhcPs)
ctxt Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> [Located (Pat GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LPat GhcPs]
[Located (Pat GhcPs)]
pats Vars -> Vars -> Vars
forall a. Semigroup a => a -> a -> a
<> GRHSs GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars GRHSs GhcPs (LHsExpr GhcPs)
grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.
  allVars (L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NoGhcTc GhcPs)
_ [LPat GhcPs]
pats GRHSs GhcPs (LHsExpr GhcPs)
grhss)) = Vars -> Vars -> Vars
forall a b. (AllVars a, AllVars b) => a -> b -> Vars
inVars ([Located (Pat GhcPs)] -> Vars
forall a. AllVars a => a -> Vars
allVars [LPat GhcPs]
[Located (Pat GhcPs)]
pats) (GRHSs GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars GRHSs GhcPs (LHsExpr GhcPs)
grhss) -- Everything else.

instance AllVars (HsStmtContext GhcPs) where
  allVars :: HsStmtContext GhcPs -> Vars
allVars (PatGuard FunRhs{mc_fun :: forall p. HsMatchContext p -> LIdP p
mc_fun=Located (IdP GhcPs)
n}) = Located (Pat GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars (Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField Located (IdP GhcPs)
n :: LPat GhcPs)
  allVars ParStmtCtxt{} = Vars
forall a. Monoid a => a
mempty -- Come back to it.
  allVars TransStmtCtxt{}  = Vars
forall a. Monoid a => a
mempty -- Come back to it.
  allVars HsStmtContext GhcPs
_ = Vars
forall a. Monoid a => a
mempty

instance AllVars (GRHSs GhcPs (LHsExpr GhcPs)) where
  allVars :: GRHSs GhcPs (LHsExpr GhcPs) -> Vars
allVars (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
grhss LHsLocalBinds GhcPs
binds) = LHsLocalBinds GhcPs -> Vars -> Vars
forall a b. (AllVars a, AllVars b) => a -> b -> Vars
inVars LHsLocalBinds GhcPs
binds ((LGRHS GhcPs (LHsExpr GhcPs) -> Vars)
-> [LGRHS GhcPs (LHsExpr GhcPs)] -> Vars
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap LGRHS GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars [LGRHS GhcPs (LHsExpr GhcPs)]
grhss)

instance AllVars (LGRHS GhcPs (LHsExpr GhcPs)) where
  allVars :: LGRHS GhcPs (LHsExpr GhcPs) -> Vars
allVars (L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [ExprLStmt GhcPs]
guards LHsExpr GhcPs
expr)) = Set OccName -> Set OccName -> Vars
Vars (Vars -> Set OccName
bound Vars
gs) (Vars -> Set OccName
free Vars
gs Set OccName -> Set OccName -> Set OccName
^+ (LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
expr Set OccName -> Set OccName -> Set OccName
^- Vars -> Set OccName
bound Vars
gs)) where gs :: Vars
gs = [ExprLStmt GhcPs] -> Vars
forall a. AllVars a => a -> Vars
allVars [ExprLStmt GhcPs]
guards

instance AllVars (LHsDecl GhcPs) where
  allVars :: LHsDecl GhcPs -> Vars
allVars (L SrcSpan
l (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
bind)) = LHsBindLR GhcPs GhcPs -> Vars
forall a. AllVars a => a -> Vars
allVars (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBindLR GhcPs GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsBindLR GhcPs GhcPs
bind :: LHsBind GhcPs)
  allVars LHsDecl GhcPs
_ = Vars
forall a. Monoid a => a
mempty


vars :: FreeVars a => a -> [String]
vars :: a -> [String]
vars = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> (a -> Set String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String)
-> (a -> Set OccName) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars

varss :: AllVars a => a -> [String]
varss :: a -> [String]
varss = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> (a -> Set String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String)
-> (a -> Set OccName) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vars -> Set OccName
free (Vars -> Set OccName) -> (a -> Vars) -> a -> Set OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vars
forall a. AllVars a => a -> Vars
allVars

pvars :: AllVars a => a -> [String]
pvars :: a -> [String]
pvars = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> (a -> Set String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String)
-> (a -> Set OccName) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vars -> Set OccName
bound (Vars -> Set OccName) -> (a -> Vars) -> a -> Set OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vars
forall a. AllVars a => a -> Vars
allVars