-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-- | Provides consistent interface with ghc-exactprint.
module Retrie.ExactPrint
  ( -- * Fixity re-association
    fix
    -- * Parsers
  , Parsers.LibDir
  , parseContent
  , parseContentNoFixity
  , parseDecl
  , parseExpr
  , parseImports
  , parsePattern
  , parseStmt
  , parseType
    -- * Primitive Transformations
  , addAllAnnsT
  -- , cloneT
  -- , setEntryDPT
  , swapEntryDPT
  , transferAnnsT
  , transferEntryAnnsT
  , transferEntryDPT
  -- , tryTransferEntryDPT
  , transferAnchor
    -- * Utils
  , debugDump
  , debugParse
  , debug
  , hasComments
  , isComma
    -- * Annotated AST
  , module Retrie.ExactPrint.Annotated
    -- * ghc-exactprint re-exports
  , module Language.Haskell.GHC.ExactPrint
  -- , module Language.Haskell.GHC.ExactPrint.Annotate
  , module Language.Haskell.GHC.ExactPrint.Types
  , module Language.Haskell.GHC.ExactPrint.Utils
  , module Language.Haskell.GHC.ExactPrint.Transform
  ) where

import Control.Exception
import Control.Monad.State.Lazy hiding (fix)
-- import Data.Function (on)
import Data.List (transpose)
-- import Data.Maybe
-- import qualified Data.Map as M
import Text.Printf

import Language.Haskell.GHC.ExactPrint hiding
  (
   setEntryDP
  , transferEntryDP
  )
-- import Language.Haskell.GHC.ExactPrint.ExactPrint (ExactPrint)
import Language.Haskell.GHC.ExactPrint.Utils hiding (debug)
import qualified Language.Haskell.GHC.ExactPrint.Parsers as Parsers
import Language.Haskell.GHC.ExactPrint.Types
  ( showGhc
  )
import Language.Haskell.GHC.ExactPrint.Transform

import Retrie.ExactPrint.Annotated
import Retrie.Fixity
import Retrie.GHC
import Retrie.SYB hiding (ext1)
import Retrie.Util

import GHC.Stack
import Debug.Trace

debug :: c -> String -> c
debug :: forall c. c -> String -> c
debug c
c String
s = forall a. String -> a -> a
trace String
s c
c

-- Fixity traversal -----------------------------------------------------------

-- | Re-associate AST using given 'FixityEnv'. (The GHC parser has no knowledge
-- of operator fixity, because that requires running the renamer, so it parses
-- all operators as left-associated.)
fix :: (Data ast, MonadIO m) => FixityEnv -> ast -> TransformT m ast
fix :: forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
env = ast -> TransformT m ast
fixAssociativity forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ast -> TransformT m ast
fixEntryDP
  where
    fixAssociativity :: ast -> TransformT m ast
fixAssociativity = forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM (forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env) forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env)
    fixEntryDP :: ast -> TransformT m ast
fixEntryDP = forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM (forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM forall (m :: * -> *).
MonadIO m =>
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` forall (m :: * -> *).
MonadIO m =>
LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat)

-- Should (x op1 y) op2 z be reassociated as x op1 (y op2 z)?
associatesRight :: Fixity -> Fixity -> Bool
associatesRight :: Fixity -> Fixity -> Bool
associatesRight (Fixity SourceText
_ Int
p1 FixityDirection
a1) (Fixity SourceText
_ Int
p2 FixityDirection
_a2) =
  Int
p2 forall a. Ord a => a -> a -> Bool
> Int
p1 Bool -> Bool -> Bool
|| Int
p1 forall a. Eq a => a -> a -> Bool
== Int
p2 Bool -> Bool -> Bool
&& FixityDirection
a1 forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixR

-- We know GHC produces left-associated chains, so 'z' is never an
-- operator application. We also know that this will be applied bottom-up
-- by 'everywhere', so we can assume the children are already fixed.
fixOneExpr
  :: MonadIO m
  => FixityEnv
  -> LHsExpr GhcPs
  -> TransformT m (LHsExpr GhcPs)
fixOneExpr :: forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env (L SrcSpanAnnA
l2 (OpApp XOpApp GhcPs
x2 ap1 :: LHsExpr GhcPs
ap1@(L SrcSpanAnnA
l1 (OpApp XOpApp GhcPs
x1 LHsExpr GhcPs
x LHsExpr GhcPs
op1 LHsExpr GhcPs
y)) LHsExpr GhcPs
op2 LHsExpr GhcPs
z))
  | Fixity -> Fixity -> Bool
associatesRight (LHsExpr GhcPs -> FixityEnv -> Fixity
lookupOp LHsExpr GhcPs
op1 FixityEnv
env) (LHsExpr GhcPs -> FixityEnv -> Fixity
lookupOp LHsExpr GhcPs
op2 FixityEnv
env) = do
    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:(l1,l2)="  [showAst (l1,l2)]
    let ap2' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap2' = forall l e. l -> e -> GenLocated l e
L (forall an. SrcAnn an -> SrcAnn an
stripComments SrcSpanAnnA
l2) forall a b. (a -> b) -> a -> b
$ forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
x2 LHsExpr GhcPs
y LHsExpr GhcPs
op2 LHsExpr GhcPs
z
    (GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap1_0, GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap2'_0) <- forall a b (m :: * -> *) a1 a2.
(Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1,
 Typeable a2) =>
LocatedAn a1 a
-> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT LHsExpr GhcPs
ap1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap2'
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap1_1 <- forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferAnnsT TrailingAnn -> Bool
isComma GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap2'_0 GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap1_0
    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:recursing"  []
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs <- forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap2'_0
    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:returning"  [showAst (L l2 $ OpApp x1 x op1 rhs)]
    -- return $ L l1 $ OpApp x1 x op1 rhs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l2 forall a b. (a -> b) -> a -> b
$ forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
x1 LHsExpr GhcPs
x LHsExpr GhcPs
op1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs
fixOneExpr FixityEnv
_ LHsExpr GhcPs
e = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e

fixOnePat :: Monad m => FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat :: forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env (forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat -> Just (L SrcSpanAnnA
l2 (ConPat XConPat GhcPs
ext2 XRec GhcPs (ConLikeP GhcPs)
op2 (InfixCon (forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat -> Just ap1 :: LPat GhcPs
ap1@(L SrcSpanAnnA
l1 (ConPat XConPat GhcPs
ext1 XRec GhcPs (ConLikeP GhcPs)
op1 (InfixCon LPat GhcPs
x LPat GhcPs
y)))) LPat GhcPs
z))))
  | Fixity -> Fixity -> Bool
associatesRight (LocatedN RdrName -> FixityEnv -> Fixity
lookupOpRdrName XRec GhcPs (ConLikeP GhcPs)
op1 FixityEnv
env) (LocatedN RdrName -> FixityEnv -> Fixity
lookupOpRdrName XRec GhcPs (ConLikeP GhcPs)
op2 FixityEnv
env) = do
    let ap2' :: GenLocated SrcSpanAnnA (Pat GhcPs)
ap2' = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l2 (forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
ext2 XRec GhcPs (ConLikeP GhcPs)
op2 (forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
y LPat GhcPs
z))
    (GenLocated SrcSpanAnnA (Pat GhcPs)
ap1_0, GenLocated SrcSpanAnnA (Pat GhcPs)
ap2'_0) <- forall a b (m :: * -> *) a1 a2.
(Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1,
 Typeable a2) =>
LocatedAn a1 a
-> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT LPat GhcPs
ap1 GenLocated SrcSpanAnnA (Pat GhcPs)
ap2'
    GenLocated SrcSpanAnnA (Pat GhcPs)
ap1_1 <- forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferAnnsT TrailingAnn -> Bool
isComma GenLocated SrcSpanAnnA (Pat GhcPs)
ap2' LPat GhcPs
ap1
    GenLocated SrcSpanAnnA (Pat GhcPs)
rhs <- forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env (forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat GenLocated SrcSpanAnnA (Pat GhcPs)
ap2'_0)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l1 (forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
ext1 XRec GhcPs (ConLikeP GhcPs)
op1 (forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
x GenLocated SrcSpanAnnA (Pat GhcPs)
rhs))
fixOnePat FixityEnv
_ LPat GhcPs
e = forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
e

-- TODO: move to ghc-exactprint
stripComments :: SrcAnn an -> SrcAnn an
stripComments :: forall an. SrcAnn an -> SrcAnn an
stripComments (SrcSpanAnn EpAnn an
EpAnnNotUsed SrcSpan
l) = forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn forall ann. EpAnn ann
EpAnnNotUsed SrcSpan
l
stripComments (SrcSpanAnn (EpAnn Anchor
anc an
an EpAnnComments
_) SrcSpan
l) = forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
an EpAnnComments
emptyComments) SrcSpan
l

-- Move leading whitespace from the left child of an operator application
-- to the application itself. We need this so we have correct offsets when
-- substituting into patterns and don't end up with extra leading spaces.
-- We can assume it is run bottom-up, and that precedence is already fixed.
fixOneEntry
  :: (MonadIO m, Data a)
  => LocatedA a -- ^ Overall application
  -> LocatedA a -- ^ Left child
  -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry :: forall (m :: * -> *) a.
(MonadIO m, Data a) =>
LocatedA a -> LocatedA a -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry LocatedA a
e LocatedA a
x = do
  -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(e,x)="  [showAst (e,x)]
  -- -- anns <- getAnnsT
  -- let
  --   zeros = SameLine 0
  --   (xdp, ard) =
  --     case M.lookup (mkAnnKey x) anns of
  --       Nothing -> (zeros, zeros)
  --       Just ann -> (annLeadingCommentEntryDelta ann, annEntryDelta ann)
  --   xr = getDeltaLine xdp
  --   xc = deltaColumn xdp
  --   actualRow = getDeltaLine ard
  --   edp =
  --     maybe zeros annLeadingCommentEntryDelta $ M.lookup (mkAnnKey e) anns
  --   er = getDeltaLine edp
  --   ec = deltaColumn edp
  -- when (actualRow == 0) $ do
  --   setEntryDPT e $ deltaPos (er, xc + ec)
  --   setEntryDPT x $ deltaPos (xr, 0)

  -- We assume that ghc-exactprint has converted all Anchor's to use their delta variants.
  -- Get the dp for the x component
  let xdp :: DeltaPos
xdp = forall a. LocatedA a -> DeltaPos
entryDP LocatedA a
x
  let xr :: Int
xr = DeltaPos -> Int
getDeltaLine DeltaPos
xdp
  let xc :: Int
xc = DeltaPos -> Int
deltaColumn DeltaPos
xdp
  -- Get the dp for the e component
  let edp :: DeltaPos
edp = forall a. LocatedA a -> DeltaPos
entryDP LocatedA a
e
  let er :: Int
er = DeltaPos -> Int
getDeltaLine DeltaPos
edp
  let ec :: Int
ec = DeltaPos -> Int
deltaColumn DeltaPos
edp
  case DeltaPos
xdp of
    SameLine Int
n -> do
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(xdp,edp)="  [showAst (xdp,edp)]
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(dpx,dpe)="  [showAst ((deltaPos er (xc + ec)),(deltaPos xr 0))]
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:e'="  [showAst e]
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:e'="  [showAst (setEntryDP e (deltaPos er (xc + ec)))]
      forall (m :: * -> *) a. Monad m => a -> m a
return ( forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LocatedA a
e (Int -> Int -> DeltaPos
deltaPos Int
er (Int
xc forall a. Num a => a -> a -> a
+ Int
ec))
             , forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LocatedA a
x (Int -> Int -> DeltaPos
deltaPos Int
xr Int
0))
    DeltaPos
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA a
e,LocatedA a
x)

  -- anns <- getAnnsT
  -- let
  --   zeros = DP (0,0)
  --   (DP (xr,xc), DP (actualRow,_)) =
  --     case M.lookup (mkAnnKey x) anns of
  --       Nothing -> (zeros, zeros)
  --       Just ann -> (annLeadingCommentEntryDelta ann, annEntryDelta ann)
  --   DP (er,ec) =
  --     maybe zeros annLeadingCommentEntryDelta $ M.lookup (mkAnnKey e) anns
  -- when (actualRow == 0) $ do
  --   setEntryDPT e $ DP (er, xc + ec)
  --   setEntryDPT x $ DP (xr, 0)
  -- return e

-- TODO: move this somewhere more appropriate
entryDP :: LocatedA a -> DeltaPos
entryDP :: forall a. LocatedA a -> DeltaPos
entryDP (L (SrcSpanAnn EpAnn AnnListItem
EpAnnNotUsed SrcSpan
_) a
_) = Int -> DeltaPos
SameLine Int
1
entryDP (L (SrcSpanAnn (EpAnn Anchor
anc AnnListItem
_ EpAnnComments
_) SrcSpan
_) a
_)
  = case Anchor -> AnchorOperation
anchor_op Anchor
anc of
      AnchorOperation
UnchangedAnchor -> Int -> DeltaPos
SameLine Int
1
      MovedAnchor DeltaPos
dp -> DeltaPos
dp


fixOneEntryExpr :: MonadIO m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr :: forall (m :: * -> *).
MonadIO m =>
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr e :: LHsExpr GhcPs
e@(L SrcSpanAnnA
l (OpApp XOpApp GhcPs
a LHsExpr GhcPs
x LHsExpr GhcPs
b LHsExpr GhcPs
c)) = do
  -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:(e,x)="  [showAst (e,x)]
  (GenLocated SrcSpanAnnA (HsExpr GhcPs)
e',GenLocated SrcSpanAnnA (HsExpr GhcPs)
x') <- forall (m :: * -> *) a.
(MonadIO m, Data a) =>
LocatedA a -> LocatedA a -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry LHsExpr GhcPs
e LHsExpr GhcPs
x
  -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:(e',x')="  [showAst (e',x')]
  -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:returning="  [showAst (L (getLoc e') (OpApp a x' b c))]
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
e') (forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
a GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' LHsExpr GhcPs
b LHsExpr GhcPs
c))
fixOneEntryExpr LHsExpr GhcPs
e = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e

fixOneEntryPat :: MonadIO m => LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat :: forall (m :: * -> *).
MonadIO m =>
LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat LPat GhcPs
pat
#if __GLASGOW_HASKELL__ < 900
  | Just p@(L l (ConPatIn a (InfixCon x b))) <- dLPat pat = do
#else
  | Just p :: LPat GhcPs
p@(L SrcSpanAnnA
l (ConPat XConPat GhcPs
a XRec GhcPs (ConLikeP GhcPs)
b (InfixCon LPat GhcPs
x LPat GhcPs
c))) <- forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat LPat GhcPs
pat = do
#endif
    (GenLocated SrcSpanAnnA (Pat GhcPs)
p', GenLocated SrcSpanAnnA (Pat GhcPs)
x') <- forall (m :: * -> *) a.
(MonadIO m, Data a) =>
LocatedA a -> LocatedA a -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry LPat GhcPs
p (forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
dLPatUnsafe LPat GhcPs
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat forall a b. (a -> b) -> a -> b
$ (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (Pat GhcPs)
p') (forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
a XRec GhcPs (ConLikeP GhcPs)
b (forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon GenLocated SrcSpanAnnA (Pat GhcPs)
x' LPat GhcPs
c))))
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
pat

-------------------------------------------------------------------------------


-- Swap entryDP and prior comments between the two args
swapEntryDPT
  :: (Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1, Typeable a2)
  => LocatedAn a1 a -> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT :: forall a b (m :: * -> *) a1 a2.
(Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1,
 Typeable a2) =>
LocatedAn a1 a
-> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT LocatedAn a1 a
a LocatedAn a2 b
b = do
  LocatedAn a2 b
b' <- forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LocatedAn a1 a
a LocatedAn a2 b
b
  LocatedAn a1 a
a' <- forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LocatedAn a2 b
b LocatedAn a1 a
a
  forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn a1 a
a',LocatedAn a2 b
b')

-- swapEntryDPT
--   :: (Data a, Data b, Monad m)
--   => LocatedAn a1 a -> LocatedAn a2 b -> TransformT m ()
-- swapEntryDPT a b =
--   modifyAnnsT $ \ anns ->
--   let akey = mkAnnKey a
--       bkey = mkAnnKey b
--       aann = fromMaybe annNone $ M.lookup akey anns
--       bann = fromMaybe annNone $ M.lookup bkey anns
--   in M.insert akey
--       aann { annEntryDelta = annEntryDelta bann
--            , annPriorComments = annPriorComments bann } $
--      M.insert bkey
--       bann { annEntryDelta = annEntryDelta aann
--            , annPriorComments = annPriorComments aann } anns

-------------------------------------------------------------------------------

-- Compatibility module with ghc-exactprint

parseContentNoFixity :: Parsers.LibDir -> FilePath -> String -> IO AnnotatedModule
parseContentNoFixity :: String -> String -> String -> IO AnnotatedModule
parseContentNoFixity String
libdir String
fp String
str = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. String -> (DynFlags -> a) -> IO a
Parsers.withDynFlags String
libdir forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> do
  ParseResult (Located HsModule)
r <- String -> String -> String -> IO (ParseResult (Located HsModule))
Parsers.parseModuleFromString String
libdir String
fp String
str
  case ParseResult (Located HsModule)
r of
    Left ErrorMessages
msg -> do
#if __GLASGOW_HASKELL__ < 900
      fail $ show msg
#elif __GLASGOW_HASKELL__ < 904
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList ErrorMessages
msg
#else
      fail $ showSDoc dflags $ ppr msg
#endif
    Right Located HsModule
m -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ast. ast -> Int -> Annotated ast
unsafeMkA (forall ast. ExactPrint ast => ast -> ast
makeDeltaAst Located HsModule
m) Int
0

parseContent :: Parsers.LibDir -> FixityEnv -> FilePath -> String -> IO AnnotatedModule
parseContent :: String -> FixityEnv -> String -> String -> IO AnnotatedModule
parseContent String
libdir FixityEnv
fixities String
fp =
  String -> String -> String -> IO AnnotatedModule
parseContentNoFixity String
libdir String
fp forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
`transformA` forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixities)

-- | Parse import statements. Each string must be a full import statement,
-- including the keyword 'import'. Supports full import syntax.
parseImports :: Parsers.LibDir -> [String] -> IO AnnotatedImports
parseImports :: String -> [String] -> IO AnnotatedImports
parseImports String
_      []      = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
parseImports String
libdir [String]
imports = do
  -- imports start on second line, so delta offsets are correct
  AnnotatedModule
am <- String -> String -> String -> IO AnnotatedModule
parseContentNoFixity String
libdir String
"parseImports" forall a b. (a -> b) -> a -> b
$ String
"\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
imports
  Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ais <- forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> [LImportDecl GhcPs]
hsmodImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ast. Data ast => Annotated ast -> Annotated ast
trimA Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ais

-- | Parse a top-level 'HsDecl'.
parseDecl :: Parsers.LibDir -> String -> IO AnnotatedHsDecl
parseDecl :: String -> String -> IO AnnotatedHsDecl
parseDecl String
libdir String
str = forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseDecl" Parser (LHsDecl GhcPs)
Parsers.parseDecl String
str

-- | Parse a 'HsExpr'.
parseExpr :: Parsers.LibDir -> String -> IO AnnotatedHsExpr
parseExpr :: String -> String -> IO AnnotatedHsExpr
parseExpr String
libdir String
str = forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseExpr" Parser (LHsExpr GhcPs)
Parsers.parseExpr String
str

-- | Parse a 'Pat'.
parsePattern :: Parsers.LibDir -> String -> IO AnnotatedPat
-- parsePattern libdir str = parseHelper libdir "parsePattern" p str
--   where
--     p flags fp str' = fmap dLPatUnsafe <$> Parsers.parsePattern flags fp str'
parsePattern :: String -> String -> IO AnnotatedPat
parsePattern String
libdir String
str = forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parsePattern" Parser (LPat GhcPs)
Parsers.parsePattern String
str

-- | Parse a 'Stmt'.
parseStmt :: Parsers.LibDir -> String -> IO AnnotatedStmt
parseStmt :: String -> String -> IO AnnotatedStmt
parseStmt String
libdir String
str = do
  -- debugPrint Loud "parseStmt:for" [str]
  Annotated
  (LocatedAn
     AnnListItem
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
res <- forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseStmt" Parser (ExprLStmt GhcPs)
Parsers.parseStmt String
str
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall an ast.
Default an =>
Annotated (LocatedAn an ast)
-> DeltaPos -> Annotated (LocatedAn an ast)
setEntryDPA Annotated
  (LocatedAn
     AnnListItem
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
res (Int -> Int -> DeltaPos
DifferentLine Int
1 Int
0))
  -- return res


-- | Parse a 'HsType'.
parseType :: Parsers.LibDir -> String -> IO AnnotatedHsType
parseType :: String -> String -> IO AnnotatedHsType
parseType String
libdir String
str = forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseType" Parser (LHsType GhcPs)
Parsers.parseType String
str

parseHelper :: (ExactPrint a)
  => Parsers.LibDir -> FilePath -> Parsers.Parser a -> String -> IO (Annotated a)
parseHelper :: forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
fp Parser a
parser String
str = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. String -> (DynFlags -> a) -> IO a
Parsers.withDynFlags String
libdir forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
  case Parser a
parser DynFlags
dflags String
fp String
str of
#if __GLASGOW_HASKELL__ < 900
    Left (_, msg) -> throwIO $ ErrorCall msg
#elif __GLASGOW_HASKELL__ < 904
    Left ErrorMessages
errBag -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList ErrorMessages
errBag)
#else
    Left msg -> throwIO $ ErrorCall (showSDoc dflags $ ppr msg)
#endif
    Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ast. ast -> Int -> Annotated ast
unsafeMkA (forall ast. ExactPrint ast => ast -> ast
makeDeltaAst a
x) Int
0

-- type Parser a = GHC.DynFlags -> FilePath -> String -> ParseResult a


-------------------------------------------------------------------------------

debugDump :: (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump :: forall a. (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump Annotated a
ax = do
  let
    str :: String
str = forall ast. (Data ast, ExactPrint ast) => Annotated ast -> String
printA Annotated a
ax
    maxCol :: Int
maxCol = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
str
    (String
tens, String
ones) =
      case forall a. [[a]] -> [[a]]
transpose [forall r. PrintfType r => String -> r
printf String
"%2d" Int
i | Int
i <- [Int
1 .. Int
maxCol]] of
        [String
ts, String
os] -> (String
ts, String
os)
        [String]
_ -> (String
"", String
"")
  -- putStrLn $ unlines
  --   [ show k ++ "\n  " ++ show v | (k,v) <- M.toList (annsA ax) ]
  String -> IO ()
putStrLn String
tens
  String -> IO ()
putStrLn String
ones
  String -> IO ()
putStrLn String
str
  String -> IO ()
putStrLn String
"------------------------------------"
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall ast. (Data ast, ExactPrint ast) => Annotated ast -> String
showAstA Annotated a
ax
  String -> IO ()
putStrLn String
"------------------------------------"

-- cloneT :: (Data a, Typeable a, Monad m) => a -> TransformT m a
-- cloneT e = getAnnsT >>= flip graftT e

-- The following definitions are all the same as the ones from ghc-exactprint,
-- but the types are liberalized from 'Transform a' to 'TransformT m a'.
transferEntryAnnsT
  :: (HasCallStack, Data a, Data b, Monad m)
  => (TrailingAnn -> Bool)  -- transfer Anns matching predicate
  -> LocatedA a             -- from
  -> LocatedA b             -- to
  -> TransformT m (LocatedA b)
transferEntryAnnsT :: forall a b (m :: * -> *).
(HasCallStack, Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferEntryAnnsT TrailingAnn -> Bool
p LocatedA a
a LocatedA b
b = do
  LocatedA b
b' <- forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LocatedA a
a LocatedA b
b
  forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferAnnsT TrailingAnn -> Bool
p LocatedA a
a LocatedA b
b'

-- | 'Transform' monad version of 'transferEntryDP'
transferEntryDPT
  :: (HasCallStack, Data a, Data b, Monad m)
  => Located a -> Located b -> TransformT m ()
-- transferEntryDPT a b = modifyAnnsT (transferEntryDP a b)
transferEntryDPT :: forall a b (m :: * -> *).
(HasCallStack, Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
transferEntryDPT Located a
_a Located b
_b = forall a. HasCallStack => String -> a
error String
"transferEntryDPT"

-- tryTransferEntryDPT
--   :: (Data a, Data b, Monad m)
--   => Located a -> Located b -> TransformT m ()
-- tryTransferEntryDPT a b = modifyAnnsT $ \anns ->
--   if M.member (mkAnnKey a) anns
--     then transferEntryDP a b anns
--     else anns

-- This function fails if b is not in Anns, which seems dumb, since we are inserting it.
-- transferEntryDP :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
-- transferEntryDP a b anns = setEntryDP b dp anns'
--   where
--     maybeAnns = do -- Maybe monad
--       anA <- M.lookup (mkAnnKey a) anns
--       let anB = M.findWithDefault annNone (mkAnnKey b) anns
--           anB' = anB { annEntryDelta = DP (0,0) }
--       return (M.insert (mkAnnKey b) anB' anns, annLeadingCommentEntryDelta anA)
--     (anns',dp) = fromMaybe
--                   (error $ "transferEntryDP: lookup failed: " ++ show (mkAnnKey a))
--                   maybeAnns

addAllAnnsT
  :: (HasCallStack, Monoid an, Data a, Data b, MonadIO m, Typeable an)
  => LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an b)
addAllAnnsT :: forall an a b (m :: * -> *).
(HasCallStack, Monoid an, Data a, Data b, MonadIO m,
 Typeable an) =>
LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an b)
addAllAnnsT LocatedAn an a
a LocatedAn an b
b = do
  -- AZ: to start with, just transfer the entry DP from a to b
  forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LocatedAn an a
a LocatedAn an b
b


-- addAllAnnsT
--   :: (HasCallStack, Data a, Data b, Monad m)
--   => Located a -> Located b -> TransformT m ()
-- addAllAnnsT a b = modifyAnnsT (addAllAnns a b)

-- addAllAnns :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
-- addAllAnns a b anns =
--   fromMaybe
--     (error $ "addAllAnns: lookup failed: " ++ show (mkAnnKey a)
--       ++ " or " ++ show (mkAnnKey b))
--     $ do ann <- M.lookup (mkAnnKey a) anns
--          case M.lookup (mkAnnKey b) anns of
--            Just ann' -> return $ M.insert (mkAnnKey b) (ann `annAdd` ann') anns
--            Nothing -> return $ M.insert (mkAnnKey b) ann anns
--   where annAdd ann ann' = ann'
--           { annEntryDelta = annEntryDelta ann
--           , annPriorComments = ((++) `on` annPriorComments) ann ann'
--           , annFollowingComments = ((++) `on` annFollowingComments) ann ann'
--           , annsDP = ((++) `on` annsDP) ann ann'
--           }

transferAnchor :: LocatedA a -> LocatedA b -> LocatedA b
transferAnchor :: forall a b. LocatedA a -> LocatedA b -> LocatedA b
transferAnchor (L (SrcSpanAnn EpAnn AnnListItem
EpAnnNotUsed SrcSpan
l)    a
_) LocatedA b
lb = forall an a.
Default an =>
LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
setAnchorAn LocatedA b
lb (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l) EpAnnComments
emptyComments
transferAnchor (L (SrcSpanAnn (EpAnn Anchor
anc AnnListItem
_ EpAnnComments
_) SrcSpan
_) a
_) LocatedA b
lb = forall an a.
Default an =>
LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
setAnchorAn LocatedA b
lb Anchor
anc              EpAnnComments
emptyComments


isComma :: TrailingAnn -> Bool
isComma :: TrailingAnn -> Bool
isComma (AddCommaAnn EpaLocation
_) = Bool
True
isComma TrailingAnn
_ = Bool
False

isCommentKeyword :: AnnKeywordId -> Bool
-- isCommentKeyword (AnnComment _) = True
isCommentKeyword :: AnnKeywordId -> Bool
isCommentKeyword AnnKeywordId
_ = Bool
False

-- isCommentAnnotation :: Annotation -> Bool
-- isCommentAnnotation Ann{..} =
--   (not . null $ annPriorComments)
--   || (not . null $ annFollowingComments)
--   || any (isCommentKeyword . fst) annsDP

hasComments :: LocatedAn an a -> Bool
hasComments :: forall an a. LocatedAn an a -> Bool
hasComments (L (SrcSpanAnn EpAnn an
EpAnnNotUsed SrcSpan
_) a
_) = Bool
False
hasComments (L (SrcSpanAnn (EpAnn Anchor
anc an
_ EpAnnComments
cs) SrcSpan
_) a
_)
  = case EpAnnComments
cs of
      EpaComments [] -> Bool
False
      EpaCommentsBalanced [] [] -> Bool
False
      EpAnnComments
_ -> Bool
True

-- hasComments :: (Data a, Monad m) => Located a -> TransformT m Bool
-- hasComments e = do
--   anns <- getAnnsT
--   let b = isCommentAnnotation <$> M.lookup (mkAnnKey e) anns
--   return $ fromMaybe False b

-- transferAnnsT
--   :: (Data a, Data b, Monad m)
--   => (KeywordId -> Bool)        -- transfer Anns matching predicate
--   -> Located a                  -- from
--   -> Located b                  -- to
--   -> TransformT m ()
-- transferAnnsT p a b = modifyAnnsT f
--   where
--     bKey = mkAnnKey b
--     f anns = fromMaybe anns $ do
--       anA <- M.lookup (mkAnnKey a) anns
--       anB <- M.lookup bKey anns
--       let anB' = anB { annsDP = annsDP anB ++ filter (p . fst) (annsDP anA) }
--       return $ M.insert bKey anB' anns

transferAnnsT
  :: (Data a, Data b, Monad m)
  => (TrailingAnn -> Bool)      -- transfer Anns matching predicate
  -> LocatedA a                 -- from
  -> LocatedA b                 -- to
  -> TransformT m (LocatedA b)
transferAnnsT :: forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferAnnsT TrailingAnn -> Bool
p (L (SrcSpanAnn EpAnn AnnListItem
EpAnnNotUsed SrcSpan
_) a
_) LocatedA b
b = forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA b
b
transferAnnsT TrailingAnn -> Bool
p (L (SrcSpanAnn (EpAnn Anchor
anc (AnnListItem [TrailingAnn]
ts) EpAnnComments
cs) SrcSpan
l) a
a) (L (SrcSpanAnn EpAnn AnnListItem
an SrcSpan
lb) b
b) = do
  let ps :: [TrailingAnn]
ps = forall a. (a -> Bool) -> [a] -> [a]
filter TrailingAnn -> Bool
p [TrailingAnn]
ts
  let an' :: EpAnn AnnListItem
an' = case EpAnn AnnListItem
an of
        EpAnn AnnListItem
EpAnnNotUsed -> forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
spanAsAnchor SrcSpan
lb) ([TrailingAnn] -> AnnListItem
AnnListItem [TrailingAnn]
ps) EpAnnComments
emptyComments
        EpAnn Anchor
ancb (AnnListItem [TrailingAnn]
tsb) EpAnnComments
csb -> forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
ancb ([TrailingAnn] -> AnnListItem
AnnListItem ([TrailingAnn]
tsbforall a. [a] -> [a] -> [a]
++[TrailingAnn]
ps)) EpAnnComments
csb
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn AnnListItem
an' SrcSpan
lb) b
b)


-- -- | 'Transform' monad version of 'setEntryDP',
-- --   which sets the entry 'DeltaPos' for an annotation.
-- setEntryDPT
--   :: (Data a, Monad m)
--   => Located a -> DeltaPos -> TransformT m ()
-- setEntryDPT ast dp = do
--   modifyAnnsT (setEntryDP ast dp)

-- -- | Set the true entry 'DeltaPos' from the annotation of a
-- --   given AST element.
-- setEntryDP :: Data a => Located a -> DeltaPos -> Anns -> Anns
-- --  The setEntryDP that comes with exactprint does some really confusing
-- --  entry math around comments that I'm unconvinced is either correct or useful.
-- setEntryDP x dp anns = M.alter (Just . f . fromMaybe annNone) k anns
--   where
--     k = mkAnnKey x
--     f ann = case annPriorComments ann of
--               []       -> ann { annEntryDelta = dp }
--               (c,_):cs -> ann { annPriorComments = (c,dp):cs }

-- Useful for figuring out what annotations should be on something.
-- If you don't care about fixities, pass 'mempty' as the FixityEnv.
-- String should be the entire module contents.
debugParse :: Parsers.LibDir -> FixityEnv -> String -> IO ()
debugParse :: String -> FixityEnv -> String -> IO ()
debugParse String
libdir FixityEnv
fixityEnv String
s = do
  String -> String -> IO ()
writeFile String
"debug.txt" String
s
  ParseResult (Located HsModule)
r <- String -> String -> IO (ParseResult (Located HsModule))
parseModule String
libdir String
"debug.txt"
  case ParseResult (Located HsModule)
r of
    Left ErrorMessages
_ -> String -> IO ()
putStrLn String
"parse failed"
    Right Located HsModule
modl -> do
      let m :: AnnotatedModule
m = forall ast. ast -> Int -> Annotated ast
unsafeMkA (forall ast. ExactPrint ast => ast -> ast
makeDeltaAst Located HsModule
modl) Int
0
      String -> IO ()
putStrLn String
"parseModule"
      forall a. (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump AnnotatedModule
m
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ AnnotatedModule -> IO AnnotatedModule
transformDebug AnnotatedModule
m
  where
    transformDebug :: AnnotatedModule -> IO AnnotatedModule
transformDebug =
      forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOneExpr D.def" (forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
fixityEnv)
        forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOnePat D.def" (forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
fixityEnv)
        forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOneEntryExpr" forall (m :: * -> *).
MonadIO m =>
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr
        forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOneEntryPat" forall (m :: * -> *).
MonadIO m =>
LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat

    run :: String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
wat b -> TransformT IO b
f Annotated a
m = do
      String -> IO ()
putStrLn String
wat
      Annotated a
m' <- forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated a
m (forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM (forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM b -> TransformT IO b
f))
      forall a. (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump Annotated a
m'
      forall (m :: * -> *) a. Monad m => a -> m a
return Annotated a
m'