{-# LANGUAGE CPP #-}
module Overloaded.Plugin.LocalDo where

import qualified Data.Generics   as SYB
import qualified GHC.Compat.All  as GHC
import           GHC.Compat.Expr

#if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Plugins     as Plugins
#else
import qualified GhcPlugins      as Plugins
#endif

import Overloaded.Plugin.Diagnostics
import Overloaded.Plugin.Names
import Overloaded.Plugin.Rewrite

#if MIN_VERSION_ghc(9,0,0)
#define _bufspan _
#else
#define _bufspan
#endif

transformDo
    :: Names
    -> LHsExpr GhcRn
    -> Rewrite (LHsExpr GhcRn)
transformDo :: Names -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)
transformDo Names
names (L SrcSpan
l (OpApp XOpApp GhcRn
_ (L (RealSrcSpan RealSrcSpan
l1 _bufspan) (HsVar _ (L _ doName)))
                                (L (RealSrcSpan RealSrcSpan
l2 _bufspan) (HsVar _ (L _ compName')))
                                (L (RealSrcSpan RealSrcSpan
l3 _bufspan)
#if MIN_VERSION_ghc(9,0,0)
                                   (HsDo _ (DoExpr Nothing) (L _ stmts))
#else
                                   (HsDo XDo GhcRn
_ HsStmtContext Name
DoExpr (L SrcSpan
_ [ExprLStmt GhcRn]
stmts))
#endif
                                   )))
    | RealSrcSpan -> RealSrcSpan -> Bool
spanNextTo RealSrcSpan
l1 RealSrcSpan
l2
    , RealSrcSpan -> RealSrcSpan -> Bool
spanNextTo RealSrcSpan
l2 RealSrcSpan
l3
    , IdP GhcRn
Name
compName' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Names -> Name
composeName Names
names
    = case Names
-> Name
-> SrcSpan
-> [ExprLStmt GhcRn]
-> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
transformDo' Names
names IdP GhcRn
Name
doName SrcSpan
l [ExprLStmt GhcRn]
stmts of
        Right LHsExpr GhcRn
x  -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)
forall a. a -> Rewrite a
Rewrite LHsExpr GhcRn
x
        Left DynFlags -> IO ()
err -> (DynFlags -> IO ()) -> Rewrite (LHsExpr GhcRn)
forall a. (DynFlags -> IO ()) -> Rewrite a
Error DynFlags -> IO ()
err
transformDo Names
_ LHsExpr GhcRn
_ = Rewrite (LHsExpr GhcRn)
forall a. Rewrite a
NoRewrite

transformDo' :: Names -> GHC.Name -> SrcSpan -> [ExprLStmt GhcRn] -> Either (GHC.DynFlags -> IO ()) (LHsExpr GhcRn)
transformDo' :: Names
-> Name
-> SrcSpan
-> [ExprLStmt GhcRn]
-> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
transformDo' Names
_names Name
_doName SrcSpan
l [] = (DynFlags -> IO ()) -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall a b. a -> Either a b
Left ((DynFlags -> IO ()) -> Either (DynFlags -> IO ()) (LHsExpr GhcRn))
-> (DynFlags -> IO ())
-> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Empty do"
#if MIN_VERSION_ghc(9,0,0)
transformDo'  names  doName _ (L l (BindStmt _ pat body) : next) = do
#else
transformDo'  Names
names  Name
doName SrcSpan
_ (L SrcSpan
l (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
body SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) : [ExprLStmt GhcRn]
next) = do
#endif
    LHsExpr GhcRn
next' <- Names
-> Name
-> SrcSpan
-> [ExprLStmt GhcRn]
-> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
transformDo' Names
names Name
doName SrcSpan
l [ExprLStmt GhcRn]
next
    LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn))
-> LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
hsApps SrcSpan
l LHsExpr GhcRn
bind [ LHsExpr GhcRn
body, LHsExpr GhcRn -> LHsExpr GhcRn
kont LHsExpr GhcRn
next' ]
  where
    bind :: LHsExpr GhcRn
bind  = SrcSpan -> LHsExpr GhcRn -> HsType GhcRn -> LHsExpr GhcRn
hsTyApp SrcSpan
l (SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
l Name
doName) (SrcSpan -> Name -> HsType GhcRn
hsTyVar SrcSpan
l (Names -> Name
doBindName Names
names))
    kont :: LHsExpr GhcRn -> LHsExpr GhcRn
kont LHsExpr GhcRn
next' = SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcRn -> LHsExpr GhcRn) -> HsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ XLam GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) -> HsExpr GhcRn
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
XLam GhcRn
noExtField MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG
        { mg_ext :: XMG GhcRn (LHsExpr GhcRn)
mg_ext    = NoExtField
XMG GhcRn (LHsExpr GhcRn)
noExtField
        , mg_alts :: Located [LMatch GhcRn (LHsExpr GhcRn)]
mg_alts   = SrcSpan
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l ([LMatch GhcRn (LHsExpr GhcRn)]
 -> Located [LMatch GhcRn (LHsExpr GhcRn)])
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ LMatch GhcRn (LHsExpr GhcRn) -> [LMatch GhcRn (LHsExpr GhcRn)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LMatch GhcRn (LHsExpr GhcRn) -> [LMatch GhcRn (LHsExpr GhcRn)])
-> LMatch GhcRn (LHsExpr GhcRn) -> [LMatch GhcRn (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Match GhcRn (LHsExpr GhcRn) -> LMatch GhcRn (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match
            { m_ext :: XCMatch GhcRn (LHsExpr GhcRn)
m_ext   = NoExtField
XCMatch GhcRn (LHsExpr GhcRn)
noExtField
            , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcRn))
m_ctxt  = HsMatchContext (NameOrRdrName (IdP GhcRn))
forall id. HsMatchContext id
LambdaExpr
            , m_pats :: [LPat GhcRn]
m_pats  = [LPat GhcRn
pat]
            , m_grhss :: GRHSs GhcRn (LHsExpr GhcRn)
m_grhss = GRHSs :: forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs
                { grhssExt :: XCGRHSs GhcRn (LHsExpr GhcRn)
grhssExt        = NoExtField
XCGRHSs GhcRn (LHsExpr GhcRn)
noExtField
                , grhssGRHSs :: [LGRHS GhcRn (LHsExpr GhcRn)]
grhssGRHSs      = [ SrcSpan
-> GRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (GRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn))
-> GRHS GhcRn (LHsExpr GhcRn) -> LGRHS GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcRn (LHsExpr GhcRn)
-> [ExprLStmt GhcRn] -> LHsExpr GhcRn -> GRHS GhcRn (LHsExpr GhcRn)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExtField
XCGRHS GhcRn (LHsExpr GhcRn)
noExtField [] (LHsExpr GhcRn -> GRHS GhcRn (LHsExpr GhcRn))
-> LHsExpr GhcRn -> GRHS GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn
next' ]
                , grhssLocalBinds :: LHsLocalBinds GhcRn
grhssLocalBinds = SrcSpan -> HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn)
-> HsLocalBindsLR GhcRn GhcRn -> LHsLocalBinds GhcRn
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcRn GhcRn -> HsLocalBindsLR GhcRn GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcRn GhcRn
noExtField
                }
            }
        , mg_origin :: Origin
mg_origin = Origin
Plugins.Generated
        }
transformDo'  Names
names  Name
doName SrcSpan
_ (L SrcSpan
l (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
body SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) : [ExprLStmt GhcRn]
next) = do
    LHsExpr GhcRn
next' <- Names
-> Name
-> SrcSpan
-> [ExprLStmt GhcRn]
-> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
transformDo' Names
names Name
doName SrcSpan
l [ExprLStmt GhcRn]
next
    LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn))
-> LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
hsApps SrcSpan
l LHsExpr GhcRn
then_ [ LHsExpr GhcRn
body, LHsExpr GhcRn
next' ]
  where
    then_ :: LHsExpr GhcRn
then_ = SrcSpan -> LHsExpr GhcRn -> HsType GhcRn -> LHsExpr GhcRn
hsTyApp SrcSpan
l (SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
l Name
doName) (SrcSpan -> Name -> HsType GhcRn
hsTyVar SrcSpan
l (Names -> Name
doThenName Names
names))

transformDo' Names
_ Name
_ SrcSpan
_ [L SrcSpan
_ (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
body Bool
_ SyntaxExpr GhcRn
_)] = LHsExpr GhcRn -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcRn
body
transformDo' Names
_ Name
_ SrcSpan
_ (L SrcSpan
l StmtLR GhcRn GhcRn (LHsExpr GhcRn)
stmt : [ExprLStmt GhcRn]
_) = (DynFlags -> IO ()) -> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall a b. a -> Either a b
Left ((DynFlags -> IO ()) -> Either (DynFlags -> IO ()) (LHsExpr GhcRn))
-> (DynFlags -> IO ())
-> Either (DynFlags -> IO ()) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Unsupported statement in do"
        SDoc -> SDoc -> SDoc
GHC.$$ StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr StmtLR GhcRn GhcRn (LHsExpr GhcRn)
stmt
        SDoc -> SDoc -> SDoc
GHC.$$ String -> SDoc
GHC.text (StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> String
forall a. Data a => a -> String
SYB.gshow StmtLR GhcRn GhcRn (LHsExpr GhcRn)
stmt)

spanNextTo :: RealSrcSpan -> RealSrcSpan -> Bool
spanNextTo :: RealSrcSpan -> RealSrcSpan -> Bool
spanNextTo RealSrcSpan
x RealSrcSpan
y
    = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
x
    Bool -> Bool -> Bool
&& RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
x