-- 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
  , parseContent
  , parseContentNoFixity
  , parseDecl
  , parseExpr
  , parseImports
  , parsePattern
  , parseStmt
  , parseType
    -- * Primitive Transformations
  , addAllAnnsT
  , cloneT
  , setEntryDPT
  , swapEntryDPT
  , transferAnnsT
  , transferEntryAnnsT
  , transferEntryDPT
  , tryTransferEntryDPT
    -- * Utils
  , debugDump
  , debugParse
  , 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
  ) 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
  ( cloneT
  , setEntryDP
  , setEntryDPT
  , transferEntryDPT
  , transferEntryDP
  )
import Language.Haskell.GHC.ExactPrint.Annotate (Annotate)
import qualified Language.Haskell.GHC.ExactPrint.Parsers as Parsers
import Language.Haskell.GHC.ExactPrint.Types
  ( AnnConName(..)
  , DeltaPos(..)
  , KeywordId(..)
  , annGetConstr
  , annNone
  , emptyAnns
  , mkAnnKey
  )
import Language.Haskell.GHC.ExactPrint.Utils (annLeadingCommentEntryDelta, showGhc)

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

import GHC.Stack

-- 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, Monad m) => FixityEnv -> ast -> TransformT m ast
fix :: 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 ((LHsExpr GhcPs -> TransformT m (LHsExpr 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 :: * -> *).
Monad m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env) (a -> TransformT m a)
-> (Located (Pat GhcPs) -> TransformT m (Located (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 ((LHsExpr GhcPs -> TransformT m (LHsExpr 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)
forall (m :: * -> *).
Monad m =>
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr (a -> TransformT m a)
-> (Located (Pat GhcPs) -> TransformT m (Located (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` Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *).
Monad 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
  :: Monad m
  => FixityEnv
  -> LHsExpr GhcPs
  -> TransformT m (LHsExpr GhcPs)
fixOneExpr :: FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env (L SrcSpan
l2 (OpApp XOpApp GhcPs
x2 ap1 :: LHsExpr GhcPs
ap1@(L SrcSpan
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
    let ap2' :: LHsExpr GhcPs
ap2' = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l2 (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr 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
    LHsExpr GhcPs -> LHsExpr GhcPs -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
swapEntryDPT LHsExpr GhcPs
ap1 LHsExpr GhcPs
ap2'
    (KeywordId -> Bool)
-> LHsExpr GhcPs -> LHsExpr GhcPs -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(KeywordId -> Bool) -> Located a -> Located b -> TransformT m ()
transferAnnsT KeywordId -> Bool
isComma LHsExpr GhcPs
ap2' LHsExpr GhcPs
ap1
    LHsExpr GhcPs
rhs <- FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
FixityEnv -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneExpr FixityEnv
env LHsExpr GhcPs
ap2'
    LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l1 (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr 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
rhs
fixOneExpr FixityEnv
_ LHsExpr GhcPs
e = LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e

fixOnePat :: Monad m => FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
#if __GLASGOW_HASKELL__ < 900
fixOnePat :: FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env (LPat GhcPs -> Maybe (Located (Pat GhcPs))
forall (p :: Pass).
LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
dLPat -> Just (L SrcSpan
l2 (ConPatIn Located (IdP GhcPs)
op2 (InfixCon (LPat GhcPs -> Maybe (Located (Pat GhcPs))
forall (p :: Pass).
LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
dLPat -> Just ap1 :: Located (Pat GhcPs)
ap1@(L SrcSpan
l1 (ConPatIn Located (IdP GhcPs)
op1 (InfixCon LPat GhcPs
x LPat GhcPs
y)))) LPat GhcPs
z))))
  | Fixity -> Fixity -> Bool
associatesRight (Located RdrName -> FixityEnv -> Fixity
lookupOpRdrName Located (IdP GhcPs)
Located RdrName
op1 FixityEnv
env) (Located RdrName -> FixityEnv -> Fixity
lookupOpRdrName Located (IdP GhcPs)
Located RdrName
op2 FixityEnv
env) = do
    let ap2' :: Located (Pat GhcPs)
ap2' = SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l2 (Located (IdP GhcPs)
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcPs)
op2 (Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
Located (Pat GhcPs)
y LPat GhcPs
Located (Pat GhcPs)
z))
    Located (Pat GhcPs) -> Located (Pat GhcPs) -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
swapEntryDPT Located (Pat GhcPs)
ap1 Located (Pat GhcPs)
ap2'
    (KeywordId -> Bool)
-> Located (Pat GhcPs) -> Located (Pat GhcPs) -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(KeywordId -> Bool) -> Located a -> Located b -> TransformT m ()
transferAnnsT KeywordId -> Bool
isComma Located (Pat GhcPs)
ap2' Located (Pat GhcPs)
ap1
    Located (Pat GhcPs)
rhs <- FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat FixityEnv
env (Located (Pat GhcPs) -> LPat GhcPs
forall (p :: Pass). Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat Located (Pat GhcPs)
ap2')
    Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs)))
-> Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ Located (Pat GhcPs) -> LPat GhcPs
forall (p :: Pass). Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat (Located (Pat GhcPs) -> LPat GhcPs)
-> Located (Pat GhcPs) -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l1 (Located (IdP GhcPs)
-> HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
-> Pat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcPs)
op1 (Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
Located (Pat GhcPs)
x Located (Pat GhcPs)
rhs))
#else
fixOnePat env (dLPat -> Just (L l2 (ConPat ext2 op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPat ext1 op1 (InfixCon x y)))) z))))
  | associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do
    let ap2' = L l2 (ConPat ext2 op2 (InfixCon y z))
    swapEntryDPT ap1 ap2'
    transferAnnsT isComma ap2' ap1
    rhs <- fixOnePat env (cLPat ap2')
    return $ cLPat $ L l1 (ConPat ext1 op1 (InfixCon x rhs))
#endif
fixOnePat FixityEnv
_ LPat GhcPs
e = Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
Located (Pat GhcPs)
e

-- 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
  :: (Monad m, Data a)
  => Located a -- ^ Overall application
  -> Located a -- ^ Left child
  -> TransformT m (Located a)
fixOneEntry :: Located a -> Located a -> TransformT m (Located a)
fixOneEntry Located a
e Located a
x = do
  Anns
anns <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  let
    zeros :: DeltaPos
zeros = (Int, Int) -> DeltaPos
DP (Int
0,Int
0)
    (DP (Int
xr,Int
xc), DP (Int
actualRow,Int
_)) =
      case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
x) Anns
anns of
        Maybe Annotation
Nothing -> (DeltaPos
zeros, DeltaPos
zeros)
        Just Annotation
ann -> (Annotation -> DeltaPos
annLeadingCommentEntryDelta Annotation
ann, Annotation -> DeltaPos
annEntryDelta Annotation
ann)
    DP (Int
er,Int
ec) =
      DeltaPos
-> (Annotation -> DeltaPos) -> Maybe Annotation -> DeltaPos
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DeltaPos
zeros Annotation -> DeltaPos
annLeadingCommentEntryDelta (Maybe Annotation -> DeltaPos) -> Maybe Annotation -> DeltaPos
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
e) Anns
anns
  Bool -> TransformT m () -> TransformT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actualRow Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (TransformT m () -> TransformT m ())
-> TransformT m () -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ do
    Located a -> DeltaPos -> TransformT m ()
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> DeltaPos -> TransformT m ()
setEntryDPT Located a
e (DeltaPos -> TransformT m ()) -> DeltaPos -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> DeltaPos
DP (Int
er, Int
xc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ec)
    Located a -> DeltaPos -> TransformT m ()
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> DeltaPos -> TransformT m ()
setEntryDPT Located a
x (DeltaPos -> TransformT m ()) -> DeltaPos -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> DeltaPos
DP (Int
xr, Int
0)
  Located a -> TransformT m (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located a
e

fixOneEntryExpr :: Monad m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr :: LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr e :: LHsExpr GhcPs
e@(L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
_ LHsExpr GhcPs
_)) = LHsExpr GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *) a.
(Monad m, Data a) =>
Located a -> Located a -> TransformT m (Located a)
fixOneEntry LHsExpr GhcPs
e LHsExpr GhcPs
x
fixOneEntryExpr LHsExpr GhcPs
e = LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e

fixOneEntryPat :: Monad m => LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat :: LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat LPat GhcPs
pat
#if __GLASGOW_HASKELL__ < 900
  | Just p :: Located (Pat GhcPs)
p@(L SrcSpan
_ (ConPatIn Located (IdP GhcPs)
_ (InfixCon LPat GhcPs
x LPat GhcPs
_))) <- LPat GhcPs -> Maybe (Located (Pat GhcPs))
forall (p :: Pass).
LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
dLPat LPat GhcPs
pat =
#else
  | Just p@(L _ (ConPat _ _ (InfixCon x _))) <- dLPat pat =
#endif
    Located (Pat GhcPs) -> Located (Pat GhcPs)
forall (p :: Pass). Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> TransformT m (Located (Pat GhcPs))
-> TransformT m (Located (Pat GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (Pat GhcPs)
-> Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *) a.
(Monad m, Data a) =>
Located a -> Located a -> TransformT m (Located a)
fixOneEntry Located (Pat GhcPs)
p (LPat GhcPs -> Located (Pat GhcPs)
forall (p :: Pass). LPat (GhcPass p) -> Located (Pat (GhcPass p))
dLPatUnsafe LPat GhcPs
x)
  | Bool
otherwise = Located (Pat GhcPs) -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
Located (Pat GhcPs)
pat

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

swapEntryDPT
  :: (Data a, Data b, Monad m)
  => Located a -> Located b -> TransformT m ()
swapEntryDPT :: Located a -> Located b -> TransformT m ()
swapEntryDPT Located a
a Located b
b = (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT ((Anns -> Anns) -> TransformT m ())
-> (Anns -> Anns) -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ \ Anns
anns ->
  let akey :: AnnKey
akey = Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a
      bkey :: AnnKey
bkey = Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b
      aann :: Annotation
aann = Annotation -> Maybe Annotation -> Annotation
forall a. a -> Maybe a -> a
fromMaybe Annotation
annNone (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AnnKey
akey Anns
anns
      bann :: Annotation
bann = Annotation -> Maybe Annotation -> Annotation
forall a. a -> Maybe a -> a
fromMaybe Annotation
annNone (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AnnKey
bkey Anns
anns
  in AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AnnKey
akey
      Annotation
aann { annEntryDelta :: DeltaPos
annEntryDelta = Annotation -> DeltaPos
annEntryDelta Annotation
bann
           , annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
bann } (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$
     AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AnnKey
bkey
      Annotation
bann { annEntryDelta :: DeltaPos
annEntryDelta = Annotation -> DeltaPos
annEntryDelta Annotation
aann
           , annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
aann } Anns
anns

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

-- Compatibility module with ghc-exactprint

parseContentNoFixity :: FilePath -> String -> IO AnnotatedModule
parseContentNoFixity :: FilePath -> FilePath -> IO AnnotatedModule
parseContentNoFixity FilePath
fp FilePath
str = do
  ParseResult ParsedSource
r <- FilePath -> FilePath -> IO (ParseResult ParsedSource)
Parsers.parseModuleFromString FilePath
fp FilePath
str
  case ParseResult ParsedSource
r of
    Left ErrorMessages
msg -> do
#if __GLASGOW_HASKELL__ < 810
      fail $ show msg
#else
      IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (DynFlags -> IO ()) -> IO (IO ())
forall a. (DynFlags -> a) -> IO a
Parsers.withDynFlags ((DynFlags -> IO ()) -> IO (IO ()))
-> (DynFlags -> IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> DynFlags -> ErrorMessages -> IO ()
printBagOfErrors DynFlags
dflags ErrorMessages
msg
      FilePath -> IO AnnotatedModule
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"parse failed"
#endif
    Right (Anns
anns, ParsedSource
m) -> AnnotatedModule -> IO AnnotatedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnotatedModule -> IO AnnotatedModule)
-> AnnotatedModule -> IO AnnotatedModule
forall a b. (a -> b) -> a -> b
$ ParsedSource -> Anns -> Int -> AnnotatedModule
forall ast. ast -> Anns -> Int -> Annotated ast
unsafeMkA ParsedSource
m Anns
anns Int
0

parseContent :: FixityEnv -> FilePath -> String -> IO AnnotatedModule
parseContent :: FixityEnv -> FilePath -> FilePath -> IO AnnotatedModule
parseContent FixityEnv
fixities FilePath
fp =
  FilePath -> FilePath -> IO AnnotatedModule
parseContentNoFixity FilePath
fp (FilePath -> IO AnnotatedModule)
-> (AnnotatedModule -> IO AnnotatedModule)
-> FilePath
-> IO AnnotatedModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (AnnotatedModule
-> (ParsedSource -> TransformT IO ParsedSource)
-> IO AnnotatedModule
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
`transformA` FixityEnv -> ParsedSource -> TransformT IO ParsedSource
forall ast (m :: * -> *).
(Data ast, Monad 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 :: [String] -> IO AnnotatedImports
parseImports :: [FilePath] -> IO AnnotatedImports
parseImports []      = AnnotatedImports -> IO AnnotatedImports
forall (m :: * -> *) a. Monad m => a -> m a
return AnnotatedImports
forall a. Monoid a => a
mempty
parseImports [FilePath]
imports = do
  -- imports start on second line, so delta offsets are correct
  AnnotatedModule
am <- FilePath -> FilePath -> IO AnnotatedModule
parseContentNoFixity FilePath
"parseImports" (FilePath -> IO AnnotatedModule) -> FilePath -> IO AnnotatedModule
forall a b. (a -> b) -> a -> b
$ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines [FilePath]
imports
  AnnotatedImports
ais <- AnnotatedModule
-> (ParsedSource -> TransformT IO [LImportDecl GhcPs])
-> IO AnnotatedImports
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((ParsedSource -> TransformT IO [LImportDecl GhcPs])
 -> IO AnnotatedImports)
-> (ParsedSource -> TransformT IO [LImportDecl GhcPs])
-> IO AnnotatedImports
forall a b. (a -> b) -> a -> b
$ [LImportDecl GhcPs] -> TransformT IO [LImportDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LImportDecl GhcPs] -> TransformT IO [LImportDecl GhcPs])
-> (ParsedSource -> [LImportDecl GhcPs])
-> ParsedSource
-> TransformT IO [LImportDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports (HsModule GhcPs -> [LImportDecl GhcPs])
-> (ParsedSource -> HsModule GhcPs)
-> ParsedSource
-> [LImportDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedSource -> HsModule GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
  AnnotatedImports -> IO AnnotatedImports
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnotatedImports -> IO AnnotatedImports)
-> AnnotatedImports -> IO AnnotatedImports
forall a b. (a -> b) -> a -> b
$ AnnotatedImports -> AnnotatedImports
forall ast. Data ast => Annotated ast -> Annotated ast
trimA AnnotatedImports
ais

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

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

-- | Parse a 'Pat'.
parsePattern :: String -> IO AnnotatedPat
parsePattern :: FilePath -> IO AnnotatedPat
parsePattern = FilePath
-> Parser (Located (Pat GhcPs)) -> FilePath -> IO AnnotatedPat
forall a. FilePath -> Parser a -> FilePath -> IO (Annotated a)
parseHelper FilePath
"parsePattern" Parser (Located (Pat GhcPs))
p
  where
    p :: Parser (Located (Pat GhcPs))
p DynFlags
flags FilePath
fp FilePath
str = (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> (Anns, Located (Pat GhcPs)) -> (Anns, Located (Pat GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located (Pat GhcPs) -> Located (Pat GhcPs)
forall (p :: Pass). LPat (GhcPass p) -> Located (Pat (GhcPass p))
dLPatUnsafe ((Anns, Located (Pat GhcPs)) -> (Anns, Located (Pat GhcPs)))
-> Either ErrorMessages (Anns, Located (Pat GhcPs))
-> Either ErrorMessages (Anns, Located (Pat GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (LPat GhcPs)
Parsers.parsePattern DynFlags
flags FilePath
fp FilePath
str

-- | Parse a 'Stmt'.
parseStmt :: String -> IO AnnotatedStmt
parseStmt :: FilePath -> IO AnnotatedStmt
parseStmt = FilePath
-> Parser (ExprLStmt GhcPs) -> FilePath -> IO AnnotatedStmt
forall a. FilePath -> Parser a -> FilePath -> IO (Annotated a)
parseHelper FilePath
"parseStmt" Parser (ExprLStmt GhcPs)
Parsers.parseStmt

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

parseHelper :: FilePath -> Parsers.Parser a -> String -> IO (Annotated a)
parseHelper :: FilePath -> Parser a -> FilePath -> IO (Annotated a)
parseHelper FilePath
fp Parser a
parser FilePath
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
$ (DynFlags -> IO (Annotated a)) -> IO (IO (Annotated a))
forall a. (DynFlags -> a) -> IO a
Parsers.withDynFlags ((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 FilePath
fp FilePath
str of
#if __GLASGOW_HASKELL__ < 810
    Left (_, msg) -> throwIO $ ErrorCall msg
#else
    Left ErrorMessages
errBag -> do
      DynFlags -> ErrorMessages -> IO ()
printBagOfErrors DynFlags
dflags ErrorMessages
errBag
      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
$ FilePath -> ErrorCall
ErrorCall FilePath
"parse failed"
#endif
    Right (Anns
anns, a
x) -> Annotated a -> IO (Annotated 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 -> Anns -> Int -> Annotated a
forall ast. ast -> Anns -> Int -> Annotated ast
unsafeMkA a
x Anns
anns Int
0

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

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

cloneT :: (Data a, Typeable a, Monad m) => a -> TransformT m a
cloneT :: a -> TransformT m a
cloneT a
e = TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT TransformT m Anns -> (Anns -> TransformT m a) -> TransformT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Anns -> a -> TransformT m a) -> a -> Anns -> TransformT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Anns -> a -> TransformT m a
forall a (m :: * -> *).
(Data a, Monad m) =>
Anns -> a -> TransformT m a
graftT a
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)
  => (KeywordId -> Bool)        -- transfer Anns matching predicate
  -> Located a                  -- from
  -> Located b                  -- to
  -> TransformT m ()
transferEntryAnnsT :: (KeywordId -> Bool) -> Located a -> Located b -> TransformT m ()
transferEntryAnnsT KeywordId -> Bool
p Located a
a Located b
b = do
  Located a -> Located b -> TransformT m ()
forall a b (m :: * -> *).
(HasCallStack, Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
transferEntryDPT Located a
a Located b
b
  (KeywordId -> Bool) -> Located a -> Located b -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(KeywordId -> Bool) -> Located a -> Located b -> TransformT m ()
transferAnnsT KeywordId -> Bool
p Located a
a Located b
b

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

tryTransferEntryDPT
  :: (Data a, Data b, Monad m)
  => Located a -> Located b -> TransformT m ()
tryTransferEntryDPT :: Located a -> Located b -> TransformT m ()
tryTransferEntryDPT Located a
a Located b
b = (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT ((Anns -> Anns) -> TransformT m ())
-> (Anns -> Anns) -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ \Anns
anns ->
  if AnnKey -> Anns -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns
    then Located a -> Located b -> Anns -> Anns
forall a b.
(HasCallStack, Data a, Data b) =>
Located a -> Located b -> Anns -> Anns
transferEntryDP Located a
a Located b
b Anns
anns
    else Anns
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 :: Located a -> Located b -> Anns -> Anns
transferEntryDP Located a
a Located b
b Anns
anns = Located b -> DeltaPos -> Anns -> Anns
forall a. Data a => Located a -> DeltaPos -> Anns -> Anns
setEntryDP Located b
b DeltaPos
dp Anns
anns'
  where
    maybeAnns :: Maybe (Anns, DeltaPos)
maybeAnns = do -- Maybe monad
      Annotation
anA <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns
      let anB :: Annotation
anB = Annotation -> AnnKey -> Anns -> Annotation
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Annotation
annNone (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) Anns
anns
          anB' :: Annotation
anB' = Annotation
anB { annEntryDelta :: DeltaPos
annEntryDelta = (Int, Int) -> DeltaPos
DP (Int
0,Int
0) }
      (Anns, DeltaPos) -> Maybe (Anns, DeltaPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) Annotation
anB' Anns
anns, Annotation -> DeltaPos
annLeadingCommentEntryDelta Annotation
anA)
    (Anns
anns',DeltaPos
dp) = (Anns, DeltaPos) -> Maybe (Anns, DeltaPos) -> (Anns, DeltaPos)
forall a. a -> Maybe a -> a
fromMaybe
                  (FilePath -> (Anns, DeltaPos)
forall a. HasCallStack => FilePath -> a
error (FilePath -> (Anns, DeltaPos)) -> FilePath -> (Anns, DeltaPos)
forall a b. (a -> b) -> a -> b
$ FilePath
"transferEntryDP: lookup failed: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnnKey -> FilePath
forall a. Show a => a -> FilePath
show (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a))
                  Maybe (Anns, DeltaPos)
maybeAnns

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

addAllAnns :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
addAllAnns :: Located a -> Located b -> Anns -> Anns
addAllAnns Located a
a Located b
b Anns
anns =
  Anns -> Maybe Anns -> Anns
forall a. a -> Maybe a -> a
fromMaybe
    (FilePath -> Anns
forall a. HasCallStack => FilePath -> a
error (FilePath -> Anns) -> FilePath -> Anns
forall a b. (a -> b) -> a -> b
$ FilePath
"addAllAnns: lookup failed: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnnKey -> FilePath
forall a. Show a => a -> FilePath
show (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a)
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" or " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnnKey -> FilePath
forall a. Show a => a -> FilePath
show (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b))
    (Maybe Anns -> Anns) -> Maybe Anns -> Anns
forall a b. (a -> b) -> a -> b
$ do Annotation
ann <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns
         case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) Anns
anns of
           Just Annotation
ann' -> Anns -> Maybe Anns
forall (m :: * -> *) a. Monad m => a -> m a
return (Anns -> Maybe Anns) -> Anns -> Maybe Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) (Annotation
ann Annotation -> Annotation -> Annotation
`annAdd` Annotation
ann') Anns
anns
           Maybe Annotation
Nothing -> Anns -> Maybe Anns
forall (m :: * -> *) a. Monad m => a -> m a
return (Anns -> Maybe Anns) -> Anns -> Maybe Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) Annotation
ann Anns
anns
  where annAdd :: Annotation -> Annotation -> Annotation
annAdd Annotation
ann Annotation
ann' = Annotation
ann'
          { annEntryDelta :: DeltaPos
annEntryDelta = Annotation -> DeltaPos
annEntryDelta Annotation
ann
          , annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = ([(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
(++) ([(Comment, DeltaPos)]
 -> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)])
-> (Annotation -> [(Comment, DeltaPos)])
-> Annotation
-> Annotation
-> [(Comment, DeltaPos)]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Annotation -> [(Comment, DeltaPos)]
annPriorComments) Annotation
ann Annotation
ann'
          , annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = ([(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
(++) ([(Comment, DeltaPos)]
 -> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)])
-> (Annotation -> [(Comment, DeltaPos)])
-> Annotation
-> Annotation
-> [(Comment, DeltaPos)]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Annotation -> [(Comment, DeltaPos)]
annFollowingComments) Annotation
ann Annotation
ann'
          , annsDP :: [(KeywordId, DeltaPos)]
annsDP = ([(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
(++) ([(KeywordId, DeltaPos)]
 -> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)])
-> (Annotation -> [(KeywordId, DeltaPos)])
-> Annotation
-> Annotation
-> [(KeywordId, DeltaPos)]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Annotation -> [(KeywordId, DeltaPos)]
annsDP) Annotation
ann Annotation
ann'
          }

isComma :: KeywordId -> Bool
isComma :: KeywordId -> Bool
isComma (G AnnKeywordId
AnnComma) = Bool
True
isComma KeywordId
_ = Bool
False

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

isCommentAnnotation :: Annotation -> Bool
isCommentAnnotation :: Annotation -> Bool
isCommentAnnotation Ann{[(Comment, DeltaPos)]
[(KeywordId, DeltaPos)]
Maybe [SrcSpan]
Maybe AnnKey
DeltaPos
annSortKey :: Annotation -> Maybe [SrcSpan]
annCapturedSpan :: Annotation -> Maybe AnnKey
annCapturedSpan :: Maybe AnnKey
annSortKey :: Maybe [SrcSpan]
annsDP :: [(KeywordId, DeltaPos)]
annFollowingComments :: [(Comment, DeltaPos)]
annPriorComments :: [(Comment, DeltaPos)]
annEntryDelta :: DeltaPos
annsDP :: Annotation -> [(KeywordId, DeltaPos)]
annFollowingComments :: Annotation -> [(Comment, DeltaPos)]
annPriorComments :: Annotation -> [(Comment, DeltaPos)]
annEntryDelta :: Annotation -> DeltaPos
..} =
  (Bool -> Bool
not (Bool -> Bool)
-> ([(Comment, DeltaPos)] -> Bool) -> [(Comment, DeltaPos)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Comment, DeltaPos)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Comment, DeltaPos)] -> Bool) -> [(Comment, DeltaPos)] -> Bool
forall a b. (a -> b) -> a -> b
$ [(Comment, DeltaPos)]
annPriorComments)
  Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool)
-> ([(Comment, DeltaPos)] -> Bool) -> [(Comment, DeltaPos)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Comment, DeltaPos)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Comment, DeltaPos)] -> Bool) -> [(Comment, DeltaPos)] -> Bool
forall a b. (a -> b) -> a -> b
$ [(Comment, DeltaPos)]
annFollowingComments)
  Bool -> Bool -> Bool
|| ((KeywordId, DeltaPos) -> Bool) -> [(KeywordId, DeltaPos)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (KeywordId -> Bool
isCommentKeyword (KeywordId -> Bool)
-> ((KeywordId, DeltaPos) -> KeywordId)
-> (KeywordId, DeltaPos)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeywordId, DeltaPos) -> KeywordId
forall a b. (a, b) -> a
fst) [(KeywordId, DeltaPos)]
annsDP

hasComments :: (Data a, Monad m) => Located a -> TransformT m Bool
hasComments :: Located a -> TransformT m Bool
hasComments Located a
e = do
  Anns
anns <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  let b :: Maybe Bool
b = Annotation -> Bool
isCommentAnnotation (Annotation -> Bool) -> Maybe Annotation -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
e) Anns
anns
  Bool -> TransformT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> TransformT m Bool) -> Bool -> TransformT m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
b

transferAnnsT
  :: (Data a, Data b, Monad m)
  => (KeywordId -> Bool)        -- transfer Anns matching predicate
  -> Located a                  -- from
  -> Located b                  -- to
  -> TransformT m ()
transferAnnsT :: (KeywordId -> Bool) -> Located a -> Located b -> TransformT m ()
transferAnnsT KeywordId -> Bool
p Located a
a Located b
b = (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
f
  where
    bKey :: AnnKey
bKey = Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b
    f :: Anns -> Anns
f Anns
anns = Anns -> Maybe Anns -> Anns
forall a. a -> Maybe a -> a
fromMaybe Anns
anns (Maybe Anns -> Anns) -> Maybe Anns -> Anns
forall a b. (a -> b) -> a -> b
$ do
      Annotation
anA <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns
      Annotation
anB <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AnnKey
bKey Anns
anns
      let anB' :: Annotation
anB' = Annotation
anB { annsDP :: [(KeywordId, DeltaPos)]
annsDP = Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
anB [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. (a -> Bool) -> [a] -> [a]
filter (KeywordId -> Bool
p (KeywordId -> Bool)
-> ((KeywordId, DeltaPos) -> KeywordId)
-> (KeywordId, DeltaPos)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeywordId, DeltaPos) -> KeywordId
forall a b. (a, b) -> a
fst) (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
anA) }
      Anns -> Maybe Anns
forall (m :: * -> *) a. Monad m => a -> m a
return (Anns -> Maybe Anns) -> Anns -> Maybe Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AnnKey
bKey Annotation
anB' Anns
anns

-- | 'Transform' monad version of 'setEntryDP',
--   which sets the entry 'DeltaPos' for an annotation.
setEntryDPT
  :: (Data a, Monad m)
  => Located a -> DeltaPos -> TransformT m ()
setEntryDPT :: Located a -> DeltaPos -> TransformT m ()
setEntryDPT Located a
ast DeltaPos
dp = do
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (Located a -> DeltaPos -> Anns -> Anns
forall a. Data a => Located a -> DeltaPos -> Anns -> Anns
setEntryDP Located a
ast DeltaPos
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 :: Located a -> DeltaPos -> Anns -> Anns
setEntryDP Located a
x DeltaPos
dp Anns
anns = (Maybe Annotation -> Maybe Annotation) -> AnnKey -> Anns -> Anns
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Annotation -> Maybe Annotation
forall a. a -> Maybe a
Just (Annotation -> Maybe Annotation)
-> (Maybe Annotation -> Annotation)
-> Maybe Annotation
-> Maybe Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Annotation
f (Annotation -> Annotation)
-> (Maybe Annotation -> Annotation)
-> Maybe Annotation
-> Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Maybe Annotation -> Annotation
forall a. a -> Maybe a -> a
fromMaybe Annotation
annNone) AnnKey
k Anns
anns
  where
    k :: AnnKey
k = Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
x
    f :: Annotation -> Annotation
f Annotation
ann = case Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
ann of
              []       -> Annotation
ann { annEntryDelta :: DeltaPos
annEntryDelta = DeltaPos
dp }
              (Comment
c,DeltaPos
_):[(Comment, DeltaPos)]
cs -> Annotation
ann { annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = (Comment
c,DeltaPos
dp)(Comment, DeltaPos)
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. a -> [a] -> [a]
:[(Comment, DeltaPos)]
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 :: FixityEnv -> String -> IO ()
debugParse :: FixityEnv -> FilePath -> IO ()
debugParse FixityEnv
fixityEnv FilePath
s = do
  FilePath -> FilePath -> IO ()
writeFile FilePath
"debug.txt" FilePath
s
  ParseResult ParsedSource
r <- FilePath -> IO (ParseResult ParsedSource)
parseModule FilePath
"debug.txt"
  case ParseResult ParsedSource
r of
    Left ErrorMessages
_ -> FilePath -> IO ()
putStrLn FilePath
"parse failed"
    Right (Anns
anns, ParsedSource
modl) -> do
      let m :: AnnotatedModule
m = ParsedSource -> Anns -> Int -> AnnotatedModule
forall ast. ast -> Anns -> Int -> Annotated ast
unsafeMkA ParsedSource
modl Anns
anns Int
0
      FilePath -> IO ()
putStrLn FilePath
"parseModule"
      AnnotatedModule -> IO ()
forall a. Annotate a => Annotated (Located 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 =
      FilePath
-> (LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs))
-> AnnotatedModule
-> IO AnnotatedModule
forall a b.
(Annotate a, Typeable b) =>
FilePath
-> (b -> TransformT IO b)
-> Annotated (Located a)
-> IO (Annotated (Located a))
run FilePath
"fixOneExpr D.def" (FixityEnv -> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad 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
>=> FilePath
-> (Located (Pat GhcPs) -> TransformT IO (Located (Pat GhcPs)))
-> AnnotatedModule
-> IO AnnotatedModule
forall a b.
(Annotate a, Typeable b) =>
FilePath
-> (b -> TransformT IO b)
-> Annotated (Located a)
-> IO (Annotated (Located a))
run FilePath
"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
>=> FilePath
-> (LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs))
-> AnnotatedModule
-> IO AnnotatedModule
forall a b.
(Annotate a, Typeable b) =>
FilePath
-> (b -> TransformT IO b)
-> Annotated (Located a)
-> IO (Annotated (Located a))
run FilePath
"fixOneEntryExpr" LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad 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
>=> FilePath
-> (Located (Pat GhcPs) -> TransformT IO (Located (Pat GhcPs)))
-> AnnotatedModule
-> IO AnnotatedModule
forall a b.
(Annotate a, Typeable b) =>
FilePath
-> (b -> TransformT IO b)
-> Annotated (Located a)
-> IO (Annotated (Located a))
run FilePath
"fixOneEntryPat" Located (Pat GhcPs) -> TransformT IO (Located (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat

    run :: FilePath
-> (b -> TransformT IO b)
-> Annotated (Located a)
-> IO (Annotated (Located a))
run FilePath
wat b -> TransformT IO b
f Annotated (Located a)
m = do
      FilePath -> IO ()
putStrLn FilePath
wat
      Annotated (Located a)
m' <- Annotated (Located a)
-> (Located a -> TransformT IO (Located a))
-> IO (Annotated (Located a))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated (Located 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 (Located a) -> IO ()
forall a. Annotate a => Annotated (Located a) -> IO ()
debugDump Annotated (Located a)
m'
      Annotated (Located a) -> IO (Annotated (Located a))
forall (m :: * -> *) a. Monad m => a -> m a
return Annotated (Located a)
m'