{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Retrie.Context
( ContextUpdater
, updateContext
, emptyContext
) where
import Control.Monad.IO.Class
import Data.Char (isDigit)
import Data.Either (partitionEithers)
import Data.Generics hiding (Fixity)
import Data.List
import Data.Maybe
import Retrie.AlphaEnv
import Retrie.ExactPrint
import Retrie.Fixity
import Retrie.FreeVars
import Retrie.GHC
import Retrie.Substitution
import Retrie.SYB
import Retrie.Types
import Retrie.Universe
type ContextUpdater = forall m. MonadIO m => GenericCU (TransformT m) Context
updateContext :: forall m. MonadIO m => GenericCU (TransformT m) Context
updateContext :: forall (m :: * -> *). MonadIO m => GenericCU (TransformT m) Context
updateContext Context
c Int
i =
TransformT m Context -> a -> TransformT m Context
forall a b. a -> b -> a
const (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
c)
(a -> TransformT m Context)
-> (HsExpr (GhcPass 'Parsed) -> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (HsExpr (GhcPass 'Parsed) -> Context)
-> HsExpr (GhcPass 'Parsed)
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr (GhcPass 'Parsed) -> Context
updExp)
(a -> TransformT m Context)
-> (HsType (GhcPass 'Parsed) -> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (HsType (GhcPass 'Parsed) -> Context)
-> HsType (GhcPass 'Parsed)
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType (GhcPass 'Parsed) -> Context
updType)
(a -> TransformT m Context)
-> (Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context)
-> Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
updMatch)
(a -> TransformT m Context)
-> (GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context)
-> GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRHSs (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
updGRHSs)
(a -> TransformT m Context)
-> (GRHS
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (GRHS
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context)
-> GRHS
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
GRHS
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
updGRHS)
(a -> TransformT m Context)
-> (StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context)
-> StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
updStmt)
(a -> TransformT m Context)
-> (Pat (GhcPass 'Parsed) -> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (Pat (GhcPass 'Parsed) -> Context)
-> Pat (GhcPass 'Parsed)
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat (GhcPass 'Parsed) -> Context
updPat)
(a -> TransformT m Context)
-> ([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))]
-> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> TransformT m Context
[GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))]
-> TransformT m Context
updStmtList
(a -> TransformT m Context)
-> (HsBind (GhcPass 'Parsed) -> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (HsBind (GhcPass 'Parsed) -> Context)
-> HsBind (GhcPass 'Parsed)
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsBind (GhcPass 'Parsed) -> Context
updHsBind)
(a -> TransformT m Context)
-> (TyClDecl (GhcPass 'Parsed) -> TransformT m Context)
-> a
-> TransformT m Context
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (TyClDecl (GhcPass 'Parsed) -> Context)
-> TyClDecl (GhcPass 'Parsed)
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl (GhcPass 'Parsed) -> Context
updTyClDecl)
where
neverParen :: Context
neverParen = Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = ParentPrec
NeverParen }
updExp :: HsExpr GhcPs -> Context
updExp :: HsExpr (GhcPass 'Parsed) -> Context
updExp HsApp{} =
Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = Fixity -> ParentPrec
HasPrec (Fixity -> ParentPrec) -> Fixity -> ParentPrec
forall a b. (a -> b) -> a -> b
$ SourceText -> Int -> FixityDirection -> Fixity
Fixity (String -> SourceText
SourceText String
"HsApp") (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstChild) FixityDirection
InfixL }
updExp (OpApp XOpApp (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
op LHsExpr (GhcPass 'Parsed)
_) = Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = Fixity -> ParentPrec
HasPrec (Fixity -> ParentPrec) -> Fixity -> ParentPrec
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed) -> FixityEnv -> Fixity
lookupOp LHsExpr (GhcPass 'Parsed)
op (Context -> FixityEnv
ctxtFixityEnv Context
c) }
updExp (HsLet XLet (GhcPass 'Parsed)
_ HsLocalBinds (GhcPass 'Parsed)
lbs LHsExpr (GhcPass 'Parsed)
_) = Context -> [RdrName] -> Context
addInScope Context
neverParen ([RdrName] -> Context) -> [RdrName] -> Context
forall a b. (a -> b) -> a -> b
$ CollectFlag (GhcPass 'Parsed)
-> HsLocalBinds (GhcPass 'Parsed) -> [IdP (GhcPass 'Parsed)]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders HsLocalBinds (GhcPass 'Parsed)
lbs
updExp HsExpr (GhcPass 'Parsed)
_ = Context
neverParen
updType :: HsType GhcPs -> Context
updType :: HsType (GhcPass 'Parsed) -> Context
updType HsAppTy{}
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
firstChild = Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = ParentPrec
IsHsAppsTy }
updType HsType (GhcPass 'Parsed)
_ = Context
neverParen
updMatch :: Match GhcPs (LHsExpr GhcPs) -> Context
updMatch :: Match (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
updMatch
| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
= Context -> [RdrName] -> Context
addInScope Context
c{ctxtParentPrec :: ParentPrec
ctxtParentPrec = ParentPrec
IsLhs} ([RdrName] -> Context)
-> (Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [RdrName])
-> Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectFlag (GhcPass 'Parsed)
-> [XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))]
-> [IdP (GhcPass 'Parsed)]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders ([XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))] -> [RdrName])
-> (Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))])
-> Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))]
forall p body. Match p body -> [LPat p]
m_pats
| Bool
otherwise = Context -> [RdrName] -> Context
addInScope Context
neverParen ([RdrName] -> Context)
-> (Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [RdrName])
-> Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectFlag (GhcPass 'Parsed)
-> [XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))]
-> [IdP (GhcPass 'Parsed)]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders ([XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))] -> [RdrName])
-> (Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))])
-> Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [XRec (GhcPass 'Parsed) (Pat (GhcPass 'Parsed))]
forall p body. Match p body -> [LPat p]
m_pats
where
updGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> Context
updGRHSs :: GRHSs (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
updGRHSs = Context -> [RdrName] -> Context
addInScope Context
neverParen ([RdrName] -> Context)
-> (GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [RdrName])
-> GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectFlag (GhcPass 'Parsed)
-> HsLocalBinds (GhcPass 'Parsed) -> [IdP (GhcPass 'Parsed)]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders (HsLocalBinds (GhcPass 'Parsed) -> [RdrName])
-> (GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> HsLocalBinds (GhcPass 'Parsed))
-> GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRHSs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> HsLocalBinds (GhcPass 'Parsed)
forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds
updGRHS :: GRHS GhcPs (LHsExpr GhcPs) -> Context
#if __GLASGOW_HASKELL__ < 900
updGRHS XGRHS{} = neverParen
#endif
updGRHS :: GRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
updGRHS (GRHS XCGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
_ [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
gs LHsExpr (GhcPass 'Parsed)
_)
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
firstChild = Context -> [RdrName] -> Context
addInScope Context
neverParen [RdrName]
bs
| Bool
otherwise = (Context, [RdrName]) -> Context
forall a b. (a, b) -> a
fst ((Context, [RdrName]) -> Context)
-> (Context, [RdrName]) -> Context
forall a b. (a -> b) -> a -> b
$ Context -> [RdrName] -> (Context, [RdrName])
updateSubstitution Context
neverParen [RdrName]
bs
where
bs :: [IdP (GhcPass 'Parsed)]
bs = CollectFlag (GhcPass 'Parsed)
-> [LStmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
-> [IdP (GhcPass 'Parsed)]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[LStmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
gs
updStmt :: Stmt GhcPs (LHsExpr GhcPs) -> Context
updStmt :: Stmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)) -> Context
updStmt Stmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
_ = Context
neverParen
updStmtList :: [LStmt GhcPs (LHsExpr GhcPs)] -> TransformT m Context
updStmtList :: [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> TransformT m Context
updStmtList [] = Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
neverParen
updStmtList (LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
ls:[LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
_)
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Context
-> [RdrName]
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
-> TransformT m Context
forall k (m :: * -> *).
(Matchable k, MonadIO m) =>
Context -> [RdrName] -> k -> TransformT m Context
insertDependentRewrites Context
neverParen [RdrName]
bs LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
ls
| L SrcSpanAnnA
_ (LetStmt XLetStmt
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
_ HsLocalBinds (GhcPass 'Parsed)
bnds) <- LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
ls =
Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> Context -> TransformT m Context
forall a b. (a -> b) -> a -> b
$ Context -> [RdrName] -> Context
addInScope Context
neverParen ([RdrName] -> Context) -> [RdrName] -> Context
forall a b. (a -> b) -> a -> b
$ CollectFlag (GhcPass 'Parsed)
-> HsLocalBinds (GhcPass 'Parsed) -> [IdP (GhcPass 'Parsed)]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders HsLocalBinds (GhcPass 'Parsed)
bnds
| Bool
otherwise = Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> Context -> TransformT m Context
forall a b. (a -> b) -> a -> b
$ (Context, [RdrName]) -> Context
forall a b. (a, b) -> a
fst ((Context, [RdrName]) -> Context)
-> (Context, [RdrName]) -> Context
forall a b. (a -> b) -> a -> b
$ Context -> [RdrName] -> (Context, [RdrName])
updateSubstitution Context
neverParen [RdrName]
bs
where
bs :: [IdP (GhcPass 'Parsed)]
bs = CollectFlag (GhcPass 'Parsed)
-> LStmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> [IdP (GhcPass 'Parsed)]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectLStmtBinders CollectFlag (GhcPass 'Parsed)
forall p. CollectFlag p
CollNoDictBinders LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
LStmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
ls
updHsBind :: HsBind GhcPs -> Context
updHsBind :: HsBind (GhcPass 'Parsed) -> Context
updHsBind FunBind{[CoreTickish]
MatchGroup (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
LIdP (GhcPass 'Parsed)
XFunBind (GhcPass 'Parsed) (GhcPass 'Parsed)
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick :: [CoreTickish]
fun_matches :: MatchGroup (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
fun_id :: LIdP (GhcPass 'Parsed)
fun_ext :: XFunBind (GhcPass 'Parsed) (GhcPass 'Parsed)
..} =
let rdr :: RdrName
rdr = GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass 'Parsed)
GenLocated SrcSpanAnnN RdrName
fun_id
in Context -> [RdrName] -> Context
addBinders (Context -> [RdrName] -> Context
addInScope Context
neverParen [RdrName
rdr]) [RdrName
rdr]
updHsBind HsBind (GhcPass 'Parsed)
_ = Context
neverParen
updTyClDecl :: TyClDecl GhcPs -> Context
updTyClDecl :: TyClDecl (GhcPass 'Parsed) -> Context
updTyClDecl SynDecl{LHsQTyVars (GhcPass 'Parsed)
XSynDecl (GhcPass 'Parsed)
LHsType (GhcPass 'Parsed)
LIdP (GhcPass 'Parsed)
LexicalFixity
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdSExt :: forall pass. TyClDecl pass -> XSynDecl pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdRhs :: LHsType (GhcPass 'Parsed)
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdLName :: LIdP (GhcPass 'Parsed)
tcdSExt :: XSynDecl (GhcPass 'Parsed)
..} = Context -> [RdrName] -> Context
addInScope Context
neverParen [GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass 'Parsed)
GenLocated SrcSpanAnnN RdrName
tcdLName]
updTyClDecl DataDecl{HsDataDefn (GhcPass 'Parsed)
LHsQTyVars (GhcPass 'Parsed)
LIdP (GhcPass 'Parsed)
XDataDecl (GhcPass 'Parsed)
LexicalFixity
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn :: HsDataDefn (GhcPass 'Parsed)
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdLName :: LIdP (GhcPass 'Parsed)
tcdDExt :: XDataDecl (GhcPass 'Parsed)
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
..} = Context -> [RdrName] -> Context
addInScope Context
neverParen [GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass 'Parsed)
GenLocated SrcSpanAnnN RdrName
tcdLName]
updTyClDecl ClassDecl{[LTyFamDefltDecl (GhcPass 'Parsed)]
[LHsFunDep (GhcPass 'Parsed)]
[LFamilyDecl (GhcPass 'Parsed)]
[LDocDecl (GhcPass 'Parsed)]
[LSig (GhcPass 'Parsed)]
Maybe (LHsContext (GhcPass 'Parsed))
LHsQTyVars (GhcPass 'Parsed)
LIdP (GhcPass 'Parsed)
XClassDecl (GhcPass 'Parsed)
LexicalFixity
LHsBinds (GhcPass 'Parsed)
tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdCExt :: forall pass. TyClDecl pass -> XClassDecl pass
tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdDocs :: forall pass. TyClDecl pass -> [LDocDecl pass]
tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdDocs :: [LDocDecl (GhcPass 'Parsed)]
tcdATDefs :: [LTyFamDefltDecl (GhcPass 'Parsed)]
tcdATs :: [LFamilyDecl (GhcPass 'Parsed)]
tcdMeths :: LHsBinds (GhcPass 'Parsed)
tcdSigs :: [LSig (GhcPass 'Parsed)]
tcdFDs :: [LHsFunDep (GhcPass 'Parsed)]
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdLName :: LIdP (GhcPass 'Parsed)
tcdCtxt :: Maybe (LHsContext (GhcPass 'Parsed))
tcdCExt :: XClassDecl (GhcPass 'Parsed)
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
..} = Context -> [RdrName] -> Context
addInScope Context
neverParen [GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass 'Parsed)
GenLocated SrcSpanAnnN RdrName
tcdLName]
updTyClDecl TyClDecl (GhcPass 'Parsed)
_ = Context
neverParen
updPat :: Pat GhcPs -> Context
updPat :: Pat (GhcPass 'Parsed) -> Context
updPat Pat (GhcPass 'Parsed)
_ = Context
neverParen
emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context
emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context
emptyContext FixityEnv
ctxtFixityEnv Rewriter
ctxtRewriter Rewriter
ctxtDependents = Context{[RdrName]
Maybe Substitution
FixityEnv
AlphaEnv
Rewriter
ParentPrec
forall {a}. [a]
forall {a}. Maybe a
ctxtSubst :: Maybe Substitution
ctxtRewriter :: Rewriter
ctxtInScope :: AlphaEnv
ctxtDependents :: Rewriter
ctxtBinders :: [RdrName]
ctxtSubst :: forall {a}. Maybe a
ctxtParentPrec :: ParentPrec
ctxtInScope :: AlphaEnv
ctxtBinders :: forall {a}. [a]
ctxtDependents :: Rewriter
ctxtRewriter :: Rewriter
ctxtFixityEnv :: FixityEnv
ctxtFixityEnv :: FixityEnv
ctxtParentPrec :: ParentPrec
..}
where
ctxtBinders :: [a]
ctxtBinders = []
ctxtInScope :: AlphaEnv
ctxtInScope = AlphaEnv
emptyAlphaEnv
ctxtParentPrec :: ParentPrec
ctxtParentPrec = ParentPrec
NeverParen
ctxtSubst :: Maybe a
ctxtSubst = Maybe a
forall {a}. Maybe a
Nothing
firstChild :: Int
firstChild :: Int
firstChild = Int
1
insertDependentRewrites
:: (Matchable k, MonadIO m) => Context -> [RdrName] -> k -> TransformT m Context
insertDependentRewrites :: forall k (m :: * -> *).
(Matchable k, MonadIO m) =>
Context -> [RdrName] -> k -> TransformT m Context
insertDependentRewrites Context
c [RdrName]
bs k
x = do
MatchResult k
r <- (RewriterResult Universe -> RewriterResult Universe)
-> Context -> Rewriter -> k -> TransformT m (MatchResult k)
forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
(RewriterResult Universe -> RewriterResult Universe)
-> Context -> Rewriter -> ast -> TransformT m (MatchResult ast)
runRewriter RewriterResult Universe -> RewriterResult Universe
forall a. a -> a
id Context
c (Context -> Rewriter
ctxtDependents Context
c) k
x
let
c' :: Context
c' = Context -> [RdrName] -> Context
addInScope Context
c [RdrName]
bs
case MatchResult k
r of
MatchResult k
NoMatch -> Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
c'
MatchResult Substitution
_ Template{Maybe [Rewrite Universe]
Annotated k
AnnotatedImports
tDependents :: forall ast. Template ast -> Maybe [Rewrite Universe]
tImports :: forall ast. Template ast -> AnnotatedImports
tTemplate :: forall ast. Template ast -> Annotated ast
tDependents :: Maybe [Rewrite Universe]
tImports :: AnnotatedImports
tTemplate :: Annotated k
..} -> do
let
rrs :: [Rewrite Universe]
rrs = [Rewrite Universe]
-> Maybe [Rewrite Universe] -> [Rewrite Universe]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Rewrite Universe]
tDependents
ds :: [Rewrite Universe]
ds = [Rewrite Universe] -> [Rewrite Universe]
forall ast. [Rewrite ast] -> [Rewrite ast]
rewritesWithDependents [Rewrite Universe]
rrs
f :: [Rewrite Universe] -> Rewriter
f = (Rewrite Universe -> Rewriter) -> [Rewrite Universe] -> Rewriter
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (AlphaEnv -> Rewrite Universe -> Rewriter
forall ast. Matchable ast => AlphaEnv -> Rewrite ast -> Rewriter
mkLocalRewriter (AlphaEnv -> Rewrite Universe -> Rewriter)
-> AlphaEnv -> Rewrite Universe -> Rewriter
forall a b. (a -> b) -> a -> b
$ Context -> AlphaEnv
ctxtInScope Context
c')
Context -> TransformT m Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
c'
{ ctxtRewriter :: Rewriter
ctxtRewriter = [Rewrite Universe] -> Rewriter
f [Rewrite Universe]
rrs Rewriter -> Rewriter -> Rewriter
forall a. Semigroup a => a -> a -> a
<> Context -> Rewriter
ctxtRewriter Context
c'
, ctxtDependents :: Rewriter
ctxtDependents = [Rewrite Universe] -> Rewriter
f [Rewrite Universe]
ds Rewriter -> Rewriter -> Rewriter
forall a. Semigroup a => a -> a -> a
<> Context -> Rewriter
ctxtDependents Context
c'
}
addInScope :: Context -> [RdrName] -> Context
addInScope :: Context -> [RdrName] -> Context
addInScope Context
c [RdrName]
bs =
Context
c' { ctxtInScope :: AlphaEnv
ctxtInScope = (RdrName -> AlphaEnv -> AlphaEnv)
-> AlphaEnv -> [RdrName] -> AlphaEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RdrName -> AlphaEnv -> AlphaEnv
extendAlphaEnv (Context -> AlphaEnv
ctxtInScope Context
c') [RdrName]
bs' }
where
(Context
c', [RdrName]
bs') = Context -> [RdrName] -> (Context, [RdrName])
updateSubstitution Context
c [RdrName]
bs
addBinders :: Context -> [RdrName] -> Context
addBinders :: Context -> [RdrName] -> Context
addBinders Context
c [RdrName]
bs = Context
c { ctxtBinders :: [RdrName]
ctxtBinders = [RdrName]
bs [RdrName] -> [RdrName] -> [RdrName]
forall a. [a] -> [a] -> [a]
++ Context -> [RdrName]
ctxtBinders Context
c }
updateSubstitution :: Context -> [RdrName] -> (Context, [RdrName])
updateSubstitution :: Context -> [RdrName] -> (Context, [RdrName])
updateSubstitution Context
c [RdrName]
rdrs =
case Context -> Maybe Substitution
ctxtSubst Context
c of
Maybe Substitution
Nothing -> (Context
c, [RdrName]
rdrs)
Just Substitution
sub ->
let
sub' :: Substitution
sub' = Substitution -> [FastString] -> Substitution
deleteSubst Substitution
sub ([FastString] -> Substitution) -> [FastString] -> Substitution
forall a b. (a -> b) -> a -> b
$ (RdrName -> FastString) -> [RdrName] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> FastString
rdrFS [RdrName]
rdrs
fvs :: FreeVars
fvs = Substitution -> FreeVars
substFVs Substitution
sub'
([RdrName]
noncapturing, [(RdrName, RdrName)]
capturing) =
[Either RdrName (RdrName, RdrName)]
-> ([RdrName], [(RdrName, RdrName)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either RdrName (RdrName, RdrName)]
-> ([RdrName], [(RdrName, RdrName)]))
-> [Either RdrName (RdrName, RdrName)]
-> ([RdrName], [(RdrName, RdrName)])
forall a b. (a -> b) -> a -> b
$ (RdrName -> Either RdrName (RdrName, RdrName))
-> [RdrName] -> [Either RdrName (RdrName, RdrName)]
forall a b. (a -> b) -> [a] -> [b]
map (FreeVars -> RdrName -> Either RdrName (RdrName, RdrName)
updateBinder FreeVars
fvs) [RdrName]
rdrs
alphaSub :: Substitution
alphaSub = (Substitution -> (FastString, HoleVal) -> Substitution)
-> Substitution -> [(FastString, HoleVal)] -> Substitution
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((FastString -> HoleVal -> Substitution)
-> (FastString, HoleVal) -> Substitution
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((FastString -> HoleVal -> Substitution)
-> (FastString, HoleVal) -> Substitution)
-> (Substitution -> FastString -> HoleVal -> Substitution)
-> Substitution
-> (FastString, HoleVal)
-> Substitution
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution -> FastString -> HoleVal -> Substitution
extendSubst) Substitution
sub'
[ (RdrName -> FastString
rdrFS RdrName
rdr, RdrName -> HoleVal
HoleRdr RdrName
rdr') | (RdrName
rdr, RdrName
rdr') <- [(RdrName, RdrName)]
capturing ]
rdrs' :: [RdrName]
rdrs' = ((RdrName, RdrName) -> RdrName)
-> [(RdrName, RdrName)] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RdrName, RdrName) -> RdrName
forall a b. (a, b) -> b
snd [(RdrName, RdrName)]
capturing [RdrName] -> [RdrName] -> [RdrName]
forall a. [a] -> [a] -> [a]
++ [RdrName]
noncapturing
in (Context
c { ctxtSubst :: Maybe Substitution
ctxtSubst = Substitution -> Maybe Substitution
forall a. a -> Maybe a
Just Substitution
alphaSub }, [RdrName]
rdrs')
updateBinder :: FreeVars -> RdrName -> Either RdrName (RdrName, RdrName)
updateBinder :: FreeVars -> RdrName -> Either RdrName (RdrName, RdrName)
updateBinder FreeVars
fvs RdrName
rdr
| RdrName -> FreeVars -> Bool
elemFVs RdrName
rdr FreeVars
fvs = (RdrName, RdrName) -> Either RdrName (RdrName, RdrName)
forall a b. b -> Either a b
Right (RdrName
rdr, RdrName -> FreeVars -> RdrName
renameBinder RdrName
rdr FreeVars
fvs)
| Bool
otherwise = RdrName -> Either RdrName (RdrName, RdrName)
forall a b. a -> Either a b
Left RdrName
rdr
renameBinder :: RdrName -> FreeVars -> RdrName
renameBinder :: RdrName -> FreeVars -> RdrName
renameBinder RdrName
rdr FreeVars
fvs = [RdrName] -> RdrName
forall a. [a] -> a
head
[ RdrName
rdr'
| Int
i <- [Int
n..]
, let rdr' :: RdrName
rdr' = FastString -> RdrName
mkVarUnqual (FastString -> RdrName) -> FastString -> RdrName
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
baseName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName
rdr' RdrName -> FreeVars -> Bool
`elemFVs` FreeVars
fvs
]
where
(String
ds, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
rdr
baseName :: String
baseName = String -> String
forall a. [a] -> [a]
reverse String
rest
n :: Int
n :: Int
n | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds = Int
1
| Bool
otherwise = String -> Int
forall a. Read a => String -> a
read (String -> String
forall a. [a] -> [a]
reverse String
ds) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1