purescript-0.15.15: src/Language/PureScript/AST/Traversals.hs

-- |
-- AST traversal helpers
--
module Language.PureScript.AST.Traversals where

import Prelude
import Protolude (swap)

import Control.Monad ((<=<), (>=>))
import Control.Monad.Trans.State (StateT(..))

import Data.Foldable (fold)
import Data.Functor.Identity (runIdentity)
import Data.List (mapAccumL)
import Data.Maybe (mapMaybe)
import Data.List.NonEmpty qualified as NEL
import Data.Map qualified as M
import Data.Set qualified as S

import Language.PureScript.AST.Binders (Binder(..), binderNames)
import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), mapTypeInstanceBody, traverseTypeInstanceBody)
import Language.PureScript.AST.Literals (Literal(..))
import Language.PureScript.Names (pattern ByNullSourcePos, Ident)
import Language.PureScript.Traversals (sndM, sndM', thirdM)
import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
import Language.PureScript.Types (Constraint(..), SourceType, mapConstraintArgs)

guardedExprM :: Applicative m
             => (Guard -> m Guard)
             -> (Expr -> m Expr)
             -> GuardedExpr
             -> m GuardedExpr
guardedExprM f g (GuardedExpr guards rhs) =
  GuardedExpr <$> traverse f guards <*> g rhs

mapGuardedExpr :: (Guard -> Guard)
               -> (Expr -> Expr)
               -> GuardedExpr
               -> GuardedExpr
mapGuardedExpr f g (GuardedExpr guards rhs) =
  GuardedExpr (fmap f guards) (g rhs)

litM :: Monad m => (a -> m a) -> Literal a -> m (Literal a)
litM go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
litM go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
litM _ other = pure other

everywhereOnValues
  :: (Declaration -> Declaration)
  -> (Expr -> Expr)
  -> (Binder -> Binder)
  -> ( Declaration -> Declaration
     , Expr -> Expr
     , Binder -> Binder
     )
everywhereOnValues f g h = (f', g', h')
  where
  f' :: Declaration -> Declaration
  f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds))
  f' (ValueDecl sa name nameKind bs val) =
     f (ValueDecl sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val))
  f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr))
  f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
  f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds))
  f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = f (TypeInstanceDeclaration sa na ch idx name cs className args (mapTypeInstanceBody (fmap f') ds))
  f' other = f other

  g' :: Expr -> Expr
  g' (Literal ss l) = g (Literal ss (lit g' l))
  g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v))
  g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
  g' (Parens v) = g (Parens (g' v))
  g' (Accessor prop v) = g (Accessor prop (g' v))
  g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (fmap (fmap g') vs))
  g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))
  g' (Abs binder v) = g (Abs (h' binder) (g' v))
  g' (App v1 v2) = g (App (g' v1) (g' v2))
  g' (VisibleTypeApp v ty) = g (VisibleTypeApp (g' v) ty)
  g' (Unused v) = g (Unused (g' v))
  g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
  g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts))
  g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
  g' (Let w ds v) = g (Let w (fmap f' ds) (g' v))
  g' (Do m es) = g (Do m (fmap handleDoNotationElement es))
  g' (Ado m es v) = g (Ado m (fmap handleDoNotationElement es) (g' v))
  g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))
  g' other = g other

  h' :: Binder -> Binder
  h' (ConstructorBinder ss ctor bs) = h (ConstructorBinder ss ctor (fmap h' bs))
  h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
  h' (ParensInBinder b) = h (ParensInBinder (h' b))
  h' (LiteralBinder ss l) = h (LiteralBinder ss (lit h' l))
  h' (NamedBinder ss name b) = h (NamedBinder ss name (h' b))
  h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
  h' (TypedBinder t b) = h (TypedBinder t (h' b))
  h' other = h other

  lit :: (a -> a) -> Literal a -> Literal a
  lit go (ArrayLiteral as) = ArrayLiteral (fmap go as)
  lit go (ObjectLiteral as) = ObjectLiteral (fmap (fmap go) as)
  lit _ other = other

  handleCaseAlternative :: CaseAlternative -> CaseAlternative
  handleCaseAlternative ca =
    ca { caseAlternativeBinders = fmap h' (caseAlternativeBinders ca)
       , caseAlternativeResult = fmap (mapGuardedExpr handleGuard g') (caseAlternativeResult ca)
       }

  handleDoNotationElement :: DoNotationElement -> DoNotationElement
  handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
  handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
  handleDoNotationElement (DoNotationLet ds) = DoNotationLet (fmap f' ds)
  handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

  handleGuard :: Guard -> Guard
  handleGuard (ConditionGuard e) = ConditionGuard (g' e)
  handleGuard (PatternGuard b e) = PatternGuard (h' b) (g' e)

everywhereOnValuesTopDownM
  :: forall m
   . (Monad m)
  => (Declaration -> m Declaration)
  -> (Expr -> m Expr)
  -> (Binder -> m Binder)
  -> ( Declaration -> m Declaration
     , Expr -> m Expr
     , Binder -> m Binder
     )
everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
  where

  f' :: Declaration -> m Declaration
  f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
  f' (ValueDecl sa name nameKind bs val) =
     ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val
  f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> (g val >>= g')) ds
  f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds
  f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
  f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> (h' <=< h) b <*> (g' <=< g) expr
  f' other = f other

  g' :: Expr -> m Expr
  g' (Literal ss l) = Literal ss <$> litM (g >=> g') l
  g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g')
  g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
  g' (Parens v) = Parens <$> (g v >>= g')
  g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
  g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
  g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs
  g' (Abs binder v) = Abs <$> (h binder >>= h') <*> (g v >>= g')
  g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
  g' (VisibleTypeApp v ty) = VisibleTypeApp <$> (g v >>= g') <*> pure ty
  g' (Unused v) = Unused <$> (g v >>= g')
  g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
  g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts
  g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
  g' (Let w ds v) = Let w <$> traverse (f' <=< f) ds <*> (g v >>= g')
  g' (Do m es) = Do m <$> traverse handleDoNotationElement es
  g' (Ado m es v) = Ado m <$> traverse handleDoNotationElement es <*> (g v >>= g')
  g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
  g' other = g other

  h' :: Binder -> m Binder
  h' (LiteralBinder ss l) = LiteralBinder ss <$> litM (h >=> h') l
  h' (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h' <=< h) bs
  h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
  h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
  h' (NamedBinder ss name b) = NamedBinder ss name <$> (h b >>= h')
  h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
  h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
  h' other = h other

  handleCaseAlternative :: CaseAlternative -> m CaseAlternative
  handleCaseAlternative (CaseAlternative bs val) =
    CaseAlternative
      <$> traverse (h' <=< h) bs
      <*> traverse (guardedExprM handleGuard (g' <=< g)) val

  handleDoNotationElement :: DoNotationElement -> m DoNotationElement
  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds
  handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

  handleGuard :: Guard -> m Guard
  handleGuard (ConditionGuard e) = ConditionGuard <$> (g' <=< g) e
  handleGuard (PatternGuard b e) = PatternGuard <$> (h' <=< h) b <*> (g' <=< g) e

everywhereOnValuesM
  :: forall m
   . (Monad m)
  => (Declaration -> m Declaration)
  -> (Expr -> m Expr)
  -> (Binder -> m Binder)
  -> ( Declaration -> m Declaration
     , Expr -> m Expr
     , Binder -> m Binder
     )
everywhereOnValuesM f g h = (f', g', h')
  where

  f' :: Declaration -> m Declaration
  f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
  f' (ValueDecl sa name nameKind bs val) =
    ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f
  f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> g' val) ds) >>= f
  f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f
  f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f
  f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = (TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f
  f' other = f other

  g' :: Expr -> m Expr
  g' (Literal ss l) = (Literal ss <$> litM g' l) >>= g
  g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g
  g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
  g' (Parens v) = (Parens <$> g' v) >>= g
  g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
  g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
  g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g
  g' (Abs binder v) = (Abs <$> h' binder <*> g' v) >>= g
  g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
  g' (VisibleTypeApp v ty) = (VisibleTypeApp <$> g' v <*> pure ty) >>= g
  g' (Unused v) = (Unused <$> g' v) >>= g
  g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
  g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g
  g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
  g' (Let w ds v) = (Let w <$> traverse f' ds <*> g' v) >>= g
  g' (Do m es) = (Do m <$> traverse handleDoNotationElement es) >>= g
  g' (Ado m es v) = (Ado m <$> traverse handleDoNotationElement es <*> g' v) >>= g
  g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
  g' other = g other

  h' :: Binder -> m Binder
  h' (LiteralBinder ss l) = (LiteralBinder ss <$> litM h' l) >>= h
  h' (ConstructorBinder ss ctor bs) = (ConstructorBinder ss ctor <$> traverse h' bs) >>= h
  h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
  h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
  h' (NamedBinder ss name b) = (NamedBinder ss name <$> h' b) >>= h
  h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
  h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
  h' other = h other

  handleCaseAlternative :: CaseAlternative -> m CaseAlternative
  handleCaseAlternative (CaseAlternative bs val) =
    CaseAlternative
      <$> traverse h' bs
      <*> traverse (guardedExprM handleGuard g') val

  handleDoNotationElement :: DoNotationElement -> m DoNotationElement
  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds
  handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

  handleGuard :: Guard -> m Guard
  handleGuard (ConditionGuard e) = ConditionGuard <$> g' e
  handleGuard (PatternGuard b e) = PatternGuard <$> h' b <*> g' e

everythingOnValues
  :: forall r
   . (r -> r -> r)
  -> (Declaration -> r)
  -> (Expr -> r)
  -> (Binder -> r)
  -> (CaseAlternative -> r)
  -> (DoNotationElement -> r)
  -> ( Declaration -> r
     , Expr -> r
     , Binder -> r
     , CaseAlternative -> r
     , DoNotationElement -> r
     )
everythingOnValues (<>.) f g h i j = (f', g', h', i', j')
  where

  f' :: Declaration -> r
  f' d@(DataBindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap f' ds)
  f' d@(ValueDeclaration vd) = foldl (<>.) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd))
  f' d@(BindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap (\(_, _, val) -> g' val) ds)
  f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) (f d) (fmap f' ds)
  f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) (f d) (fmap f' ds)
  f' d@(BoundValueDeclaration _ b expr) = f d <>. h' b <>. g' expr
  f' d = f d

  g' :: Expr -> r
  g' v@(Literal _ l) = lit (g v) g' l
  g' v@(UnaryMinus _ v1) = g v <>. g' v1
  g' v@(BinaryNoParens op v1 v2) = g v <>. g' op <>. g' v1 <>. g' v2
  g' v@(Parens v1) = g v <>. g' v1
  g' v@(Accessor _ v1) = g v <>. g' v1
  g' v@(ObjectUpdate obj vs) = foldl (<>.) (g v <>. g' obj) (fmap (g' . snd) vs)
  g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs)
  g' v@(Abs b v1) = g v <>. h' b <>. g' v1
  g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2
  g' v@(VisibleTypeApp v' _) = g v <>. g' v'
  g' v@(Unused v1) = g v <>. g' v1
  g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3
  g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts)
  g' v@(TypedValue _ v1 _) = g v <>. g' v1
  g' v@(Let _ ds v1) = foldl (<>.) (g v) (fmap f' ds) <>. g' v1
  g' v@(Do _ es) = foldl (<>.) (g v) (fmap j' es)
  g' v@(Ado _ es v1) = foldl (<>.) (g v) (fmap j' es) <>. g' v1
  g' v@(PositionedValue _ _ v1) = g v <>. g' v1
  g' v = g v

  h' :: Binder -> r
  h' b@(LiteralBinder _ l) = lit (h b) h' l
  h' b@(ConstructorBinder _ _ bs) = foldl (<>.) (h b) (fmap h' bs)
  h' b@(BinaryNoParensBinder b1 b2 b3) = h b <>. h' b1 <>. h' b2 <>. h' b3
  h' b@(ParensInBinder b1) = h b <>. h' b1
  h' b@(NamedBinder _ _ b1) = h b <>. h' b1
  h' b@(PositionedBinder _ _ b1) = h b <>. h' b1
  h' b@(TypedBinder _ b1) = h b <>. h' b1
  h' b = h b

  lit :: r -> (a -> r) -> Literal a -> r
  lit r go (ArrayLiteral as) = foldl (<>.) r (fmap go as)
  lit r go (ObjectLiteral as) = foldl (<>.) r (fmap (go . snd) as)
  lit r _ _ = r

  i' :: CaseAlternative -> r
  i' ca@(CaseAlternative bs gs) =
    foldl (<>.) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs)

  j' :: DoNotationElement -> r
  j' e@(DoNotationValue v) = j e <>. g' v
  j' e@(DoNotationBind b v) = j e <>. h' b <>. g' v
  j' e@(DoNotationLet ds) = foldl (<>.) (j e) (fmap f' ds)
  j' e@(PositionedDoNotationElement _ _ e1) = j e <>. j' e1

  k' :: Guard -> r
  k' (ConditionGuard e) = g' e
  k' (PatternGuard b e) = h' b <>. g' e

everythingWithContextOnValues
  :: forall s r
   . s
  -> r
  -> (r -> r -> r)
  -> (s -> Declaration       -> (s, r))
  -> (s -> Expr              -> (s, r))
  -> (s -> Binder            -> (s, r))
  -> (s -> CaseAlternative   -> (s, r))
  -> (s -> DoNotationElement -> (s, r))
  -> ( Declaration       -> r
     , Expr              -> r
     , Binder            -> r
     , CaseAlternative   -> r
     , DoNotationElement -> r)
everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
  where

  f'' :: s -> Declaration -> r
  f'' s d = let (s', r) = f s d in r <>. f' s' d

  f' :: s -> Declaration -> r
  f' s (DataBindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (f'' s) ds)
  f' s (ValueDeclaration vd) = foldl (<>.) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd))
  f' s (BindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (\(_, _, val) -> g'' s val) ds)
  f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) r0 (fmap (f'' s) ds)
  f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) r0 (fmap (f'' s) ds)
  f' _ _ = r0

  g'' :: s -> Expr -> r
  g'' s v = let (s', r) = g s v in r <>. g' s' v

  g' :: s -> Expr -> r
  g' s (Literal _ l) = lit g'' s l
  g' s (UnaryMinus _ v1) = g'' s v1
  g' s (BinaryNoParens op v1 v2) = g'' s op <>. g'' s v1 <>. g'' s v2
  g' s (Parens v1) = g'' s v1
  g' s (Accessor _ v1) = g'' s v1
  g' s (ObjectUpdate obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s . snd) vs)
  g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs)
  g' s (Abs binder v1) = h'' s binder <>. g'' s v1
  g' s (App v1 v2) = g'' s v1 <>. g'' s v2
  g' s (VisibleTypeApp v _) = g'' s v
  g' s (Unused v) = g'' s v
  g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3
  g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts)
  g' s (TypedValue _ v1 _) = g'' s v1
  g' s (Let _ ds v1) = foldl (<>.) r0 (fmap (f'' s) ds) <>. g'' s v1
  g' s (Do _ es) = foldl (<>.) r0 (fmap (j'' s) es)
  g' s (Ado _ es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. g'' s v1
  g' s (PositionedValue _ _ v1) = g'' s v1
  g' _ _ = r0

  h'' :: s -> Binder -> r
  h'' s b = let (s', r) = h s b in r <>. h' s' b

  h' :: s -> Binder -> r
  h' s (LiteralBinder _ l) = lit h'' s l
  h' s (ConstructorBinder _ _ bs) = foldl (<>.) r0 (fmap (h'' s) bs)
  h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <>. h'' s b2 <>. h'' s b3
  h' s (ParensInBinder b) = h'' s b
  h' s (NamedBinder _ _ b1) = h'' s b1
  h' s (PositionedBinder _ _ b1) = h'' s b1
  h' s (TypedBinder _ b1) = h'' s b1
  h' _ _ = r0

  lit :: (s -> a -> r) -> s -> Literal a -> r
  lit go s (ArrayLiteral as) = foldl (<>.) r0 (fmap (go s) as)
  lit go s (ObjectLiteral as) = foldl (<>.) r0 (fmap (go s . snd) as)
  lit _ _ _ = r0

  i'' :: s -> CaseAlternative -> r
  i'' s ca = let (s', r) = i s ca in r <>. i' s' ca

  i' :: s -> CaseAlternative -> r
  i' s (CaseAlternative bs gs) = foldl (<>.) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs)

  j'' :: s -> DoNotationElement -> r
  j'' s e = let (s', r) = j s e in r <>. j' s' e

  j' :: s -> DoNotationElement -> r
  j' s (DoNotationValue v) = g'' s v
  j' s (DoNotationBind b v) = h'' s b <>. g'' s v
  j' s (DoNotationLet ds) = foldl (<>.) r0 (fmap (f'' s) ds)
  j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

  k' :: s -> Guard -> r
  k' s (ConditionGuard e) = g'' s e
  k' s (PatternGuard b e) = h'' s b <>. g'' s e

everywhereWithContextOnValues
  :: forall s
   . s
  -> (s -> Declaration       -> (s, Declaration))
  -> (s -> Expr              -> (s, Expr))
  -> (s -> Binder            -> (s, Binder))
  -> (s -> CaseAlternative   -> (s, CaseAlternative))
  -> (s -> DoNotationElement -> (s, DoNotationElement))
  -> (s -> Guard             -> (s, Guard))
  -> ( Declaration       -> Declaration
     , Expr              -> Expr
     , Binder            -> Binder
     , CaseAlternative   -> CaseAlternative
     , DoNotationElement -> DoNotationElement
     , Guard             -> Guard
     )
everywhereWithContextOnValues s f g h i j k = (runIdentity . f', runIdentity . g', runIdentity . h', runIdentity . i', runIdentity . j', runIdentity . k')
  where
  (f', g', h', i', j', k') = everywhereWithContextOnValuesM s (wrap f) (wrap g) (wrap h) (wrap i) (wrap j) (wrap k)
  wrap = ((pure .) .)

everywhereWithContextOnValuesM
  :: forall m s
   . (Monad m)
  => s
  -> (s -> Declaration       -> m (s, Declaration))
  -> (s -> Expr              -> m (s, Expr))
  -> (s -> Binder            -> m (s, Binder))
  -> (s -> CaseAlternative   -> m (s, CaseAlternative))
  -> (s -> DoNotationElement -> m (s, DoNotationElement))
  -> (s -> Guard             -> m (s, Guard))
  -> ( Declaration       -> m Declaration
     , Expr              -> m Expr
     , Binder            -> m Binder
     , CaseAlternative   -> m CaseAlternative
     , DoNotationElement -> m DoNotationElement
     , Guard             -> m Guard
     )
everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0, k'' s0)
  where
  f'' s = uncurry f' <=< f s

  f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
  f' s (ValueDecl sa name nameKind bs val) =
    ValueDecl sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
  f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
  f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds
  f' s (TypeInstanceDeclaration sa na ch idx name cs className args ds) = TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
  f' _ other = return other

  g'' s = uncurry g' <=< g s

  g' s (Literal ss l) = Literal ss <$> lit g'' s l
  g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v
  g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
  g' s (Parens v) = Parens <$> g'' s v
  g' s (Accessor prop v) = Accessor prop <$> g'' s v
  g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
  g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs
  g' s (Abs binder v) = Abs <$> h' s binder <*> g'' s v
  g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
  g' s (VisibleTypeApp v ty) = VisibleTypeApp <$> g'' s v <*> pure ty
  g' s (Unused v) = Unused <$> g'' s v
  g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
  g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts
  g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
  g' s (Let w ds v) = Let w <$> traverse (f'' s) ds <*> g'' s v
  g' s (Do m es) = Do m <$> traverse (j'' s) es
  g' s (Ado m es v) = Ado m <$> traverse (j'' s) es <*> g'' s v
  g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v
  g' _ other = return other

  h'' s = uncurry h' <=< h s

  h' s (LiteralBinder ss l) = LiteralBinder ss <$> lit h'' s l
  h' s (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h'' s) bs
  h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
  h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
  h' s (NamedBinder ss name b) = NamedBinder ss name <$> h'' s b
  h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
  h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
  h' _ other = return other

  lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a)
  lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as
  lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as
  lit _ _ other = return other

  i'' s = uncurry i' <=< i s

  i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM' s) val

  -- A specialized `guardedExprM` that keeps track of the context `s`
  -- after traversing `guards`, such that it's also exposed to `expr`.
  guardedExprM' :: s -> GuardedExpr -> m GuardedExpr
  guardedExprM' s (GuardedExpr guards expr) = do
    (guards', s') <- runStateT (traverse (StateT . goGuard) guards) s
    GuardedExpr guards' <$> g'' s' expr

  -- Like k'', but `s` is tracked.
  goGuard :: Guard -> s -> m (Guard, s)
  goGuard x s  = k s x >>= fmap swap . sndM' k'

  j'' s = uncurry j' <=< j s

  j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
  j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
  j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
  j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

  k'' s = uncurry k' <=< k s

  k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
  k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e

data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident
  deriving (Show, Eq, Ord)

inScope :: Ident -> S.Set ScopedIdent -> Bool
inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s)

everythingWithScope
  :: forall r
   . (Monoid r)
  => (S.Set ScopedIdent -> Declaration -> r)
  -> (S.Set ScopedIdent -> Expr -> r)
  -> (S.Set ScopedIdent -> Binder -> r)
  -> (S.Set ScopedIdent -> CaseAlternative -> r)
  -> (S.Set ScopedIdent -> DoNotationElement -> r)
  -> ( S.Set ScopedIdent -> Declaration -> r
     , S.Set ScopedIdent -> Expr -> r
     , S.Set ScopedIdent -> Binder -> r
     , S.Set ScopedIdent -> CaseAlternative -> r
     , S.Set ScopedIdent -> DoNotationElement -> r
     )
everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
  where
  f'' :: S.Set ScopedIdent -> Declaration -> r
  f'' s a = f s a <> f' s a

  f' :: S.Set ScopedIdent -> Declaration -> r
  f' s (DataBindingGroupDeclaration ds) =
    let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds))))
    in foldMap (f'' s') ds
  f' s (ValueDecl _ name _ bs val) =
    let s' = S.insert (ToplevelIdent name) s
        s'' = S.union s' (S.fromList (concatMap localBinderNames bs))
    in foldMap (h'' s') bs <> foldMap (l' s'') val
  f' s (BindingGroupDeclaration ds) =
    let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds)))
    in foldMap (\(_, _, val) -> g'' s' val) ds
  f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds
  f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
  f' _ _ = mempty

  g'' :: S.Set ScopedIdent -> Expr -> r
  g'' s a = g s a <> g' s a

  g' :: S.Set ScopedIdent -> Expr -> r
  g' s (Literal _ l) = lit g'' s l
  g' s (UnaryMinus _ v1) = g'' s v1
  g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
  g' s (Parens v1) = g'' s v1
  g' s (Accessor _ v1) = g'' s v1
  g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
  g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs
  g' s (Abs b v1) =
    let s' = S.union (S.fromList (localBinderNames b)) s
    in h'' s b <> g'' s' v1
  g' s (App v1 v2) = g'' s v1 <> g'' s v2
  g' s (VisibleTypeApp v _) = g'' s v
  g' s (Unused v) = g'' s v
  g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
  g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
  g' s (TypedValue _ v1 _) = g'' s v1
  g' s (Let _ ds v1) =
    let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
    in foldMap (f'' s') ds <> g'' s' v1
  g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es
  g' s (Ado _ es v1) =
    let s' = S.union s (foldMap (fst . j'' s) es)
    in g'' s' v1
  g' s (PositionedValue _ _ v1) = g'' s v1
  g' _ _ = mempty

  h'' :: S.Set ScopedIdent -> Binder -> r
  h'' s a = h s a <> h' s a

  h' :: S.Set ScopedIdent -> Binder -> r
  h' s (LiteralBinder _ l) = lit h'' s l
  h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
  h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
  h' s (ParensInBinder b) = h'' s b
  h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1
  h' s (PositionedBinder _ _ b1) = h'' s b1
  h' s (TypedBinder _ b1) = h'' s b1
  h' _ _ = mempty

  lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r
  lit go s (ArrayLiteral as) = foldMap (go s) as
  lit go s (ObjectLiteral as) = foldMap (go s . snd) as
  lit _ _ _ = mempty

  i'' :: S.Set ScopedIdent -> CaseAlternative -> r
  i'' s a = i s a <> i' s a

  i' :: S.Set ScopedIdent -> CaseAlternative -> r
  i' s (CaseAlternative bs gs) =
    let s' = S.union s (S.fromList (concatMap localBinderNames bs))
    in foldMap (h'' s) bs <> foldMap (l' s') gs

  j'' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
  j'' s a = let (s', r) = j' s a in (s', j s a <> r)

  j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
  j' s (DoNotationValue v) = (s, g'' s v)
  j' s (DoNotationBind b v) =
    let s' = S.union (S.fromList (localBinderNames b)) s
    in (s', h'' s b <> g'' s v)
  j' s (DoNotationLet ds) =
    let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
    in (s', foldMap (f'' s') ds)
  j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

  k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r)
  k' s (ConditionGuard e) = (s, g'' s e)
  k' s (PatternGuard b e) =
    let s' = S.union (S.fromList (localBinderNames b)) s
    in (s', h'' s b <> g'' s' e)

  l' s (GuardedExpr [] e) = g'' s e
  l' s (GuardedExpr (grd:gs) e) =
    let (s', r) = k' s grd
    in r <> l' s' (GuardedExpr gs e)

  getDeclIdent :: Declaration -> Maybe Ident
  getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
  getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td)
  getDeclIdent _ = Nothing

  localBinderNames = map LocalIdent . binderNames

accumTypes
  :: (Monoid r)
  => (SourceType -> r)
  -> ( Declaration -> r
     , Expr -> r
     , Binder -> r
     , CaseAlternative -> r
     , DoNotationElement -> r
     )
accumTypes f = everythingOnValues mappend forDecls forValues forBinders (const mempty) (const mempty)
  where
  forDecls (DataDeclaration _ _ _ args dctors) =
    foldMap (foldMap f . snd) args <>
    foldMap (foldMap (f . snd) . dataCtorFields) dctors
  forDecls (ExternDataDeclaration _ _ ty) = f ty
  forDecls (ExternDeclaration _ _ ty) = f ty
  forDecls (TypeClassDeclaration _ _ args implies _ _) =
    foldMap (foldMap (foldMap f)) args <>
    foldMap (foldMap f . constraintArgs) implies
  forDecls (TypeInstanceDeclaration _ _ _ _ _ cs _ tys _) =
    foldMap (foldMap f . constraintArgs) cs <> foldMap f tys
  forDecls (TypeSynonymDeclaration _ _ args ty) =
    foldMap (foldMap f . snd) args <>
    f ty
  forDecls (KindDeclaration _ _ _ ty) = f ty
  forDecls (TypeDeclaration td) = f (tydeclType td)
  forDecls _ = mempty

  forValues (TypeClassDictionary c _ _) = foldMap f (constraintArgs c)
  forValues (DeferredDictionary _ tys) = foldMap f tys
  forValues (TypedValue _ _ ty) = f ty
  forValues (VisibleTypeApp _ ty) = f ty
  forValues _ = mempty

  forBinders (TypedBinder ty _) = f ty
  forBinders _ = mempty

-- |
-- Map a function over type annotations appearing inside a value
--
overTypes :: (SourceType -> SourceType) -> Expr -> Expr
overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
  where
  g :: Expr -> Expr
  g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
  g (TypeClassDictionary c sco hints) =
    TypeClassDictionary
      (mapConstraintArgs (fmap f) c)
      (updateCtx sco)
      hints
  g other = other
  updateDict fn dict = dict { tcdInstanceTypes = fn (tcdInstanceTypes dict) }
  updateScope = fmap . fmap . fmap . fmap $ updateDict $ fmap f
  updateCtx = M.alter updateScope ByNullSourcePos