-- 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
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 = String -> c -> c
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 (ast -> TransformT m ast)
-> (ast -> TransformT m ast) -> ast -> TransformT m ast
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 = GenericM (TransformT m) -> GenericM (TransformT m)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env) (a -> TransformT m a)
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
    -> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> a
-> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env)
    fixEntryDP :: ast -> TransformT m ast
fixEntryDP = GenericM (TransformT m) -> GenericM (TransformT m)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *).
MonadIO m =>
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr (a -> TransformT m a)
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
    -> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> a
-> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` LPat GhcPs -> TransformT m (LPat GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p1 Bool -> Bool -> Bool
|| Int
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p2 Bool -> Bool -> Bool
&& FixityDirection
a1 FixityDirection -> FixityDirection -> Bool
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' = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnA
forall an. SrcAnn an -> SrcAnn an
stripComments SrcSpanAnnA
l2) (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
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) <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT
     m
     (GenLocated SrcSpanAnnA (HsExpr GhcPs),
      GenLocated SrcSpanAnnA (HsExpr GhcPs))
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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap2'
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
ap1_1 <- (TrailingAnn -> Bool)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
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 <- FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env LHsExpr GhcPs
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
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l2 (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
x1 LHsExpr GhcPs
x LHsExpr GhcPs
op1 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs
fixOneExpr FixityEnv
_ LHsExpr GhcPs
e = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 (LPat GhcPs -> Maybe (LPat GhcPs)
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 (LPat GhcPs -> Maybe (LPat GhcPs)
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)
LocatedN RdrName
op1 FixityEnv
env) (LocatedN RdrName -> FixityEnv -> Fixity
lookupOpRdrName XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
op2 FixityEnv
env) = do
    let ap2' :: GenLocated SrcSpanAnnA (Pat GhcPs)
ap2' = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l2 (XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
ext2 XRec GhcPs (ConLikeP GhcPs)
op2 (LPat GhcPs
-> LPat GhcPs
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
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) <- GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT
     m
     (GenLocated SrcSpanAnnA (Pat GhcPs),
      GenLocated SrcSpanAnnA (Pat GhcPs))
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
GenLocated SrcSpanAnnA (Pat GhcPs)
ap1 GenLocated SrcSpanAnnA (Pat GhcPs)
ap2'
    GenLocated SrcSpanAnnA (Pat GhcPs)
ap1_1 <- (TrailingAnn -> Bool)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
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
GenLocated SrcSpanAnnA (Pat GhcPs)
ap1
    GenLocated SrcSpanAnnA (Pat GhcPs)
rhs <- FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env (LPat GhcPs -> LPat GhcPs
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
ap2'_0)
    GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> LPat GhcPs
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l1 (XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
ext1 XRec GhcPs (ConLikeP GhcPs)
op1 (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
x GenLocated SrcSpanAnnA (Pat GhcPs)
rhs))
fixOnePat FixityEnv
_ LPat GhcPs
e = GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
GenLocated SrcSpanAnnA (Pat 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) = EpAnn an -> SrcSpan -> SrcSpanAnn' (EpAnn an)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn an
forall ann. EpAnn ann
EpAnnNotUsed SrcSpan
l
stripComments (SrcSpanAnn (EpAnn Anchor
anc an
an EpAnnComments
_) SrcSpan
l) = EpAnn an -> SrcSpan -> SrcSpanAnn' (EpAnn an)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> an -> EpAnnComments -> EpAnn an
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 = LocatedA a -> DeltaPos
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 = LocatedA a -> DeltaPos
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)))]
      (LocatedA a, LocatedA a) -> TransformT m (LocatedA a, LocatedA a)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return ( LocatedA a -> DeltaPos -> LocatedA a
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LocatedA a
e (Int -> Int -> DeltaPos
deltaPos Int
er (Int
xc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ec))
             , LocatedA a -> DeltaPos -> LocatedA a
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
_ -> (LocatedA a, LocatedA a) -> TransformT m (LocatedA a, LocatedA a)
forall a. a -> TransformT m a
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') <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT
     m
     (GenLocated SrcSpanAnnA (HsExpr GhcPs),
      GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *) a.
(MonadIO m, Data a) =>
LocatedA a -> LocatedA a -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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))]
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
e') (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
a LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' LHsExpr GhcPs
b LHsExpr GhcPs
c))
fixOneEntryExpr LHsExpr GhcPs
e = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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))) <- LPat GhcPs -> Maybe (LPat GhcPs)
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') <- GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT
     m
     (GenLocated SrcSpanAnnA (Pat GhcPs),
      GenLocated SrcSpanAnnA (Pat GhcPs))
forall (m :: * -> *) a.
(MonadIO m, Data a) =>
LocatedA a -> LocatedA a -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p (LPat GhcPs -> LPat GhcPs
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
dLPatUnsafe LPat GhcPs
x)
    GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> LPat GhcPs
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (Pat GhcPs)
p') (XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
a XRec GhcPs (ConLikeP GhcPs)
b (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon GenLocated SrcSpanAnnA (Pat GhcPs)
x' LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
c))))
  | Bool
otherwise = GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
GenLocated SrcSpanAnnA (Pat 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' <- LocatedAn a1 a -> LocatedAn a2 b -> TransformT m (LocatedAn a2 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' <- LocatedAn a2 b -> LocatedAn a1 a -> TransformT m (LocatedAn a1 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
  (LocatedAn a1 a, LocatedAn a2 b)
-> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
forall a. a -> TransformT m 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 = IO (IO AnnotatedModule) -> IO AnnotatedModule
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO AnnotatedModule) -> IO AnnotatedModule)
-> IO (IO AnnotatedModule) -> IO AnnotatedModule
forall a b. (a -> b) -> a -> b
$ String
-> (DynFlags -> IO AnnotatedModule) -> IO (IO AnnotatedModule)
forall a. String -> (DynFlags -> a) -> IO a
Parsers.withDynFlags String
libdir ((DynFlags -> IO AnnotatedModule) -> IO (IO AnnotatedModule))
-> (DynFlags -> IO AnnotatedModule) -> IO (IO AnnotatedModule)
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> do
  ParseResult (Located (HsModule GhcPs))
r <- String
-> String -> String -> IO (ParseResult (Located (HsModule GhcPs)))
Parsers.parseModuleFromString String
libdir String
fp String
str
  case ParseResult (Located (HsModule GhcPs))
r of
    Left ErrorMessages
msg -> do
#if __GLASGOW_HASKELL__ < 900
      fail $ show msg
#elif __GLASGOW_HASKELL__ < 904
      fail $ show $ bagToList msg
#else
      String -> IO AnnotatedModule
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO AnnotatedModule) -> String -> IO AnnotatedModule
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SDoc
forall a. Outputable a => a -> SDoc
ppr ErrorMessages
msg
#endif
    Right Located (HsModule GhcPs)
m -> AnnotatedModule -> IO AnnotatedModule
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnotatedModule -> IO AnnotatedModule)
-> AnnotatedModule -> IO AnnotatedModule
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs) -> Int -> AnnotatedModule
forall ast. ast -> Int -> Annotated ast
unsafeMkA (Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall ast. ExactPrint ast => ast -> ast
makeDeltaAst Located (HsModule GhcPs)
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 (String -> IO AnnotatedModule)
-> (AnnotatedModule -> IO AnnotatedModule)
-> String
-> IO AnnotatedModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (AnnotatedModule
-> (Located (HsModule GhcPs)
    -> TransformT IO (Located (HsModule GhcPs)))
-> IO AnnotatedModule
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
`transformA` FixityEnv
-> Located (HsModule GhcPs)
-> TransformT IO (Located (HsModule GhcPs))
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
_      []      = Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
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" (String -> IO AnnotatedModule) -> String -> IO AnnotatedModule
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
imports
  Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ais <- AnnotatedModule
-> (Located (HsModule GhcPs)
    -> TransformT IO [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((Located (HsModule GhcPs)
  -> TransformT IO [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
 -> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]))
-> (Located (HsModule GhcPs)
    -> TransformT IO [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> TransformT IO [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. a -> TransformT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
 -> TransformT IO [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> (Located (HsModule GhcPs)
    -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> Located (HsModule GhcPs)
-> TransformT IO [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule GhcPs -> [LImportDecl GhcPs]
HsModule GhcPs -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall p. HsModule p -> [LImportDecl p]
hsmodImports (HsModule GhcPs -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> (Located (HsModule GhcPs) -> HsModule GhcPs)
-> Located (HsModule GhcPs)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc
  Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
 -> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]))
-> Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a b. (a -> b) -> a -> b
$ Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
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 = String
-> String
-> Parser (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> String
-> IO (Annotated (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseDecl" Parser (LHsDecl GhcPs)
Parser (GenLocated SrcSpanAnnA (HsDecl GhcPs))
Parsers.parseDecl String
str

-- | Parse a 'HsExpr'.
parseExpr :: Parsers.LibDir -> String -> IO AnnotatedHsExpr
parseExpr :: String -> String -> IO AnnotatedHsExpr
parseExpr String
libdir String
str = String
-> String
-> Parser (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> String
-> IO (Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseExpr" Parser (LHsExpr GhcPs)
Parser (GenLocated SrcSpanAnnA (HsExpr 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 = String
-> String
-> Parser (GenLocated SrcSpanAnnA (Pat GhcPs))
-> String
-> IO (Annotated (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parsePattern" Parser (LPat GhcPs)
Parser (GenLocated SrcSpanAnnA (Pat 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 <- String
-> String
-> Parser
     (LocatedAn
        AnnListItem
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> String
-> IO
     (Annotated
        (LocatedAn
           AnnListItem
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseStmt" Parser (ExprLStmt GhcPs)
Parser
  (LocatedAn
     AnnListItem
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Parsers.parseStmt String
str
  Annotated
  (LocatedAn
     AnnListItem
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> IO
     (Annotated
        (LocatedAn
           AnnListItem
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Annotated
  (LocatedAn
     AnnListItem
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> DeltaPos
-> Annotated
     (LocatedAn
        AnnListItem
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
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 = String
-> String
-> Parser (GenLocated SrcSpanAnnA (HsType GhcPs))
-> String
-> IO (Annotated (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall a.
ExactPrint a =>
String -> String -> Parser a -> String -> IO (Annotated a)
parseHelper String
libdir String
"parseType" Parser (LHsType GhcPs)
Parser (GenLocated SrcSpanAnnA (HsType 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 = IO (IO (Annotated a)) -> IO (Annotated a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Annotated a)) -> IO (Annotated a))
-> IO (IO (Annotated a)) -> IO (Annotated a)
forall a b. (a -> b) -> a -> b
$ String -> (DynFlags -> IO (Annotated a)) -> IO (IO (Annotated a))
forall a. String -> (DynFlags -> a) -> IO a
Parsers.withDynFlags String
libdir ((DynFlags -> IO (Annotated a)) -> IO (IO (Annotated a)))
-> (DynFlags -> IO (Annotated a)) -> IO (IO (Annotated a))
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 errBag -> throwIO $ ErrorCall (show $ bagToList errBag)
#else
    Left ErrorMessages
msg -> ErrorCall -> IO (Annotated a)
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO (Annotated a)) -> ErrorCall -> IO (Annotated a)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SDoc
forall a. Outputable a => a -> SDoc
ppr ErrorMessages
msg)
#endif
    Right a
x -> Annotated a -> IO (Annotated a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Annotated a -> IO (Annotated a))
-> Annotated a -> IO (Annotated a)
forall a b. (a -> b) -> a -> b
$ a -> Int -> Annotated a
forall ast. ast -> Int -> Annotated ast
unsafeMkA (a -> a
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 = Annotated a -> String
forall ast. (Data ast, ExactPrint ast) => Annotated ast -> String
printA Annotated a
ax
    maxCol :: Int
maxCol = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> [Int]) -> [String] -> [Int]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
str
    (String
tens, String
ones) =
      case [String] -> [String]
forall a. [[a]] -> [[a]]
transpose [String -> Int -> String
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Annotated a -> String
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' <- LocatedA a -> LocatedA b -> TransformT m (LocatedA 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
  (TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA 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 = String -> TransformT m ()
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
  LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an 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 = LocatedA b -> Anchor -> EpAnnComments -> LocatedA b
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 = LocatedA b -> Anchor -> EpAnnComments -> LocatedA b
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 = LocatedA b -> TransformT m (LocatedA b)
forall a. a -> TransformT m a
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 = (TrailingAnn -> Bool) -> [TrailingAnn] -> [TrailingAnn]
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 -> Anchor -> AnnListItem -> EpAnnComments -> EpAnn AnnListItem
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 -> Anchor -> AnnListItem -> EpAnnComments -> EpAnn AnnListItem
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
ancb ([TrailingAnn] -> AnnListItem
AnnListItem ([TrailingAnn]
tsb[TrailingAnn] -> [TrailingAnn] -> [TrailingAnn]
forall a. [a] -> [a] -> [a]
++[TrailingAnn]
ps)) EpAnnComments
csb
  LocatedA b -> TransformT m (LocatedA b)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> b -> LocatedA b
forall l e. l -> e -> GenLocated l e
L (EpAnn AnnListItem -> SrcSpan -> SrcSpanAnnA
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 GhcPs))
r <- String -> String -> IO (ParseResult (Located (HsModule GhcPs)))
parseModule String
libdir String
"debug.txt"
  case ParseResult (Located (HsModule GhcPs))
r of
    Left ErrorMessages
_ -> String -> IO ()
putStrLn String
"parse failed"
    Right Located (HsModule GhcPs)
modl -> do
      let m :: AnnotatedModule
m = Located (HsModule GhcPs) -> Int -> AnnotatedModule
forall ast. ast -> Int -> Annotated ast
unsafeMkA (Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall ast. ExactPrint ast => ast -> ast
makeDeltaAst Located (HsModule GhcPs)
modl) Int
0
      String -> IO ()
putStrLn String
"parseModule"
      AnnotatedModule -> IO ()
forall a. (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump AnnotatedModule
m
      IO AnnotatedModule -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO AnnotatedModule -> IO ()) -> IO AnnotatedModule -> IO ()
forall a b. (a -> b) -> a -> b
$ AnnotatedModule -> IO AnnotatedModule
transformDebug AnnotatedModule
m
  where
    transformDebug :: AnnotatedModule -> IO AnnotatedModule
transformDebug =
      String
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> AnnotatedModule
-> IO AnnotatedModule
forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOneExpr D.def" (FixityEnv -> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
MonadIO m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
fixityEnv)
        (AnnotatedModule -> IO AnnotatedModule)
-> (AnnotatedModule -> IO AnnotatedModule)
-> AnnotatedModule
-> IO AnnotatedModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
    -> TransformT IO (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> AnnotatedModule
-> IO AnnotatedModule
forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOnePat D.def" (FixityEnv -> LPat GhcPs -> TransformT IO (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
fixityEnv)
        (AnnotatedModule -> IO AnnotatedModule)
-> (AnnotatedModule -> IO AnnotatedModule)
-> AnnotatedModule
-> IO AnnotatedModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> AnnotatedModule
-> IO AnnotatedModule
forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOneEntryExpr" LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *).
MonadIO m =>
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr
        (AnnotatedModule -> IO AnnotatedModule)
-> (AnnotatedModule -> IO AnnotatedModule)
-> AnnotatedModule
-> IO AnnotatedModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
    -> TransformT IO (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> AnnotatedModule
-> IO AnnotatedModule
forall {a} {b}.
(Data a, ExactPrint a, Typeable b) =>
String -> (b -> TransformT IO b) -> Annotated a -> IO (Annotated a)
run String
"fixOneEntryPat" LPat GhcPs -> TransformT IO (LPat GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT IO (GenLocated SrcSpanAnnA (Pat GhcPs))
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' <- Annotated a -> (a -> TransformT IO a) -> IO (Annotated a)
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated a
m (GenericM (TransformT IO) -> GenericM (TransformT IO)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((b -> TransformT IO b) -> a -> TransformT IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM b -> TransformT IO b
f))
      Annotated a -> IO ()
forall a. (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump Annotated a
m'
      Annotated a -> IO (Annotated a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Annotated a
m'