{-# OPTIONS -fno-warn-name-shadowing #-}
{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE ImplicitParams        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE UndecidableInstances  #-}

-- MonoLocalBinds extension prevents premature generalization, which
-- results in the "default" instance being picked.
{-# LANGUAGE MonoLocalBinds        #-}
module Language.Haskell.Names.Open.Instances () where

import           Fay.Compiler.Prelude
import           Language.Haskell.Names.GetBound
import           Language.Haskell.Names.Open.Base
import           Language.Haskell.Names.Open.Derived    ()
import           Language.Haskell.Names.RecordWildcards
import           Language.Haskell.Names.Types

import           Data.Lens.Light
import qualified Data.Traversable                       as T
import           Language.Haskell.Exts

c :: Applicative w => c -> w c
c :: c -> w c
c = c -> w c
forall (f :: * -> *) a. Applicative f => a -> f a
pure

(<|)
  :: (Applicative w, Resolvable b, ?alg :: Alg w)
  => w (b -> c) -> (b, Scope) -> w c
<| :: w (b -> c) -> (b, Scope) -> w c
(<|) w (b -> c)
k (b
b, Scope
sc) = w (b -> c)
k w (b -> c) -> w b -> w c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> Scope -> w b
forall (w :: * -> *) d.
(?alg::Alg w, Resolvable d) =>
d -> Scope -> w d
alg b
b Scope
sc
infixl 4 <|

(-:) :: Scope -> a -> (a, Scope)
Scope
sc -: :: Scope -> a -> (a, Scope)
-: a
b = (a
b, Scope
sc)
infix 5 -:

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Decl l) where
  rtraverse :: Decl l -> Scope -> f (Decl l)
rtraverse Decl l
e Scope
sc =
    case Decl l
e of
      -- N.B. We do not add pat to the local scope.
      --
      -- If this is a top-level binding, then we shouldn't do so, lest
      -- global values are marked as local.
      -- (see https://github.com/haskell-suite/haskell-names/issues/35)
      --
      -- If this is a local binding, then we have already introduced these
      -- variables when processing the enclosing Binds.
      PatBind l
l Pat l
pat Rhs l
rhs Maybe (Binds l)
mbWhere ->
        let
          scWithWhere :: Scope
scWithWhere = Maybe (Binds l) -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro Maybe (Binds l)
mbWhere Scope
sc
        in
        (l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l)
-> f (l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind
          f (l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l)
-> (l, Scope) -> f (Pat l -> Rhs l -> Maybe (Binds l) -> Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc                Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Pat l -> Rhs l -> Maybe (Binds l) -> Decl l)
-> (Pat l, Scope) -> f (Rhs l -> Maybe (Binds l) -> Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc                Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat
          f (Rhs l -> Maybe (Binds l) -> Decl l)
-> (Rhs l, Scope) -> f (Maybe (Binds l) -> Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
scWithWhere Scope -> Rhs l -> (Rhs l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Rhs l
rhs
          f (Maybe (Binds l) -> Decl l)
-> (Maybe (Binds l), Scope) -> f (Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc                Scope -> Maybe (Binds l) -> (Maybe (Binds l), Scope)
forall a. Scope -> a -> (a, Scope)
-: Maybe (Binds l)
mbWhere
      -- FunBind consists of Matches, which we handle below anyway.
      TypeSig l
l [Name l]
names Type l
ty ->
        (l -> [Name l] -> Type l -> Decl l)
-> f (l -> [Name l] -> Type l -> Decl l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> [Name l] -> Type l -> Decl l
forall l. l -> [Name l] -> Type l -> Decl l
TypeSig
          f (l -> [Name l] -> Type l -> Decl l)
-> (l, Scope) -> f ([Name l] -> Type l -> Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f ([Name l] -> Type l -> Decl l)
-> ([Name l], Scope) -> f (Type l -> Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> [Name l] -> ([Name l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [Name l]
names
          f (Type l -> Decl l) -> (Type l, Scope) -> f (Decl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> Type l -> (Type l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Type l
ty
      Decl l
_ -> Decl l -> Scope -> f (Decl l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse Decl l
e Scope
sc

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Type l) where
  rtraverse :: Type l -> Scope -> f (Type l)
rtraverse Type l
e Scope
sc = Type l -> Scope -> f (Type l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse Type l
e (Scope -> Scope
exprT Scope
sc)

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (DeclHead l) where
  rtraverse :: DeclHead l -> Scope -> f (DeclHead l)
rtraverse DeclHead l
e Scope
sc =
    case DeclHead l
e of
      DHead l
l Name l
name ->
        (l -> Name l -> DeclHead l) -> f (l -> Name l -> DeclHead l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> DeclHead l
forall l. l -> Name l -> DeclHead l
DHead
          f (l -> Name l -> DeclHead l)
-> (l, Scope) -> f (Name l -> DeclHead l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> DeclHead l) -> (Name l, Scope) -> f (DeclHead l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderT Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
      DHInfix l
l TyVarBind l
v1 Name l
name ->
        (l -> TyVarBind l -> Name l -> DeclHead l)
-> f (l -> TyVarBind l -> Name l -> DeclHead l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> TyVarBind l -> Name l -> DeclHead l
forall l. l -> TyVarBind l -> Name l -> DeclHead l
DHInfix
          f (l -> TyVarBind l -> Name l -> DeclHead l)
-> (l, Scope) -> f (TyVarBind l -> Name l -> DeclHead l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (TyVarBind l -> Name l -> DeclHead l)
-> (TyVarBind l, Scope) -> f (Name l -> DeclHead l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> TyVarBind l -> (TyVarBind l, Scope)
forall a. Scope -> a -> (a, Scope)
-: TyVarBind l
v1
          f (Name l -> DeclHead l) -> (Name l, Scope) -> f (DeclHead l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderT Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
      DeclHead l
_ -> DeclHead l -> Scope -> f (DeclHead l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse DeclHead l
e Scope
sc

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (ConDecl l) where
  rtraverse :: ConDecl l -> Scope -> f (ConDecl l)
rtraverse ConDecl l
e Scope
sc =
    case ConDecl l
e of
      ConDecl l
l Name l
name [Type l]
tys ->
        (l -> Name l -> [Type l] -> ConDecl l)
-> f (l -> Name l -> [Type l] -> ConDecl l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> [Type l] -> ConDecl l
forall l. l -> Name l -> [Type l] -> ConDecl l
ConDecl
          f (l -> Name l -> [Type l] -> ConDecl l)
-> (l, Scope) -> f (Name l -> [Type l] -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> [Type l] -> ConDecl l)
-> (Name l, Scope) -> f ([Type l] -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
          f ([Type l] -> ConDecl l) -> ([Type l], Scope) -> f (ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> [Type l] -> ([Type l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [Type l]
tys
      InfixConDecl l
l Type l
t1 Name l
name Type l
t2 ->
        (l -> Type l -> Name l -> Type l -> ConDecl l)
-> f (l -> Type l -> Name l -> Type l -> ConDecl l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Type l -> Name l -> Type l -> ConDecl l
forall l. l -> Type l -> Name l -> Type l -> ConDecl l
InfixConDecl
          f (l -> Type l -> Name l -> Type l -> ConDecl l)
-> (l, Scope) -> f (Type l -> Name l -> Type l -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Type l -> Name l -> Type l -> ConDecl l)
-> (Type l, Scope) -> f (Name l -> Type l -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> Type l -> (Type l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Type l
t1
          f (Name l -> Type l -> ConDecl l)
-> (Name l, Scope) -> f (Type l -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
          f (Type l -> ConDecl l) -> (Type l, Scope) -> f (ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> Type l -> (Type l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Type l
t2
      RecDecl l
l Name l
name [FieldDecl l]
fields ->
        (l -> Name l -> [FieldDecl l] -> ConDecl l)
-> f (l -> Name l -> [FieldDecl l] -> ConDecl l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> [FieldDecl l] -> ConDecl l
forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
RecDecl
          f (l -> Name l -> [FieldDecl l] -> ConDecl l)
-> (l, Scope) -> f (Name l -> [FieldDecl l] -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> [FieldDecl l] -> ConDecl l)
-> (Name l, Scope) -> f ([FieldDecl l] -> ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
          f ([FieldDecl l] -> ConDecl l)
-> ([FieldDecl l], Scope) -> f (ConDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> [FieldDecl l] -> ([FieldDecl l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [FieldDecl l]
fields


instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (FieldDecl l) where
  rtraverse :: FieldDecl l -> Scope -> f (FieldDecl l)
rtraverse FieldDecl l
e Scope
sc =
    case FieldDecl l
e of
      FieldDecl l
l [Name l]
name Type l
tys ->
        (l -> [Name l] -> Type l -> FieldDecl l)
-> f (l -> [Name l] -> Type l -> FieldDecl l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> [Name l] -> Type l -> FieldDecl l
forall l. l -> [Name l] -> Type l -> FieldDecl l
FieldDecl
          f (l -> [Name l] -> Type l -> FieldDecl l)
-> (l, Scope) -> f ([Name l] -> Type l -> FieldDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f ([Name l] -> Type l -> FieldDecl l)
-> ([Name l], Scope) -> f (Type l -> FieldDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> [Name l] -> ([Name l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [Name l]
name
          f (Type l -> FieldDecl l) -> (Type l, Scope) -> f (FieldDecl l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> Type l -> (Type l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Type l
tys

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Pat l) where
  rtraverse :: Pat l -> Scope -> f (Pat l)
rtraverse Pat l
e Scope
sc =
    case Pat l
e of
      PVar l
l Name l
name ->
        (l -> Name l -> Pat l) -> f (l -> Name l -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar
          f (l -> Name l -> Pat l) -> (l, Scope) -> f (Name l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc         Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> Pat l) -> (Name l, Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
      PNPlusK l
l Name l
name Integer
i ->
        (l -> Name l -> Integer -> Pat l)
-> f (l -> Name l -> Integer -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> Integer -> Pat l
forall l. l -> Name l -> Integer -> Pat l
PNPlusK
          f (l -> Name l -> Integer -> Pat l)
-> (l, Scope) -> f (Name l -> Integer -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc         Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> Integer -> Pat l)
-> (Name l, Scope) -> f (Integer -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
          f (Integer -> Pat l) -> (Integer, Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc         Scope -> Integer -> (Integer, Scope)
forall a. Scope -> a -> (a, Scope)
-: Integer
i
      PInfixApp l
l Pat l
pat1 QName l
name Pat l
pat2 ->
        (l -> Pat l -> QName l -> Pat l -> Pat l)
-> f (l -> Pat l -> QName l -> Pat l -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Pat l -> QName l -> Pat l -> Pat l
forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp
          f (l -> Pat l -> QName l -> Pat l -> Pat l)
-> (l, Scope) -> f (Pat l -> QName l -> Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Pat l -> QName l -> Pat l -> Pat l)
-> (Pat l, Scope) -> f (QName l -> Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat1
          f (QName l -> Pat l -> Pat l)
-> (QName l, Scope) -> f (Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> QName l -> (QName l, Scope)
forall a. Scope -> a -> (a, Scope)
-: QName l
name
          f (Pat l -> Pat l) -> (Pat l, Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat2
      PApp l
l QName l
qn [Pat l]
pat ->
        (l -> QName l -> [Pat l] -> Pat l)
-> f (l -> QName l -> [Pat l] -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> QName l -> [Pat l] -> Pat l
forall l. l -> QName l -> [Pat l] -> Pat l
PApp
          f (l -> QName l -> [Pat l] -> Pat l)
-> (l, Scope) -> f (QName l -> [Pat l] -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (QName l -> [Pat l] -> Pat l)
-> (QName l, Scope) -> f ([Pat l] -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> QName l -> (QName l, Scope)
forall a. Scope -> a -> (a, Scope)
-: QName l
qn
          f ([Pat l] -> Pat l) -> ([Pat l], Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> [Pat l] -> ([Pat l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [Pat l]
pat
      PRec l
l QName l
qn [PatField l]
pfs ->
        let
          scWc :: Scope
scWc =
            WcNames -> Scope -> Scope
setWcNames (Table -> QName l -> [PatField l] -> WcNames
forall l. Table -> QName l -> [PatField l] -> WcNames
patWcNames (Scope
sc Scope -> Lens Scope Table -> Table
forall b c. b -> Lens b c -> c
^. Lens Scope Table
gTable) QName l
qn [PatField l]
pfs) Scope
sc
        in
        (l -> QName l -> [PatField l] -> Pat l)
-> f (l -> QName l -> [PatField l] -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> QName l -> [PatField l] -> Pat l
forall l. l -> QName l -> [PatField l] -> Pat l
PRec
          f (l -> QName l -> [PatField l] -> Pat l)
-> (l, Scope) -> f (QName l -> [PatField l] -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (QName l -> [PatField l] -> Pat l)
-> (QName l, Scope) -> f ([PatField l] -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> QName l -> (QName l, Scope)
forall a. Scope -> a -> (a, Scope)
-: QName l
qn
          f ([PatField l] -> Pat l) -> ([PatField l], Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWc     Scope -> [PatField l] -> ([PatField l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [PatField l]
pfs
      PAsPat l
l Name l
n Pat l
pat ->
        (l -> Name l -> Pat l -> Pat l)
-> f (l -> Name l -> Pat l -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> Pat l -> Pat l
forall l. l -> Name l -> Pat l -> Pat l
PAsPat
          f (l -> Name l -> Pat l -> Pat l)
-> (l, Scope) -> f (Name l -> Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc         Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> Pat l -> Pat l)
-> (Name l, Scope) -> f (Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
n
          f (Pat l -> Pat l) -> (Pat l, Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc         Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat
      PViewPat l
l Exp l
exp Pat l
pat ->
        (l -> Exp l -> Pat l -> Pat l) -> f (l -> Exp l -> Pat l -> Pat l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Exp l -> Pat l -> Pat l
forall l. l -> Exp l -> Pat l -> Pat l
PViewPat
          f (l -> Exp l -> Pat l -> Pat l)
-> (l, Scope) -> f (Exp l -> Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Exp l -> Pat l -> Pat l) -> (Exp l, Scope) -> f (Pat l -> Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
exp
          f (Pat l -> Pat l) -> (Pat l, Scope) -> f (Pat l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat
      Pat l
_ -> Pat l -> Scope -> f (Pat l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse Pat l
e Scope
sc

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (PatField l) where
  rtraverse :: PatField l -> Scope -> f (PatField l)
rtraverse PatField l
e Scope
sc =
    case PatField l
e of
      PFieldPat l
l QName l
qn Pat l
pat ->
        (l -> QName l -> Pat l -> PatField l)
-> f (l -> QName l -> Pat l -> PatField l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> QName l -> Pat l -> PatField l
forall l. l -> QName l -> Pat l -> PatField l
PFieldPat
          f (l -> QName l -> Pat l -> PatField l)
-> (l, Scope) -> f (QName l -> Pat l -> PatField l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (QName l -> Pat l -> PatField l)
-> (QName l, Scope) -> f (Pat l -> PatField l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> QName l -> (QName l, Scope)
forall a. Scope -> a -> (a, Scope)
-: QName l
qn
          f (Pat l -> PatField l) -> (Pat l, Scope) -> f (PatField l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc       Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat
      PFieldPun l
l QName l
qn ->
        (l -> QName l -> PatField l) -> f (l -> QName l -> PatField l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> QName l -> PatField l
forall l. l -> QName l -> PatField l
PFieldPun
          f (l -> QName l -> PatField l)
-> (l, Scope) -> f (QName l -> PatField l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (QName l -> PatField l) -> (QName l, Scope) -> f (PatField l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
sc Scope -> QName l -> (QName l, Scope)
forall a. Scope -> a -> (a, Scope)
-: QName l
qn
      -- In future we might want to annotate PFieldWildcard with the names
      -- it introduces.
      PFieldWildcard {} -> PatField l -> Scope -> f (PatField l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse PatField l
e Scope
sc

-- | Chain a sequence of nodes where every node may introduce some
-- variables into scope for the subsequent nodes. Examples: patterns (see
-- note [Nested pattern scopes]), statements.
chain
  :: ( Resolvable (a l)
     , GetBound (a l) l
     , Applicative w
     , SrcInfo l
     , Data l
     , ?alg :: Alg w)
  => [a l] -> Scope -> (w [a l], Scope)
chain :: [a l] -> Scope -> (w [a l], Scope)
chain [a l]
pats Scope
sc =
  case [a l]
pats of
    [] -> ([a l] -> w [a l]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [], Scope
sc)
    a l
p:[a l]
ps ->
      let
        sc' :: Scope
sc' = a l -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro a l
p Scope
sc
        p' :: w (a l)
p' = a l -> Scope -> w (a l)
forall (w :: * -> *) d.
(?alg::Alg w, Resolvable d) =>
d -> Scope -> w d
alg a l
p Scope
sc
        (w [a l]
ps', Scope
sc'') = [a l] -> Scope -> (w [a l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [a l]
ps Scope
sc'
      in ((:) (a l -> [a l] -> [a l]) -> w (a l) -> w ([a l] -> [a l])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (a l)
p' w ([a l] -> [a l]) -> w [a l] -> w [a l]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> w [a l]
ps', Scope
sc'')

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Match l) where
  rtraverse :: Match l -> Scope -> f (Match l)
rtraverse Match l
e Scope
sc =
    case Match l
e of
      Match l
l Name l
name [Pat l]
pats Rhs l
rhs Maybe (Binds l)
mbWhere ->
        -- f x y z = ...
        --   where ...
        let
          (f [Pat l]
pats', Scope
scWithPats) = [Pat l] -> Scope -> (f [Pat l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [Pat l]
pats Scope
sc
          scWithWhere :: Scope
scWithWhere = Maybe (Binds l) -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro Maybe (Binds l)
mbWhere Scope
scWithPats
        in
        (l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
-> f (l
      -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match
          f (l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
-> (l, Scope)
-> f (Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc                Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
-> (Name l, Scope)
-> f ([Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
binderV Scope
sc        Scope -> Name l -> (Name l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Name l
name
          f ([Pat l] -> Rhs l -> Maybe (Binds l) -> Match l)
-> f [Pat l] -> f (Rhs l -> Maybe (Binds l) -> Match l)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [Pat l]
pats' -- has been already traversed
          f (Rhs l -> Maybe (Binds l) -> Match l)
-> (Rhs l, Scope) -> f (Maybe (Binds l) -> Match l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope -> Scope
exprV Scope
scWithWhere Scope -> Rhs l -> (Rhs l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Rhs l
rhs
          f (Maybe (Binds l) -> Match l)
-> (Maybe (Binds l), Scope) -> f (Match l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithPats        Scope -> Maybe (Binds l) -> (Maybe (Binds l), Scope)
forall a. Scope -> a -> (a, Scope)
-: Maybe (Binds l)
mbWhere
      InfixMatch l
l Pat l
pat1 Name l
name [Pat l]
patsRest Rhs l
rhs Maybe (Binds l)
mbWhere ->
        let
          equivalentMatch :: Match l
equivalentMatch = l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match l
l Name l
name (Pat l
pat1Pat l -> [Pat l] -> [Pat l]
forall a. a -> [a] -> [a]
:[Pat l]
patsRest) Rhs l
rhs Maybe (Binds l)
mbWhere
          back :: Match l -> Match l
back (Match l
l Name l
name (Pat l
pat1:[Pat l]
patsRest) Rhs l
rhs Maybe (Binds l)
mbWhere) =
            l
-> Pat l
-> Name l
-> [Pat l]
-> Rhs l
-> Maybe (Binds l)
-> Match l
forall l.
l
-> Pat l
-> Name l
-> [Pat l]
-> Rhs l
-> Maybe (Binds l)
-> Match l
InfixMatch l
l Pat l
pat1 Name l
name [Pat l]
patsRest Rhs l
rhs Maybe (Binds l)
mbWhere
          back Match l
_ = [Char] -> Match l
forall a. HasCallStack => [Char] -> a
error [Char]
"InfixMatch"
        in Match l -> Match l
forall l. Match l -> Match l
back (Match l -> Match l) -> f (Match l) -> f (Match l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Match l -> Scope -> f (Match l)
forall a (f :: * -> *).
(Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
rtraverse Match l
equivalentMatch Scope
sc

-- NB: there is an inefficiency here (and in similar places), because we
-- call intro on the same subtree several times. Maybe tackle it later.
instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Binds l) where
  rtraverse :: Binds l -> Scope -> f (Binds l)
rtraverse Binds l
e Scope
sc =
    case Binds l
e of
      BDecls l
l [Decl l]
decls ->
        let scWithBinds :: Scope
scWithBinds = [Decl l] -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro [Decl l]
decls Scope
sc
        in
        (l -> [Decl l] -> Binds l) -> f (l -> [Decl l] -> Binds l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> [Decl l] -> Binds l
forall l. l -> [Decl l] -> Binds l
BDecls
          f (l -> [Decl l] -> Binds l)
-> (l, Scope) -> f ([Decl l] -> Binds l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc          Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f ([Decl l] -> Binds l) -> ([Decl l], Scope) -> f (Binds l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithBinds Scope -> [Decl l] -> ([Decl l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [Decl l]
decls
      Binds l
_ -> Binds l -> Scope -> f (Binds l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse Binds l
e Scope
sc

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Exp l) where
  rtraverse :: Exp l -> Scope -> f (Exp l)
rtraverse Exp l
e Scope
sc =
    case Exp l
e of
      Let l
l Binds l
bnds Exp l
body ->
        let scWithBinds :: Scope
scWithBinds = Binds l -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro Binds l
bnds Scope
sc
        in
        (l -> Binds l -> Exp l -> Exp l)
-> f (l -> Binds l -> Exp l -> Exp l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Binds l -> Exp l -> Exp l
forall l. l -> Binds l -> Exp l -> Exp l
Let
          f (l -> Binds l -> Exp l -> Exp l)
-> (l, Scope) -> f (Binds l -> Exp l -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc          Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Binds l -> Exp l -> Exp l)
-> (Binds l, Scope) -> f (Exp l -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithBinds Scope -> Binds l -> (Binds l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Binds l
bnds
          f (Exp l -> Exp l) -> (Exp l, Scope) -> f (Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithBinds Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
body

      Lambda l
l [Pat l]
pats Exp l
body ->
        let (f [Pat l]
pats', Scope
scWithPats) = [Pat l] -> Scope -> (f [Pat l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [Pat l]
pats Scope
sc
        in
        (l -> [Pat l] -> Exp l -> Exp l)
-> f (l -> [Pat l] -> Exp l -> Exp l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda
          f (l -> [Pat l] -> Exp l -> Exp l)
-> (l, Scope) -> f ([Pat l] -> Exp l -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
sc         Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f ([Pat l] -> Exp l -> Exp l) -> f [Pat l] -> f (Exp l -> Exp l)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [Pat l]
pats'
          f (Exp l -> Exp l) -> (Exp l, Scope) -> f (Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
scWithPats Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
body

      ListComp l
l Exp l
e [QualStmt l]
stmts ->
        let (f [QualStmt l]
stmts', Scope
scWithStmts) = [QualStmt l] -> Scope -> (f [QualStmt l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [QualStmt l]
stmts Scope
sc
        in
        (l -> Exp l -> [QualStmt l] -> Exp l)
-> f (l -> Exp l -> [QualStmt l] -> Exp l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Exp l -> [QualStmt l] -> Exp l
forall l. l -> Exp l -> [QualStmt l] -> Exp l
ListComp
          f (l -> Exp l -> [QualStmt l] -> Exp l)
-> (l, Scope) -> f (Exp l -> [QualStmt l] -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Exp l -> [QualStmt l] -> Exp l)
-> (Exp l, Scope) -> f ([QualStmt l] -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
scWithStmts Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
e
          f ([QualStmt l] -> Exp l) -> f [QualStmt l] -> f (Exp l)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [QualStmt l]
stmts'

      ParComp l
l Exp l
e [[QualStmt l]]
stmtss ->
        let
          ([f [QualStmt l]]
stmtss', [Scope]
scsWithStmts) =
            [(f [QualStmt l], Scope)] -> ([f [QualStmt l]], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(f [QualStmt l], Scope)] -> ([f [QualStmt l]], [Scope]))
-> [(f [QualStmt l], Scope)] -> ([f [QualStmt l]], [Scope])
forall a b. (a -> b) -> a -> b
$ ([QualStmt l] -> (f [QualStmt l], Scope))
-> [[QualStmt l]] -> [(f [QualStmt l], Scope)]
forall a b. (a -> b) -> [a] -> [b]
map (\[QualStmt l]
stmts -> [QualStmt l] -> Scope -> (f [QualStmt l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [QualStmt l]
stmts Scope
sc) [[QualStmt l]]
stmtss
          scWithAllStmtss :: Scope
scWithAllStmtss = (Scope -> Scope -> Scope) -> [Scope] -> Scope
forall a. (a -> a -> a) -> [a] -> a
foldl1' Scope -> Scope -> Scope
mergeLocalScopes [Scope]
scsWithStmts
        in
        (l -> Exp l -> [[QualStmt l]] -> Exp l)
-> f (l -> Exp l -> [[QualStmt l]] -> Exp l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Exp l -> [[QualStmt l]] -> Exp l
forall l. l -> Exp l -> [[QualStmt l]] -> Exp l
ParComp
          f (l -> Exp l -> [[QualStmt l]] -> Exp l)
-> (l, Scope) -> f (Exp l -> [[QualStmt l]] -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Exp l -> [[QualStmt l]] -> Exp l)
-> (Exp l, Scope) -> f ([[QualStmt l]] -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
scWithAllStmtss Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
e
          f ([[QualStmt l]] -> Exp l) -> f [[QualStmt l]] -> f (Exp l)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [f [QualStmt l]] -> f [[QualStmt l]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA [f [QualStmt l]]
stmtss'

      Proc l
l Pat l
pat Exp l
e ->
        let scWithPat :: Scope
scWithPat = Pat l -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro Pat l
pat Scope
sc
        in
        (l -> Pat l -> Exp l -> Exp l) -> f (l -> Pat l -> Exp l -> Exp l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Pat l -> Exp l -> Exp l
forall l. l -> Pat l -> Exp l -> Exp l
Proc
          f (l -> Pat l -> Exp l -> Exp l)
-> (l, Scope) -> f (Pat l -> Exp l -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Pat l -> Exp l -> Exp l) -> (Pat l, Scope) -> f (Exp l -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat
          f (Exp l -> Exp l) -> (Exp l, Scope) -> f (Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithPat Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
e

      RecConstr l
l QName l
qn [FieldUpdate l]
fields ->
        let
          scWc :: Scope
scWc =
            WcNames -> Scope -> Scope
setWcNames
              (Table -> Table -> QName l -> [FieldUpdate l] -> WcNames
forall l. Table -> Table -> QName l -> [FieldUpdate l] -> WcNames
expWcNames
                (Scope
sc Scope -> Lens Scope Table -> Table
forall b c. b -> Lens b c -> c
^. Lens Scope Table
gTable)
                (Scope
sc Scope -> Lens Scope Table -> Table
forall b c. b -> Lens b c -> c
^. Lens Scope Table
lTable)
                QName l
qn
                [FieldUpdate l]
fields)
              Scope
sc
        in
        (l -> QName l -> [FieldUpdate l] -> Exp l)
-> f (l -> QName l -> [FieldUpdate l] -> Exp l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> QName l -> [FieldUpdate l] -> Exp l
forall l. l -> QName l -> [FieldUpdate l] -> Exp l
RecConstr
          f (l -> QName l -> [FieldUpdate l] -> Exp l)
-> (l, Scope) -> f (QName l -> [FieldUpdate l] -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc   Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (QName l -> [FieldUpdate l] -> Exp l)
-> (QName l, Scope) -> f ([FieldUpdate l] -> Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc   Scope -> QName l -> (QName l, Scope)
forall a. Scope -> a -> (a, Scope)
-: QName l
qn
          f ([FieldUpdate l] -> Exp l)
-> ([FieldUpdate l], Scope) -> f (Exp l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWc Scope -> [FieldUpdate l] -> ([FieldUpdate l], Scope)
forall a. Scope -> a -> (a, Scope)
-: [FieldUpdate l]
fields

      Exp l
_ -> Exp l -> Scope -> f (Exp l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse Exp l
e Scope
sc

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Alt l) where
  rtraverse :: Alt l -> Scope -> f (Alt l)
rtraverse Alt l
e Scope
sc =
    case Alt l
e of
      Alt l
l Pat l
pat Rhs l
guardedAlts Maybe (Binds l)
mbWhere ->
        let
          scWithPat :: Scope
scWithPat = Pat l -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro Pat l
pat Scope
sc
          scWithBinds :: Scope
scWithBinds = Maybe (Binds l) -> Scope -> Scope
forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro Maybe (Binds l)
mbWhere Scope
scWithPat
        in
        (l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l)
-> f (l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt
          f (l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l)
-> (l, Scope) -> f (Pat l -> Rhs l -> Maybe (Binds l) -> Alt l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f (Pat l -> Rhs l -> Maybe (Binds l) -> Alt l)
-> (Pat l, Scope) -> f (Rhs l -> Maybe (Binds l) -> Alt l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
sc Scope -> Pat l -> (Pat l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Pat l
pat
          f (Rhs l -> Maybe (Binds l) -> Alt l)
-> (Rhs l, Scope) -> f (Maybe (Binds l) -> Alt l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithBinds Scope -> Rhs l -> (Rhs l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Rhs l
guardedAlts
          f (Maybe (Binds l) -> Alt l)
-> (Maybe (Binds l), Scope) -> f (Alt l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<| Scope
scWithBinds Scope -> Maybe (Binds l) -> (Maybe (Binds l), Scope)
forall a. Scope -> a -> (a, Scope)
-: Maybe (Binds l)
mbWhere

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (GuardedRhs l) where
  rtraverse :: GuardedRhs l -> Scope -> f (GuardedRhs l)
rtraverse GuardedRhs l
e Scope
sc =
    case GuardedRhs l
e of
      GuardedRhs l
l [Stmt l]
stmts Exp l
exp ->
        let (f [Stmt l]
stmts', Scope
scWithStmts) = [Stmt l] -> Scope -> (f [Stmt l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [Stmt l]
stmts Scope
sc
        in
        (l -> [Stmt l] -> Exp l -> GuardedRhs l)
-> f (l -> [Stmt l] -> Exp l -> GuardedRhs l)
forall (w :: * -> *) c. Applicative w => c -> w c
c l -> [Stmt l] -> Exp l -> GuardedRhs l
forall l. l -> [Stmt l] -> Exp l -> GuardedRhs l
GuardedRhs
          f (l -> [Stmt l] -> Exp l -> GuardedRhs l)
-> (l, Scope) -> f ([Stmt l] -> Exp l -> GuardedRhs l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
sc Scope -> l -> (l, Scope)
forall a. Scope -> a -> (a, Scope)
-: l
l
          f ([Stmt l] -> Exp l -> GuardedRhs l)
-> f [Stmt l] -> f (Exp l -> GuardedRhs l)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [Stmt l]
stmts'
          f (Exp l -> GuardedRhs l) -> (Exp l, Scope) -> f (GuardedRhs l)
forall (w :: * -> *) b c.
(Applicative w, Resolvable b, ?alg::Alg w) =>
w (b -> c) -> (b, Scope) -> w c
<|  Scope
scWithStmts Scope -> Exp l -> (Exp l, Scope)
forall a. Scope -> a -> (a, Scope)
-: Exp l
exp

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable [Stmt l] where
  rtraverse :: [Stmt l] -> Scope -> f [Stmt l]
rtraverse [Stmt l]
e Scope
sc =
    (f [Stmt l], Scope) -> f [Stmt l]
forall a b. (a, b) -> a
fst ((f [Stmt l], Scope) -> f [Stmt l])
-> (f [Stmt l], Scope) -> f [Stmt l]
forall a b. (a -> b) -> a -> b
$ [Stmt l] -> Scope -> (f [Stmt l], Scope)
forall (a :: * -> *) l (w :: * -> *).
(Resolvable (a l), GetBound (a l) l, Applicative w, SrcInfo l,
 Data l, ?alg::Alg w) =>
[a l] -> Scope -> (w [a l], Scope)
chain [Stmt l]
e Scope
sc

instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (QualStmt l) where
  rtraverse :: QualStmt l -> Scope -> f (QualStmt l)
rtraverse QualStmt l
e Scope
sc =
    case QualStmt l
e of
      QualStmt {} -> QualStmt l -> Scope -> f (QualStmt l)
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse QualStmt l
e Scope
sc
      QualStmt l
_ -> [Char] -> f (QualStmt l)
forall a. HasCallStack => [Char] -> a
error [Char]
"haskell-names: TransformListComp is not supported yet"

{-
Note [Nested pattern scopes]
~~~~~~~~~~~~~~~~~~~~~~

When we resolve a group of patterns, their scopes nest.

Most of the time, this is not important, but there are two exceptions:
1. ScopedTypeVariables

Example: f (x :: a) (y :: a) = ...

The first 'a' is a binder, the second — a reference.

2. View patterns

An expression inside a view pattern may reference the variables bound
earlier.

Example: f x (find (< x) -> Just y) = ...
-}

-- Some road-block Resolvable instances
instance {-# OVERLAPPING #-} Typeable a => Resolvable (Scoped a) where
  rtraverse :: Scoped a -> Scope -> f (Scoped a)
rtraverse = (Scope -> Scoped a -> f (Scoped a))
-> Scoped a -> Scope -> f (Scoped a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Scope -> Scoped a -> f (Scoped a))
 -> Scoped a -> Scope -> f (Scoped a))
-> (Scope -> Scoped a -> f (Scoped a))
-> Scoped a
-> Scope
-> f (Scoped a)
forall a b. (a -> b) -> a -> b
$ (Scoped a -> f (Scoped a)) -> Scope -> Scoped a -> f (Scoped a)
forall a b. a -> b -> a
const Scoped a -> f (Scoped a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance {-# OVERLAPPING #-} Resolvable SrcSpan where
  rtraverse :: SrcSpan -> Scope -> f SrcSpan
rtraverse = (Scope -> SrcSpan -> f SrcSpan) -> SrcSpan -> Scope -> f SrcSpan
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Scope -> SrcSpan -> f SrcSpan) -> SrcSpan -> Scope -> f SrcSpan)
-> (Scope -> SrcSpan -> f SrcSpan) -> SrcSpan -> Scope -> f SrcSpan
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> f SrcSpan) -> Scope -> SrcSpan -> f SrcSpan
forall a b. a -> b -> a
const SrcSpan -> f SrcSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance {-# OVERLAPPING #-} Resolvable SrcSpanInfo where
  rtraverse :: SrcSpanInfo -> Scope -> f SrcSpanInfo
rtraverse = (Scope -> SrcSpanInfo -> f SrcSpanInfo)
-> SrcSpanInfo -> Scope -> f SrcSpanInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Scope -> SrcSpanInfo -> f SrcSpanInfo)
 -> SrcSpanInfo -> Scope -> f SrcSpanInfo)
-> (Scope -> SrcSpanInfo -> f SrcSpanInfo)
-> SrcSpanInfo
-> Scope
-> f SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ (SrcSpanInfo -> f SrcSpanInfo)
-> Scope -> SrcSpanInfo -> f SrcSpanInfo
forall a b. a -> b -> a
const SrcSpanInfo -> f SrcSpanInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure