summaryrefslogtreecommitdiff
path: root/utils
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2022-04-10 18:35:43 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-10-17 19:20:40 -0400
commitd80ad2f40f2092f14402351a6a3cb944039a57df (patch)
treef551d41cfea2c1b8c2b4b34d78b2e3c66c528c54 /utils
parent8c72411d9504963069fb1ae736a2470cb9ae1250 (diff)
downloadhaskell-d80ad2f40f2092f14402351a6a3cb944039a57df.tar.gz
Update the check-exact infrastructure to match ghc-exactprint
GHC tests the exact print annotations using the contents of utils/check-exact. The same functionality is provided via https://github.com/alanz/ghc-exactprint The latter was updated to ensure it works with all of the files on hackage when 9.2 was released, as well as updated to ensure users of the library could work properly (apply-refact, retrie, etc). This commit brings the changes from ghc-exactprint into GHC/utils/check-exact, adapting for the changes to master. Once it lands, it will form the basis for the 9.4 version of ghc-exactprint. See also discussion around this process at #21355
Diffstat (limited to 'utils')
-rw-r--r--utils/check-exact/.ghci2
-rw-r--r--utils/check-exact/ExactPrint.hs5392
-rw-r--r--utils/check-exact/Lookup.hs215
-rw-r--r--utils/check-exact/Main.hs145
-rw-r--r--utils/check-exact/Orphans.hs92
-rw-r--r--utils/check-exact/Parsers.hs14
-rw-r--r--utils/check-exact/Preprocess.hs54
-rw-r--r--utils/check-exact/Transform.hs598
-rw-r--r--utils/check-exact/Types.hs142
-rw-r--r--utils/check-exact/Utils.hs258
-rw-r--r--utils/check-exact/check-exact.cabal1
11 files changed, 3818 insertions, 3095 deletions
diff --git a/utils/check-exact/.ghci b/utils/check-exact/.ghci
index 43ff67a50e..f1c0f9d503 100644
--- a/utils/check-exact/.ghci
+++ b/utils/check-exact/.ghci
@@ -1,3 +1,3 @@
:set -package ghc
-:set -i./src
:set -Wall
+-- :set -fobject-code
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 25ea557a27..cfa50a9e3b 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -10,6 +10,7 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BlockArguments #-}
@@ -19,7 +20,14 @@ module ExactPrint
(
ExactPrint(..)
, exactPrint
- -- , exactPrintWithOptions
+ , exactPrintWithOptions
+ , makeDeltaAst
+
+ -- * Configuration
+ , EPOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint, epUpdateAnchors)
+ , stringOptions
+ , epOptions
+ , deltaOptions
) where
import GHC
@@ -27,6 +35,7 @@ import GHC.Core.Coercion.Axiom (Role(..))
import GHC.Data.Bag
import qualified GHC.Data.BooleanFormula as BF
import GHC.Data.FastString
+import GHC.TypeLits
import GHC.Types.Basic hiding (EP)
import GHC.Types.Fixity
import GHC.Types.ForeignCall
@@ -38,59 +47,71 @@ import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Unit.Module.Warnings
import GHC.Utils.Misc
import GHC.Utils.Panic
-import GHC.TypeLits
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad.Identity
+import qualified Control.Monad.Reader as Reader
import Control.Monad.RWS
import Data.Data ( Data )
+import Data.Dynamic
import Data.Foldable
+import Data.Functor.Const
+import qualified Data.Set as Set
import Data.Typeable
-import Data.List ( partition, sortBy)
-import Data.List.NonEmpty ( NonEmpty )
-import Data.Maybe ( isJust )
+import Data.List ( partition, sort, sortBy)
+import Data.Maybe ( isJust, mapMaybe )
import Data.Void
import Lookup
import Utils
import Types
-import Data.Ord
-
--- import Debug.Trace
-- ---------------------------------------------------------------------
-exactPrint :: ExactPrint ast => Located ast -> String
-exactPrint ast = runIdentity (runEP stringOptions (markAnnotated ast))
+exactPrint :: ExactPrint ast => ast -> String
+exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast))
-type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a
-type EPP a = EP String Identity a
+-- | The additional option to specify the rigidity and printing
+-- configuration.
+exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m)
+ => EPOptions m b
+ -> ast
+ -> m (ast, b)
+exactPrintWithOptions r ast =
+ runEP r (markAnnotated ast)
-runEP :: PrintOptions Identity String
- -> Annotated () -> Identity String
-runEP epReader action =
- fmap (output . snd) .
- (\next -> execRWST next epReader defaultEPState)
- . xx $ action
+-- | Transform concrete annotations into relative annotations which
+-- are more useful when transforming an AST. This corresponds to the
+-- earlier 'relativiseApiAnns'.
+makeDeltaAst :: ExactPrint ast => ast -> ast
+makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast))
-xx :: Annotated () -> EP String Identity ()
--- xx :: Annotated() -> RWST (PrintOptions m w) (EPWriter w) EPState m ()
-xx = id
+------------------------------------------------------
+
+type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a
+
+runEP :: (Monad m)
+ => EPOptions m w
+ -> EP w m a -> m (a, w)
+runEP epReader action = do
+ (ast, w) <- evalRWST action epReader defaultEPState
+ return (ast, output w)
-- ---------------------------------------------------------------------
defaultEPState :: EPState
defaultEPState = EPState
{ epPos = (1,1)
- , dLHS = 0
+ , dLHS = 1
, pMarkLayout = False
- , pLHS = 0
+ , pLHS = 1
, dMarkLayout = False
, dPriorEndPosition = (1,1)
, uAnchorSpan = badRealSrcSpan
, uExtraDP = Nothing
, epComments = []
+ , epCommentsApplied = []
}
@@ -99,34 +120,40 @@ defaultEPState = EPState
-- | The R part of RWS. The environment. Updated via 'local' as we
-- enter a new AST element, having a different anchor point.
-data PrintOptions m a = PrintOptions
+data EPOptions m a = EPOptions
{
- epAnn :: !Annotation
- , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a
+ epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a
, epTokenPrint :: String -> m a
, epWhitespacePrint :: String -> m a
, epRigidity :: Rigidity
+ , epUpdateAnchors :: Bool
}
--- | Helper to create a 'PrintOptions'
-printOptions ::
+-- | Helper to create a 'EPOptions'
+epOptions ::
(forall ast . Data ast => GHC.Located ast -> a -> m a)
-> (String -> m a)
-> (String -> m a)
-> Rigidity
- -> PrintOptions m a
-printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions
+ -> Bool
+ -> EPOptions m a
+epOptions astPrint tokenPrint wsPrint rigidity delta = EPOptions
{
- epAnn = annNone
- , epAstPrint = astPrint
+ epAstPrint = astPrint
, epWhitespacePrint = wsPrint
, epTokenPrint = tokenPrint
, epRigidity = rigidity
+ , epUpdateAnchors = delta
}
-- | Options which can be used to print as a normal String.
-stringOptions :: PrintOptions Identity String
-stringOptions = printOptions (\_ b -> return b) return return NormalLayout
+stringOptions :: EPOptions Identity String
+stringOptions = epOptions (\_ b -> return b) return return NormalLayout False
+
+-- | Options which can be used to simply update the AST to be in delta
+-- form, without generating output
+deltaOptions :: EPOptions Identity ()
+deltaOptions = epOptions (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ()) NormalLayout True
data EPWriter a = EPWriter
{ output :: !a }
@@ -158,6 +185,7 @@ data EPState = EPState
-- Shared
, epComments :: ![Comment]
+ , epCommentsApplied :: ![[Comment]]
}
-- ---------------------------------------------------------------------
@@ -168,73 +196,123 @@ class HasEntry ast where
-- ---------------------------------------------------------------------
--- type Annotated = FreeT AnnotationF Identity
-type Annotated a = EP String Identity a
-
--- ---------------------------------------------------------------------
-
-- | Key entry point. Switches to an independent AST element with its
-- own annotation, calculating new offsets, etc
-markAnnotated :: ExactPrint a => a -> Annotated ()
+markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a
markAnnotated a = enterAnn (getAnnotationEntry a) a
-data Entry = Entry Anchor EpAnnComments
+-- | For HsModule, because we do not have a proper SrcSpan, we must
+-- indicate to flush trailing comments when done.
+data FlushComments = FlushComments
+ | NoFlushComments
+ deriving (Eq, Show)
+
+-- | For GenLocated SrcSpan, we construct an entry location but cannot update it.
+data CanUpdateAnchor = CanUpdateAnchor
+ | CanUpdateAnchorOnly
+ | NoCanUpdateAnchor
+ deriving (Eq, Show)
+
+data Entry = Entry Anchor EpAnnComments FlushComments CanUpdateAnchor
| NoEntryVal
-instance (HasEntry (EpAnn an)) => HasEntry (SrcSpanAnn' (EpAnn an)) where
- fromAnn (SrcSpanAnn EpAnnNotUsed ss) = Entry (spanAsAnchor ss) emptyComments
+-- | For flagging whether to capture comments in an EpaDelta or not
+data CaptureComments = CaptureComments
+ | NoCaptureComments
+
+mkEntry :: Anchor -> EpAnnComments -> Entry
+mkEntry anc cs = Entry anc cs NoFlushComments CanUpdateAnchor
+
+instance HasEntry (SrcSpanAnn' (EpAnn an)) where
+ fromAnn (SrcSpanAnn EpAnnNotUsed ss) = mkEntry (spanAsAnchor ss) emptyComments
fromAnn (SrcSpanAnn an _) = fromAnn an
instance HasEntry (EpAnn a) where
- fromAnn (EpAnn anchor _ cs) = Entry anchor cs
+ fromAnn (EpAnn anchor _ cs) = mkEntry anchor cs
fromAnn EpAnnNotUsed = NoEntryVal
-- ---------------------------------------------------------------------
+fromAnn' :: (HasEntry a) => a -> Entry
+fromAnn' an = case fromAnn an of
+ NoEntryVal -> NoEntryVal
+ Entry a c _ u -> Entry a c' FlushComments u
+ where
+ c' = case c of
+ EpaComments cs -> EpaCommentsBalanced (filterEofComment False cs) (filterEofComment True cs)
+ EpaCommentsBalanced cp ct -> EpaCommentsBalanced cp ct
+
+-- ---------------------------------------------------------------------
+
astId :: (Typeable a) => a -> String
astId a = show (typeOf a)
+cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a]
+cua CanUpdateAnchor f = f
+cua CanUpdateAnchorOnly _ = return []
+cua NoCanUpdateAnchor _ = return []
+
-- | "Enter" an annotation, by using the associated 'anchor' field as
-- the new reference point for calculating all DeltaPos positions.
--
-- This is combination of the ghc=exactprint Delta.withAST and
-- Print.exactPC functions and effectively does the delta processing
-- immediately followed by the print processing. JIT ghc-exactprint.
-enterAnn :: (ExactPrint a) => Entry -> a -> Annotated ()
+enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
enterAnn NoEntryVal a = do
p <- getPosP
- debugM $ "enterAnn:NO ANN:(p,a) =" ++ show (p, astId a) ++ " starting"
- exact a
- debugM $ "enterAnn:NO ANN:p =" ++ show (p, astId a) ++ " done"
-enterAnn (Entry anchor' cs) a = do
+ debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a)
+ r <- exact a
+ debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)
+ return r
+enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
p <- getPosP
- debugM $ "enterAnn:(p,a) =" ++ show (p, astId a) ++ " starting"
+ debugM $ "enterAnn:starting:(p,a) =" ++ show (p, astId a)
+ -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs)
let curAnchor = anchor anchor' -- As a base for the current AST element
debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)
+ case canUpdateAnchor of
+ CanUpdateAnchor -> pushAppliedComments
+ _ -> return ()
addCommentsA (priorComments cs)
+ debugM $ "enterAnn:Added comments"
printComments curAnchor
+ priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop
-- -------------------------
case anchor_op anchor' of
MovedAnchor dp -> do
debugM $ "enterAnn: MovedAnchor:" ++ show dp
-- Set the original anchor as prior end, so the rest of this AST
-- fragment has a reference
- -- BUT: this means the entry DP can be calculated incorrectly too,
- -- for immediately nested items.
setPriorEndNoLayoutD (ss2pos curAnchor)
_ -> do
return ()
-- -------------------------
- setAnchorU curAnchor
+ if ((fst $ fst $ rs2range curAnchor) >= 0)
+ then
+ setAnchorU curAnchor
+ else
+ debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor)
+ -- -------------------------------------------------------------------
+ -- Make sure the running dPriorEndPosition gets updated according to
+ -- the change in the current anchor.
+
+ -- Compute the distance from dPriorEndPosition to the start of the new span.
+
+ -- While processing in the context of the prior anchor, we choose to
+ -- enter a new Anchor, which has a defined position relative to the
+ -- prior anchor, even if we do not actively output anything at that
+ -- point.
+ -- Is this edp?
+
-- -------------------------------------------------------------------
-- The first part corresponds to the delta phase, so should only use
- -- delta phase variables
- -- -----------------------------------
+ -- delta phase variables -----------------------------------
-- Calculate offset required to get to the start of the SrcSPan
- off <- gets dLHS
+ off <- getLayoutOffsetD
let spanStart = ss2pos curAnchor
priorEndAfterComments <- getPriorEndD
- let edp' = adjustDeltaForOffset 0
+ let edp' = adjustDeltaForOffset
-- Use the propagated offset if one is set
-- Note that we need to use the new offset if it has
-- changed.
@@ -254,7 +332,7 @@ enterAnn (Entry anchor' cs) a = do
-- list entry values to be DP (1,0)
Just (Anchor r _) -> dp
where
- dp = adjustDeltaForOffset 0
+ dp = adjustDeltaForOffset
off (ss2delta priorEndAfterComments r)
when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp)
-- ---------------------------------------------
@@ -265,23 +343,43 @@ enterAnn (Entry anchor' cs) a = do
debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor)
debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)
+ p0 <- getPosP
+ d <- getPriorEndD
+ debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d)
-- end of delta phase processing
-- -------------------------------------------------------------------
-- start of print phase processing
- let
- st = annNone { annEntryDelta = edp }
- withOffset st (advance edp >> exact a)
+ let mflush = when (flush == FlushComments) $ do
+ debugM $ "flushing comments in enterAnn:" ++ showAst cs
+ flushComments (getFollowingComments cs ++ filterEofComment True (priorComments cs))
+
+ advance edp
+ a' <- exact a
+ mflush
+
+ -- end of sub-Anchor processing, start of tail end processing
+ postCs <- cua canUpdateAnchor takeAppliedCommentsPop
+ when (flush == NoFlushComments) $ do
+ when ((getFollowingComments cs) /= []) $ do
+ debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
+ mapM_ printOneComment (map tokComment $ getFollowingComments cs)
+ debugM $ "ending trailing comments"
- when ((getFollowingComments cs) /= []) $ do
- debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
- mapM_ printOneComment (map tokComment $ getFollowingComments cs)
- debugM $ "ending trailing comments"
+ let newAchor = anchor' { anchor_op = MovedAnchor edp }
+ let r = case canUpdateAnchor of
+ CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) [])
+ CanUpdateAnchorOnly -> setAnnotationAnchor a' newAchor emptyComments
+ NoCanUpdateAnchor -> a'
+ -- debugM $ "calling setAnnotationAnchor:(curAnchor, newAchor,priorCs,postCs)=" ++ showAst (show (rs2range curAnchor), newAchor, priorCs, postCs)
+ -- debugM $ "calling setAnnotationAnchor:(newAchor,postCs)=" ++ showAst (newAchor, postCs)
+ debugM $ "enterAnn:done:(p,a) =" ++ show (p0, astId a')
+ return r
-- ---------------------------------------------------------------------
-addCommentsA :: [LEpaComment] -> EPP ()
+addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
addCommentsA csNew = addComments (map tokComment csNew)
{-
@@ -300,61 +398,67 @@ By definition it is the current anchor, so work against that. And that
also means that the first entry comment that has moved should not have
a line offset.
-}
-addComments :: [Comment] -> EPP ()
+addComments :: (Monad m, Monoid w) => [Comment] -> EP w m ()
addComments csNew = do
- debugM $ "addComments:" ++ show csNew
+ -- debugM $ "addComments:" ++ show csNew
cs <- getUnallocatedComments
- -- Must compare without span filenames, for CPP injected comments with fake filename
- let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
- -- AZ:TODO: sortedlist?
- putUnallocatedComments (sortBy cmp $ csNew ++ cs)
+
+ putUnallocatedComments (sort (cs ++ csNew))
-- ---------------------------------------------------------------------
-- | Just before we print out the EOF comments, flush the remaining
-- ones in the state.
-flushComments :: EPP ()
-flushComments = do
+flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
+flushComments trailing = do
+ addCommentsA (filterEofComment False trailing)
cs <- getUnallocatedComments
- -- Must compare without span filenames, for CPP injected comments with fake filename
- let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
- mapM_ printOneComment (sortBy cmp cs)
+ debugM $ "flushing comments starting"
+ mapM_ printOneComment (sortComments cs)
+ debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing)
+ debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing)
+ mapM_ printOneComment (map tokComment (filterEofComment True trailing))
+ debugM $ "flushing comments done"
+
+filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment]
+filterEofComment keep cs = fixCs cs
+ where
+ notEof com = case com of
+ L _ (GHC.EpaComment (EpaEofComment) _) -> keep
+ _ -> not keep
+ fixCs c = filter notEof c
-- ---------------------------------------------------------------------
-- |In order to interleave annotations into the stream, we turn them into
--- comments.
-annotationsToComments :: [AddEpAnn] -> [AnnKeywordId] -> EPP ()
-annotationsToComments ans kws = do
- let
- getSpans _ [] = []
- getSpans k1 (AddEpAnn k2 ss:as)
- | k1 == k2 = ss : getSpans k1 as
- | otherwise = getSpans k1 as
- doOne :: AnnKeywordId -> EPP [Comment]
- doOne kw = do
- let sps =getSpans kw ans
- return $ concatMap (mkKWComment kw ) sps
- -- TODO:AZ make sure these are sorted/merged properly when the invariant for
- -- allocateComments is re-established.
- newComments <- mapM doOne kws
- addComments (concat newComments)
+-- comments. They are removed from the annotation to avoid duplication.
+annotationsToComments :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m (EpAnn a)
+annotationsToComments EpAnnNotUsed _ _kws = return EpAnnNotUsed
+annotationsToComments (EpAnn anc a cs) l kws = do
+ let (newComments, newAnns) = go ([],[]) (view l a)
+ addComments newComments
+ return (EpAnn anc (set l (reverse newAnns) a) cs)
+ where
+ keywords = Set.fromList kws
-annotationsToCommentsA :: EpAnn [AddEpAnn] -> [AnnKeywordId] -> EPP ()
-annotationsToCommentsA EpAnnNotUsed _ = return ()
-annotationsToCommentsA an kws = annotationsToComments (anns an) kws
+ go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn])
+ go acc [] = acc
+ go (cs',ans) ((AddEpAnn k ss) : ls)
+ | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls
+ | otherwise = go (cs', (AddEpAnn k ss):ans) ls
-- ---------------------------------------------------------------------
-- Temporary function to simply reproduce the "normal" pretty printer output
-withPpr :: (Outputable a) => a -> Annotated ()
+withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a
withPpr a = do
ss <- getAnchorU
debugM $ "withPpr: ss=" ++ show ss
- printStringAtKw' ss (showPprUnsafe a)
+ printStringAtRs' ss (showPprUnsafe a)
+ return a
-- ---------------------------------------------------------------------
--- Modeled on Outputable
-- | An AST fragment with an annotation must be able to return the
-- requirements for nesting another one, captured in an 'Entry', and
@@ -363,331 +467,772 @@ withPpr a = do
-- 'ppr'.
class (Typeable a) => ExactPrint a where
getAnnotationEntry :: a -> Entry
- exact :: a -> Annotated ()
+ setAnnotationAnchor :: a -> Anchor -> EpAnnComments -> a
+ exact :: (Monad m, Monoid w) => a -> EP w m a
-- ---------------------------------------------------------------------
+-- Start of utility functions
+-- ---------------------------------------------------------------------
--- | Bare Located elements are simply stripped off without further
--- processing.
-instance (ExactPrint a) => ExactPrint (Located a) where
- getAnnotationEntry (L l _) = Entry (spanAsAnchor l) emptyComments
- exact (L _ a) = markAnnotated a
-
-instance (ExactPrint a) => ExactPrint (LocatedA a) where
- getAnnotationEntry = entryFromLocatedA
- exact (L la a) = do
- debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la)
- markAnnotated a
- markALocatedA (ann la)
+printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m ()
+printSourceText (NoSourceText) txt = printStringAdvance txt >> return ()
+printSourceText (SourceText txt) _ = printStringAdvance txt >> return ()
-instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where
- getAnnotationEntry = entryFromLocatedA
- exact (L _ a) = markAnnotated a
+-- ---------------------------------------------------------------------
-instance (ExactPrint a) => ExactPrint [a] where
- getAnnotationEntry = const NoEntryVal
- exact ls = mapM_ markAnnotated ls
+printStringAtSs :: (Monad m, Monoid w) => SrcSpan -> String -> EP w m ()
+printStringAtSs ss str = printStringAtRs (realSrcSpan ss) str >> return ()
-instance (ExactPrint a) => ExactPrint (NonEmpty a) where
- getAnnotationEntry = const NoEntryVal
- exact ls = mapM_ markAnnotated ls
+printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation
+printStringAtRs pa str = printStringAtRsC CaptureComments pa str
-instance (ExactPrint a) => ExactPrint (Maybe a) where
- getAnnotationEntry = const NoEntryVal
- exact Nothing = return ()
- exact (Just a) = markAnnotated a
+printStringAtRsC :: (Monad m, Monoid w)
+ => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation
+printStringAtRsC capture pa str = do
+ debugM $ "printStringAtRsC: pa=" ++ showAst pa
+ printComments pa
+ pe <- getPriorEndD
+ debugM $ "printStringAtRsC:pe=" ++ show pe
+ let p = ss2delta pe pa
+ p' <- adjustDeltaForOffsetM p
+ debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p')
+ printStringAtLsDelta p' str
+ setPriorEndASTD True pa
+ cs' <- case capture of
+ CaptureComments -> takeAppliedComments
+ NoCaptureComments -> return []
+ debugM $ "printStringAtRsC:cs'=" ++ show cs'
+ debugM $ "printStringAtRsC:p'=" ++ showAst p'
+ debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' [])
+ debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs'))
+ return (EpaDelta p' (map comment2LEpaComment cs'))
+
+printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m ()
+printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return ()
+
+-- ---------------------------------------------------------------------
+
+printStringAtMLoc' :: (Monad m, Monoid w)
+ => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation)
+printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s
+printStringAtMLoc' Nothing s = do
+ printStringAtLsDelta (SameLine 1) s
+ return (Just (EpaDelta (SameLine 1) []))
+
+printStringAtMLocL :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a)
+printStringAtMLocL EpAnnNotUsed _ _ = return EpAnnNotUsed
+printStringAtMLocL (EpAnn anc an cs) l s = do
+ r <- go (view l an) s
+ return (EpAnn anc (set l r an) cs)
+ where
+ go (Just aa) str = Just <$> printStringAtAA aa str
+ go Nothing str = do
+ printStringAtLsDelta (SameLine 1) str
+ return (Just (EpaDelta (SameLine 1) []))
+
+printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation
+printStringAtAA el str = printStringAtAAC CaptureComments el str
+
+printStringAtAAL :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a EpaLocation -> String -> EP w m (EpAnn a)
+printStringAtAAL EpAnnNotUsed _ _ = return EpAnnNotUsed
+printStringAtAAL (EpAnn anc an cs) l str = do
+ r <- printStringAtAAC CaptureComments (view l an) str
+ return (EpAnn anc (set l r an) cs)
+
+printStringAtAAC :: (Monad m, Monoid w)
+ => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
+printStringAtAAC capture (EpaSpan r) s = printStringAtRsC capture r s
+printStringAtAAC capture (EpaDelta d cs) s = do
+ mapM_ (printOneComment . tokComment) cs
+ pe1 <- getPriorEndD
+ p1 <- getPosP
+ printStringAtLsDelta d s
+ p2 <- getPosP
+ pe2 <- getPriorEndD
+ debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2)
+ setPriorEndASTPD True (pe1,pe2)
+ cs' <- case capture of
+ CaptureComments -> takeAppliedComments
+ NoCaptureComments -> return []
+ debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs')
+ return (EpaDelta d (map comment2LEpaComment cs'))
+
+-- ---------------------------------------------------------------------
+
+markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
+markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return ()
+markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return ()
+
+-- ---------------------------------------------------------------------
+
+markLensMAA :: (Monad m, Monoid w) => EpAnn a -> Lens a (Maybe AddEpAnn) -> EP w m (EpAnn a)
+markLensMAA EpAnnNotUsed _ = return EpAnnNotUsed
+markLensMAA (EpAnn anc a cs) l =
+ case view l a of
+ Nothing -> return (EpAnn anc a cs)
+ Just aa -> do
+ aa' <- markAddEpAnn aa
+ return (EpAnn anc (set l (Just aa') a) cs)
+
+markLensAA :: (Monad m, Monoid w) => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a)
+markLensAA EpAnnNotUsed _ = return EpAnnNotUsed
+markLensAA (EpAnn anc a cs) l = do
+ a' <- markKw (view l a)
+ return (EpAnn anc (set l a' a) cs)
+
+
+markEpAnnLMS :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a)
+markEpAnnLMS an l kw Nothing = markEpAnnL an l kw
+markEpAnnLMS EpAnnNotUsed _ _ _ = return EpAnnNotUsed
+markEpAnnLMS (EpAnn anc a cs) l kw (Just str) = do
+ anns <- mapM go (view l a)
+ return (EpAnn anc (set l anns a) cs)
+ where
+ go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn
+ go (AddEpAnn kw' r)
+ | kw' == kw = do
+ r' <- printStringAtAA r str
+ return (AddEpAnn kw' r')
+ | otherwise = return (AddEpAnn kw' r)
+
+markEpAnnLMS' :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a)
+markEpAnnLMS' an l _kw Nothing = markLensKwA an l
+markEpAnnLMS' EpAnnNotUsed _ _ _ = return EpAnnNotUsed
+markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do
+ anns <- go (view l a)
+ return (EpAnn anc (set l anns a) cs)
+ where
+ go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn
+ go (AddEpAnn kw' r)
+ | kw' == kw = do
+ r' <- printStringAtAA r str
+ return (AddEpAnn kw' r')
+ | otherwise = return (AddEpAnn kw' r)
-- ---------------------------------------------------------------------
--- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'
-instance ExactPrint (HsModule GhcPs) where
- getAnnotationEntry hsmod = fromAnn (hsmodAnn $ hsmodExt hsmod)
+markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
+ => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs)
+markToken (L NoTokenLoc t) = return (L NoTokenLoc t)
+markToken (L (TokenLoc aa) t) = do
+ aa' <- printStringAtAA aa (symbolVal (Proxy @tok))
+ return (L (TokenLoc aa') t)
- exact hsmod@(HsModule (XModulePs EpAnnNotUsed _ _ _) _ _ _ _) = withPpr hsmod
- exact (HsModule (XModulePs an _lo mdeprec mbDoc) mmn mexports imports decls) = do
+markUniToken :: forall m w tok utok. (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok)
+ => LHsUniToken tok utok GhcPs -> EP w m (LHsUniToken tok utok GhcPs)
+markUniToken (L l HsNormalTok) = do
+ (L l' _) <- markToken (L l (HsTok @tok))
+ return (L l' HsNormalTok)
+markUniToken (L l HsUnicodeTok) = do
+ (L l' _) <- markToken (L l (HsTok @utok))
+ return (L l' HsUnicodeTok)
- markAnnotated mbDoc
+-- ---------------------------------------------------------------------
- case mmn of
- Nothing -> return ()
- Just (L ln mn) -> do
- markEpAnn' an am_main AnnModule
- markAnnotated (L ln mn)
+markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs)
+markArrow (HsUnrestrictedArrow arr) = do
+ arr' <- markUniToken arr
+ return (HsUnrestrictedArrow arr')
+markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do
+ pct1' <- markToken pct1
+ arr' <- markUniToken arr
+ return (HsLinearArrow (HsPct1 pct1' arr'))
+markArrow (HsLinearArrow (HsLolly arr)) = do
+ arr' <- markToken arr
+ return (HsLinearArrow (HsLolly arr'))
+markArrow (HsExplicitMult pct t arr) = do
+ pct' <- markToken pct
+ t' <- markAnnotated t
+ arr' <- markUniToken arr
+ return (HsExplicitMult pct' t' arr')
+
+-- ---------------------------------------------------------------------
- -- forM_ mdeprec markLocated
- setLayoutTopLevelP $ markAnnotated mdeprec
+markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma)
+markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}")
- setLayoutTopLevelP $ markAnnotated mexports
+markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma)
+markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
+markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
- debugM $ "HsModule.AnnWhere coming"
- setLayoutTopLevelP $ markEpAnn' an am_main AnnWhere
+markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn])
+markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt)
+markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt)
- markAnnList' False (am_decls $ anns an) $ do
- markTopLevelList imports
- markTopLevelList decls
+markAnnOpen' :: (Monad m, Monoid w)
+ => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation)
+markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt
+markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt
- -- In the weird case of an empty file with comments, make sure
- -- they print
- flushComments
+markAnnOpen'' :: (Monad m, Monoid w)
+ => EpaLocation -> SourceText -> String -> EP w m EpaLocation
+markAnnOpen'' el NoSourceText txt = printStringAtAA el txt
+markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt
-- ---------------------------------------------------------------------
+{-
+data AnnParen
+ = AnnParen {
+ ap_adornment :: ParenType,
+ ap_open :: EpaLocation,
+ ap_close :: EpaLocation
+ } deriving (Data)
+-}
+markOpeningParen, markClosingParen :: (Monad m, Monoid w) => EpAnn AnnParen -> EP w m (EpAnn AnnParen)
+markOpeningParen an = markParen an lfst
+markClosingParen an = markParen an lsnd
+
+markParen :: (Monad m, Monoid w) => EpAnn AnnParen -> (forall a. Lens (a,a) a) -> EP w m (EpAnn AnnParen)
+markParen EpAnnNotUsed _ = return (EpAnnNotUsed)
+markParen (EpAnn anc (AnnParen pt o c) cs) l = do
+ loc' <- markKwA (view l $ kw pt) (view l (o, c))
+ let (o',c') = set l loc' (o,c)
+ return (EpAnn anc (AnnParen pt o' c') cs)
+ where
+ kw AnnParens = (AnnOpenP, AnnCloseP)
+ kw AnnParensHash = (AnnOpenPH, AnnClosePH)
+ kw AnnParensSquare = (AnnOpenS, AnnCloseS)
--- TODO:AZ: do we *need* the following, or can we capture it in the AST?
--- | We can have a list with its own entry point defined. Create a
--- data structure to capture this, for defining an ExactPrint instance
-data AnnotatedList a = AnnotatedList (Maybe Anchor) a
- deriving (Eq,Show)
+-- ---------------------------------------------------------------------
+-- Bare bones Optics
+-- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html
-instance (ExactPrint a) => ExactPrint (AnnotatedList a) where
- getAnnotationEntry (AnnotatedList (Just anc) _) = Entry anc (EpaComments [])
- getAnnotationEntry (AnnotatedList Nothing _) = NoEntryVal
+type Lens a b = forall f . Functor f => (b -> f b) -> (a -> f a)
+type Getting a b = (b -> Const b b) -> (a -> Const b a)
+type ASetter a b = (b -> Identity b) -> (a -> Identity a)
- exact (AnnotatedList an ls) = do
- debugM $ "AnnotatedList:an=" ++ show an
- markAnnotatedWithLayout ls
+view :: MonadReader s m => Getting s a -> m a
+view l = Reader.asks (getConst . l Const)
+{-# INLINE view #-}
+over :: ASetter a b -> (b -> b) -> (a -> a)
+over l f = runIdentity . l (Identity . f)
+{-# INLINE over #-}
--- ---------------------------------------------------------------------
--- Start of utility functions
--- ---------------------------------------------------------------------
+set :: Lens a b -> b -> a -> a
+set lens b = over lens (\_ -> b)
+{-# INLINE set #-}
-printSourceText :: SourceText -> String -> EPP ()
-printSourceText NoSourceText txt = printStringAdvance txt
-printSourceText (SourceText txt) _ = printStringAdvance txt
+{-
+Question: How do I combine lenses?
--- ---------------------------------------------------------------------
+Answer: You compose them, using function composition (Yes, really!)
-printStringAtRs :: RealSrcSpan -> String -> EPP ()
-printStringAtRs ss str = printStringAtKw' ss str
+You can think of the function composition operator as having this type:
-printStringAtSs :: SrcSpan -> String -> EPP ()
-printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str
+(.) :: Lens' a b -> Lens' b c -> Lens' a c
+-}
-- ---------------------------------------------------------------------
+-- Lenses
--- AZ:TODO get rid of this
-printStringAtMkw :: Maybe EpaLocation -> String -> EPP ()
-printStringAtMkw (Just aa) s = printStringAtAA aa s
-printStringAtMkw Nothing s = printStringAtLsDelta (SameLine 1) s
+-- data AnnsModule
+-- = AnnsModule {
+-- am_main :: [AddEpAnn],
+-- am_decls :: AnnList
+-- } deriving (Data, Eq)
-printStringAtAnn :: EpAnn a -> (a -> EpaLocation) -> String -> EPP ()
-printStringAtAnn EpAnnNotUsed _ _ = return ()
-printStringAtAnn (EpAnn _ a _) f str = printStringAtAA (f a) str
+lam_main :: Lens AnnsModule [AddEpAnn]
+lam_main k annsModule = fmap (\newAnns -> annsModule { am_main = newAnns })
+ (k (am_main annsModule))
-printStringAtAA :: EpaLocation -> String -> EPP ()
-printStringAtAA (EpaSpan r) s = printStringAtKw' r s
-printStringAtAA (EpaDelta d cs) s = do
- mapM_ (printOneComment . tokComment) cs
- pe <- getPriorEndD
- p1 <- getPosP
- printStringAtLsDelta d s
- p2 <- getPosP
- debugM $ "printStringAtAA:(pe,p1,p2)=" ++ show (pe,p1,p2)
- setPriorEndASTPD True (p1,p2)
+-- lam_decls :: Lens AnnsModule AnnList
+-- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns })
+-- (k (am_decls annsModule))
--- Based on Delta.addAnnotationWorker
-printStringAtKw' :: RealSrcSpan -> String -> EPP ()
-printStringAtKw' pa str = do
- printComments pa
- pe <- getPriorEndD
- debugM $ "printStringAtKw':pe=" ++ show pe
- let p = ss2delta pe pa
- p' <- adjustDeltaForOffsetM p
- printStringAtLsDelta p' str
- setPriorEndASTD True pa
--- ---------------------------------------------------------------------
+-- data EpAnnImportDecl = EpAnnImportDecl
+-- { importDeclAnnImport :: EpaLocation
+-- , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation)
+-- , importDeclAnnSafe :: Maybe EpaLocation
+-- , importDeclAnnQualified :: Maybe EpaLocation
+-- , importDeclAnnPackage :: Maybe EpaLocation
+-- , importDeclAnnAs :: Maybe EpaLocation
+-- } deriving (Data)
-markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP ()
-markExternalSourceText l NoSourceText txt = printStringAtKw' (realSrcSpan l) txt
-markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) txt
+limportDeclAnnImport :: Lens EpAnnImportDecl EpaLocation
+limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new })
+ (k (importDeclAnnImport annImp))
--- ---------------------------------------------------------------------
+-- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation))
+-- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new })
+-- (k (importDeclAnnPragma annImp))
-markAddEpAnn :: AddEpAnn -> EPP ()
-markAddEpAnn a@(AddEpAnn kw _) = mark [a] kw
+limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe EpaLocation)
+limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new })
+ (k (importDeclAnnSafe annImp))
-markLocatedMAA :: EpAnn a -> (a -> Maybe AddEpAnn) -> EPP ()
-markLocatedMAA EpAnnNotUsed _ = return ()
-markLocatedMAA (EpAnn _ a _) f =
- case f a of
- Nothing -> return ()
- Just aa -> markAddEpAnn aa
+limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe EpaLocation)
+limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new })
+ (k (importDeclAnnQualified annImp))
-markLocatedAA :: EpAnn a -> (a -> AddEpAnn) -> EPP ()
-markLocatedAA EpAnnNotUsed _ = return ()
-markLocatedAA (EpAnn _ a _) f = markKw (f a)
+limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation)
+limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new })
+ (k (importDeclAnnPackage annImp))
-markLocatedAAL :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EPP ()
-markLocatedAAL EpAnnNotUsed _ _ = return ()
-markLocatedAAL (EpAnn _ a _) f kw = go (f a)
- where
- go [] = return ()
- go (aa@(AddEpAnn kw' _):as)
- | kw' == kw = mark [aa] kw
- | otherwise = go as
-
-markLocatedAALS :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> Maybe String -> EPP ()
-markLocatedAALS an f kw Nothing = markLocatedAAL an f kw
-markLocatedAALS EpAnnNotUsed _ _ _ = return ()
-markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a)
- where
- go [] = return ()
- go (AddEpAnn kw' r:as)
- | kw' == kw = printStringAtAA r str
- | otherwise = go as
+-- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation)
+-- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new })
+-- (k (importDeclAnnAs annImp))
--- ---------------------------------------------------------------------
+-- -------------------------------------
-markArrow :: HsArrow GhcPs -> EPP ()
-markArrow (HsUnrestrictedArrow arr) = do
- markUniToken arr
-markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do
- markToken pct1
- markUniToken arr
-markArrow (HsLinearArrow (HsLolly arr)) = do
- markToken arr
-markArrow (HsExplicitMult pct t arr) = do
- markToken pct
- markAnnotated t
- markUniToken arr
+-- data AnnList
+-- = AnnList {
+-- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout
+-- al_open :: Maybe AddEpAnn,
+-- al_close :: Maybe AddEpAnn,
+-- al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword
+-- al_trailing :: [TrailingAnn] -- ^ items appearing after the
+-- -- list, such as '=>' for a
+-- -- context
+-- } deriving (Data,Eq)
+
+lal_open :: Lens AnnList (Maybe AddEpAnn)
+lal_open k parent = fmap (\new -> parent { al_open = new })
+ (k (al_open parent))
+
+lal_close :: Lens AnnList (Maybe AddEpAnn)
+lal_close k parent = fmap (\new -> parent { al_close = new })
+ (k (al_close parent))
+
+lal_rest :: Lens AnnList [AddEpAnn]
+lal_rest k parent = fmap (\new -> parent { al_rest = new })
+ (k (al_rest parent))
+
+lal_trailing :: Lens AnnList [TrailingAnn]
+lal_trailing k parent = fmap (\new -> parent { al_trailing = new })
+ (k (al_trailing parent))
--- ---------------------------------------------------------------------
+-- -------------------------------------
-markAnnCloseP :: EpAnn AnnPragma -> EPP ()
-markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}")
+lapr_rest :: Lens AnnPragma [AddEpAnn]
+lapr_rest k parent = fmap (\newAnns -> parent { apr_rest = newAnns })
+ (k (apr_rest parent))
-markAnnOpenP :: EpAnn AnnPragma -> SourceText -> String -> EPP ()
-markAnnOpenP an NoSourceText txt = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt)
-markAnnOpenP an (SourceText txt) _ = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt)
+lapr_open :: Lens AnnPragma AddEpAnn
+lapr_open k parent = fmap (\new -> parent { apr_open = new })
+ (k (apr_open parent))
-markAnnOpen :: EpAnn [AddEpAnn] -> SourceText -> String -> EPP ()
-markAnnOpen an NoSourceText txt = markLocatedAALS an id AnnOpen (Just txt)
-markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt)
+lapr_close :: Lens AnnPragma AddEpAnn
+lapr_close k parent = fmap (\new -> parent { apr_close = new })
+ (k (apr_close parent))
-markAnnOpen' :: Maybe EpaLocation -> SourceText -> String -> EPP ()
-markAnnOpen' ms NoSourceText txt = printStringAtMkw ms txt
-markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt
+lidl :: Lens [AddEpAnn] [AddEpAnn]
+lidl k parent = fmap (\new -> new)
+ (k parent)
--- ---------------------------------------------------------------------
+lid :: Lens a a
+lid k parent = fmap (\new -> new)
+ (k parent)
-markOpeningParen, markClosingParen :: EpAnn AnnParen -> EPP ()
-markOpeningParen an = markParen an fst
-markClosingParen an = markParen an snd
+lfst :: Lens (a,a) a
+lfst k parent = fmap (\new -> (new, snd parent))
+ (k (fst parent))
-markParen :: EpAnn AnnParen -> (forall a. (a,a) -> a) -> EPP ()
-markParen EpAnnNotUsed _ = return ()
-markParen (EpAnn _ (AnnParen pt o c) _) f = markKwA (f $ kw pt) (f (o, c))
- where
- kw AnnParens = (AnnOpenP, AnnCloseP)
- kw AnnParensHash = (AnnOpenPH, AnnClosePH)
- kw AnnParensSquare = (AnnOpenS, AnnCloseS)
+lsnd :: Lens (a,a) a
+lsnd k parent = fmap (\new -> (fst parent, new))
+ (k (snd parent))
+-- -------------------------------------
+-- data AnnExplicitSum
+-- = AnnExplicitSum {
+-- aesOpen :: EpaLocation,
+-- aesBarsBefore :: [EpaLocation],
+-- aesBarsAfter :: [EpaLocation],
+-- aesClose :: EpaLocation
+-- } deriving Data
+
+laesOpen :: Lens AnnExplicitSum EpaLocation
+laesOpen k parent = fmap (\new -> parent { aesOpen = new })
+ (k (aesOpen parent))
+
+laesBarsBefore :: Lens AnnExplicitSum [EpaLocation]
+laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new })
+ (k (aesBarsBefore parent))
+
+laesBarsAfter :: Lens AnnExplicitSum [EpaLocation]
+laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new })
+ (k (aesBarsAfter parent))
+
+laesClose :: Lens AnnExplicitSum EpaLocation
+laesClose k parent = fmap (\new -> parent { aesClose = new })
+ (k (aesClose parent))
-markAnnKw :: EpAnn a -> (a -> EpaLocation) -> AnnKeywordId -> EPP ()
-markAnnKw EpAnnNotUsed _ _ = return ()
-markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a)
+-- -------------------------------------
+-- data AnnFieldLabel
+-- = AnnFieldLabel {
+-- afDot :: Maybe EpaLocation
+-- } deriving Data
-markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP ()
-markAnnKwAll EpAnnNotUsed _ _ = return ()
-markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sortBy (comparing unsafeGetEpaLoc) (f a))
+lafDot :: Lens AnnFieldLabel (Maybe EpaLocation)
+lafDot k parent = fmap (\new -> parent { afDot = new })
+ (k (afDot parent))
-markAnnKwM :: EpAnn a -> (a -> Maybe EpaLocation) -> AnnKeywordId -> EPP ()
-markAnnKwM EpAnnNotUsed _ _ = return ()
-markAnnKwM (EpAnn _ a _) f kw = go (f a)
- where
- go Nothing = return ()
- go (Just s) = markKwA kw s
+-- -------------------------------------
+-- data AnnProjection
+-- = AnnProjection {
+-- apOpen :: EpaLocation, -- ^ '('
+-- apClose :: EpaLocation -- ^ ')'
+-- } deriving Data
-markALocatedA :: EpAnn AnnListItem -> EPP ()
-markALocatedA EpAnnNotUsed = return ()
-markALocatedA (EpAnn _ a _) = markTrailing (lann_trailing a)
+lapOpen :: Lens AnnProjection EpaLocation
+lapOpen k parent = fmap (\new -> parent { apOpen = new })
+ (k (apOpen parent))
-markEpAnn :: EpAnn [AddEpAnn] -> AnnKeywordId -> EPP ()
-markEpAnn EpAnnNotUsed _ = return ()
-markEpAnn (EpAnn _ a _) kw = mark a kw
+lapClose :: Lens AnnProjection EpaLocation
+lapClose k parent = fmap (\new -> parent { apClose = new })
+ (k (apClose parent))
-markEpAnn' :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP ()
-markEpAnn' EpAnnNotUsed _ _ = return ()
-markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw
+-- -------------------------------------
+-- data AnnsIf
+-- = AnnsIf {
+-- aiIf :: EpaLocation,
+-- aiThen :: EpaLocation,
+-- aiElse :: EpaLocation,
+-- aiThenSemi :: Maybe EpaLocation,
+-- aiElseSemi :: Maybe EpaLocation
+-- } deriving Data
+
+laiIf :: Lens AnnsIf EpaLocation
+laiIf k parent = fmap (\new -> parent { aiIf = new })
+ (k (aiIf parent))
+
+laiThen :: Lens AnnsIf EpaLocation
+laiThen k parent = fmap (\new -> parent { aiThen = new })
+ (k (aiThen parent))
+
+laiElse :: Lens AnnsIf EpaLocation
+laiElse k parent = fmap (\new -> parent { aiElse = new })
+ (k (aiElse parent))
+
+laiThenSemi :: Lens AnnsIf (Maybe EpaLocation)
+laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new })
+ (k (aiThenSemi parent))
+
+laiElseSemi :: Lens AnnsIf (Maybe EpaLocation)
+laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new })
+ (k (aiElseSemi parent))
-markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP ()
-markEpAnnAll EpAnnNotUsed _ _ = return ()
-markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns)
- where
- anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a)
+-- -------------------------------------
-unsafeGetEpAnnLoc :: AddEpAnn -> RealSrcSpan
-unsafeGetEpAnnLoc (AddEpAnn _ ss) = unsafeGetEpaLoc ss
+-- data AnnParen
+-- = AnnParen {
+-- ap_adornment :: ParenType,
+-- ap_open :: EpaLocation,
+-- ap_close :: EpaLocation
+-- } deriving (Data)
+-- lap_open :: Lens AnnParen EpaLocation
+-- lap_open k parent = fmap (\new -> parent { ap_open = new })
+-- (k (ap_open parent))
-unsafeGetEpaLoc :: EpaLocation -> RealSrcSpan
-unsafeGetEpaLoc (EpaSpan real) = real
-unsafeGetEpaLoc (EpaDelta _ _) = error "DELTA"
+-- lap_close :: Lens AnnParen EpaLocation
+-- lap_close k parent = fmap (\new -> parent { ap_close = new })
+-- (k (ap_close parent))
-markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP ()
-markAnnAll a kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns)
- where
- anns = filter (\(AddEpAnn ka _) -> ka == kw) a
-
-mark :: [AddEpAnn] -> AnnKeywordId -> EPP ()
-mark anns kw = do
- case find (\(AddEpAnn k _) -> k == kw) anns of
- Just aa -> markKw aa
- Nothing -> case find (\(AddEpAnn k _) -> k == (unicodeAnn kw)) anns of
- Just aau -> markKw aau
- Nothing -> return ()
+-- -------------------------------------
+-- data EpAnnHsCase = EpAnnHsCase
+-- { hsCaseAnnCase :: EpaLocation
+-- , hsCaseAnnOf :: EpaLocation
+-- , hsCaseAnnsRest :: [AddEpAnn]
+-- } deriving Data
+
+lhsCaseAnnCase :: Lens EpAnnHsCase EpaLocation
+lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new })
+ (k (hsCaseAnnCase parent))
+
+lhsCaseAnnOf :: Lens EpAnnHsCase EpaLocation
+lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new })
+ (k (hsCaseAnnOf parent))
+
+lhsCaseAnnsRest :: Lens EpAnnHsCase [AddEpAnn]
+lhsCaseAnnsRest k parent = fmap (\new -> parent { hsCaseAnnsRest = new })
+ (k (hsCaseAnnsRest parent))
+
+-- ---------------------------------------------------------------------
+
+-- data HsRuleAnn
+-- = HsRuleAnn
+-- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
+-- -- ^ The locations of 'forall' and '.' for forall'd type vars
+-- -- Using AddEpAnn to capture possible unicode variants
+-- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
+-- -- ^ The locations of 'forall' and '.' for forall'd term vars
+-- -- Using AddEpAnn to capture possible unicode variants
+-- , ra_rest :: [AddEpAnn]
+-- } deriving (Data, Eq)
+
+lra_tyanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn))
+lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new })
+ (k (ra_tyanns parent))
+
+ff :: Maybe (a,b) -> (Maybe a,Maybe b)
+ff Nothing = (Nothing, Nothing)
+ff (Just (a,b)) = (Just a, Just b)
-markKwT :: TrailingAnn -> EPP ()
-markKwT (AddSemiAnn ss) = markKwA AnnSemi ss
-markKwT (AddCommaAnn ss) = markKwA AnnComma ss
-markKwT (AddVbarAnn ss) = markKwA AnnVbar ss
-markKw :: AddEpAnn -> EPP ()
-markKw (AddEpAnn kw ss) = markKwA kw ss
+gg :: (Maybe a,Maybe b) -> Maybe (a,b)
+gg (Nothing, Nothing) = Nothing
+gg (Just a, Just b) = Just (a,b)
+gg _ = error "gg:expecting two Nothing or two Just"
--- | This should be the main driver of the process, managing comments
-markKwA :: AnnKeywordId -> EpaLocation -> EPP ()
-markKwA kw aa = printStringAtAA aa (keywordToString (G kw))
+lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b)
+lff k parent = fmap (\new -> gg new)
+ (k (ff parent))
-markToken :: forall tok. KnownSymbol tok => LHsToken tok GhcPs -> EPP ()
-markToken (L NoTokenLoc _) = return ()
-markToken (L (TokenLoc aa) _) = printStringAtAA aa (symbolVal (Proxy @tok))
+-- (.) :: Lens' a b -> Lens' b c -> Lens' a c
+lra_tyanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tyanns_fst = lra_tyanns . lff . lfst
+
+lra_tyanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tyanns_snd = lra_tyanns . lff . lsnd
+
+lra_tmanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn))
+lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new })
+ (k (ra_tmanns parent))
+
+lra_tmanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tmanns_fst = lra_tmanns . lff . lfst
+
+lra_tmanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tmanns_snd = lra_tmanns . lff . lsnd
+
+lra_rest :: Lens HsRuleAnn [AddEpAnn]
+lra_rest k parent = fmap (\new -> parent { ra_rest = new })
+ (k (ra_rest parent))
-markUniToken :: forall tok utok. (KnownSymbol tok, KnownSymbol utok) => LHsUniToken tok utok GhcPs -> EPP ()
-markUniToken (L l HsNormalTok) = markToken (L l (HsTok @tok))
-markUniToken (L l HsUnicodeTok) = markToken (L l (HsTok @utok))
-- ---------------------------------------------------------------------
+-- data GrhsAnn
+-- = GrhsAnn {
+-- ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this?
+-- ga_sep :: AddEpAnn -- ^ Match separator location
+-- } deriving (Data)
-markAnnList :: Bool -> EpAnn AnnList -> EPP () -> EPP ()
-markAnnList _ EpAnnNotUsed action = action
-markAnnList reallyTrail (EpAnn _ ann _) action = markAnnList' reallyTrail ann action
+lga_vbar :: Lens GrhsAnn (Maybe EpaLocation)
+lga_vbar k parent = fmap (\new -> parent { ga_vbar = new })
+ (k (ga_vbar parent))
-markAnnList' :: Bool -> AnnList -> EPP () -> EPP ()
-markAnnList' reallyTrail ann action = do
- p <- getPosP
- debugM $ "markAnnList : " ++ showPprUnsafe (p, ann)
- mapM_ markAddEpAnn (al_open ann)
- unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule.
- markAnnAll (sortBy (comparing unsafeGetEpAnnLoc) $ al_rest ann) AnnSemi
- action
- mapM_ markAddEpAnn (al_close ann)
- debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann)
- when reallyTrail $ markTrailing (al_trailing ann) -- normal case
+lga_sep :: Lens GrhsAnn AddEpAnn
+lga_sep k parent = fmap (\new -> parent { ga_sep = new })
+ (k (ga_sep parent))
-- ---------------------------------------------------------------------
+-- data AnnSig
+-- = AnnSig {
+-- asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option
+-- asRest :: [AddEpAnn]
+-- } deriving Data
+
+lasDcolon :: Lens AnnSig AddEpAnn
+lasDcolon k parent = fmap (\new -> parent { asDcolon = new })
+ (k (asDcolon parent))
+
+lasRest :: Lens AnnSig [AddEpAnn]
+lasRest k parent = fmap (\new -> parent { asRest = new })
+ (k (asRest parent))
+
+-- ---------------------------------------------------------------------
+-- data EpAnnSumPat = EpAnnSumPat
+-- { sumPatParens :: [AddEpAnn]
+-- , sumPatVbarsBefore :: [EpaLocation]
+-- , sumPatVbarsAfter :: [EpaLocation]
+-- } deriving Data
+
+lsumPatParens :: Lens EpAnnSumPat [AddEpAnn]
+lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new })
+ (k (sumPatParens parent))
+
+lsumPatVbarsBefore :: Lens EpAnnSumPat [EpaLocation]
+lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new })
+ (k (sumPatVbarsBefore parent))
-printComments :: RealSrcSpan -> EPP ()
+lsumPatVbarsAfter :: Lens EpAnnSumPat [EpaLocation]
+lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new })
+ (k (sumPatVbarsAfter parent))
+
+-- End of lenses
+-- ---------------------------------------------------------------------
+
+markLensKwA :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a)
+markLensKwA EpAnnNotUsed _ = return EpAnnNotUsed
+markLensKwA (EpAnn anc a cs) l = do
+ loc <- markKw (view l a)
+ return (EpAnn anc (set l loc a) cs)
+
+markLensKw :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a)
+markLensKw EpAnnNotUsed _ _ = return EpAnnNotUsed
+markLensKw (EpAnn anc a cs) l kw = do
+ loc <- markKwA kw (view l a)
+ return (EpAnn anc (set l loc a) cs)
+
+markAnnKwL :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a)
+markAnnKwL = markLensKw
+
+markAnnKwAllL :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m (EpAnn a)
+markAnnKwAllL EpAnnNotUsed _ _ = return EpAnnNotUsed
+markAnnKwAllL (EpAnn anc a cs) l kw = do
+ anns <- mapM (markKwA kw) (view l a)
+ return (EpAnn anc (set l anns a) cs)
+
+markLensKwM :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a)
+markLensKwM EpAnnNotUsed _ _ = return EpAnnNotUsed
+markLensKwM (EpAnn anc a cs) l kw = do
+ new <- go (view l a)
+ return (EpAnn anc (set l new a) cs)
+ where
+ go Nothing = return Nothing
+ go (Just s) = Just <$> markKwA kw s
+
+-- ---------------------------------------------------------------------
+
+markALocatedA :: (Monad m, Monoid w) => EpAnn AnnListItem -> EP w m (EpAnn AnnListItem)
+markALocatedA EpAnnNotUsed = return EpAnnNotUsed
+markALocatedA (EpAnn anc a cs) = do
+ t <- markTrailing (lann_trailing a)
+ return (EpAnn anc (a { lann_trailing = t }) cs)
+
+markEpAnnL :: (Monad m, Monoid w)
+ => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann)
+markEpAnnL EpAnnNotUsed _ _ = return EpAnnNotUsed
+markEpAnnL (EpAnn anc a cs) l kw = do
+ anns <- mark' (view l a) kw
+ return (EpAnn anc (set l anns a) cs)
+
+markEpAnnAllL :: (Monad m, Monoid w)
+ => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann)
+markEpAnnAllL EpAnnNotUsed _ _ = return EpAnnNotUsed
+markEpAnnAllL (EpAnn anc a cs) l kw = do
+ anns <- mapM doit (view l a)
+ return (EpAnn anc (set l anns a) cs)
+ where
+ doit an@(AddEpAnn ka _)
+ = if ka == kw
+ then markKw an
+ else return an
+
+markAddEpAnn :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn
+markAddEpAnn a@(AddEpAnn kw _) = do
+ r <- mark' [a] kw
+ case r of
+ [a'] -> return a'
+ _ -> error "Should not happen: markAddEpAnn"
+
+mark' :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m [AddEpAnn]
+mark' anns kw = do
+ case find' kw anns of
+ (lead, Just aa, end) -> do
+ aa' <- markKw aa
+ return (lead ++ [aa'] ++ end)
+ (_lead, Nothing, _end) -> case find' (unicodeAnn kw) anns of
+ (leadu, Just aau, endu) -> do
+ aau' <- markKw aau
+ return (leadu ++ [aau'] ++ endu)
+ (_,Nothing,_) -> return anns
+
+-- | Find for update, returning lead section of the list, item if
+-- found, and tail of the list
+find' :: AnnKeywordId -> [AddEpAnn] -> ([AddEpAnn], Maybe AddEpAnn, [AddEpAnn])
+find' kw anns = (lead, middle, end)
+ where
+ (lead, rest) = break (\(AddEpAnn k _) -> k == kw) anns
+ (middle,end) = case rest of
+ [] -> (Nothing, [])
+ (x:xs) -> (Just x, xs)
+
+markKw :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn
+markKw an = markKwC CaptureComments an
+
+markKwC :: (Monad m, Monoid w) => CaptureComments -> AddEpAnn -> EP w m AddEpAnn
+markKwC capture (AddEpAnn kw ss) = do
+ ss' <- markKwAC capture kw ss
+ return (AddEpAnn kw ss')
+
+-- | This should be the main driver of the process, managing printing keywords.
+-- It returns the 'EpaDelta' variant of the passed in 'EpaLocation'
+markKwA :: (Monad m, Monoid w) => AnnKeywordId -> EpaLocation -> EP w m EpaLocation
+markKwA kw aa = markKwAC CaptureComments kw aa
+
+markKwAC :: (Monad m, Monoid w)
+ => CaptureComments -> AnnKeywordId -> EpaLocation -> EP w m EpaLocation
+markKwAC capture kw aa = printStringAtAAC capture aa (keywordToString kw)
+
+-- | Print a keyword encoded in a 'TrailingAnn'
+markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn
+markKwT (AddSemiAnn ss) = AddSemiAnn <$> markKwA AnnSemi ss
+markKwT (AddCommaAnn ss) = AddCommaAnn <$> markKwA AnnComma ss
+markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss
+
+-- ---------------------------------------------------------------------
+
+markAnnList :: (Monad m, Monoid w)
+ => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)
+markAnnList reallyTrail ann action = do
+ markAnnListA reallyTrail ann $ \a -> do
+ r <- action
+ return (a,r)
+
+markAnnListA :: (Monad m, Monoid w)
+ => Bool -> EpAnn AnnList
+ -> (EpAnn AnnList -> EP w m (EpAnn AnnList, a))
+ -> EP w m (EpAnn AnnList, a)
+markAnnListA _ EpAnnNotUsed action = do
+ action EpAnnNotUsed
+markAnnListA reallyTrail an action = do
+ debugM $ "markAnnListA: an=" ++ showAst an
+ an0 <- markLensMAA an lal_open
+ an1 <- if (not reallyTrail)
+ then markTrailingL an0 lal_trailing
+ else return an0
+ an2 <- markEpAnnAllL an1 lal_rest AnnSemi
+ (an3, r) <- action an2
+ an4 <- markLensMAA an3 lal_close
+ an5 <- if reallyTrail
+ then markTrailingL an4 lal_trailing
+ else return an4
+ debugM $ "markAnnListA: an5=" ++ showAst an
+ return (an5, r)
+
+
+markAnnList' :: (Monad m, Monoid w)
+ => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)
+markAnnList' reallyTrail an action = do
+ p <- getPosP
+ debugM $ "markAnnList : " ++ showPprUnsafe (p, an)
+ an0 <- markLensMAA an lal_open
+ an1 <- if (not reallyTrail)
+ then markTrailingL an0 lal_trailing
+ else return an0
+ an2 <- markEpAnnAllL an1 lal_rest AnnSemi
+ r <- action
+ an3 <- markLensMAA an2 lal_close
+ an4 <- if reallyTrail
+ then markTrailingL an3 lal_trailing
+ else return an3
+ return (an4, r)
+
+-- ---------------------------------------------------------------------
+
+printComments :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
printComments ss = do
cs <- commentAllocation ss
+ debugM $ "printComments: (ss): " ++ showPprUnsafe (rs2range ss)
-- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
mapM_ printOneComment cs
-- ---------------------------------------------------------------------
-printOneComment :: Comment -> EPP ()
-printOneComment c@(Comment _str loc _mo) = do
+printOneComment :: (Monad m, Monoid w) => Comment -> EP w m ()
+printOneComment c@(Comment _str loc _r _mo) = do
debugM $ "printOneComment:c=" ++ showGhc c
dp <-case anchor_op loc of
MovedAnchor dp -> return dp
@@ -695,48 +1240,172 @@ printOneComment c@(Comment _str loc _mo) = do
pe <- getPriorEndD
let dp = ss2delta pe (anchor loc)
debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc)
- return dp
- dp'' <- adjustDeltaForOffsetM dp
+ adjustDeltaForOffsetM dp
mep <- getExtraDP
dp' <- case mep of
Just (Anchor _ (MovedAnchor edp)) -> do
debugM $ "printOneComment:edp=" ++ show edp
- return edp
- _ -> return dp''
- LayoutStartCol dOff <- gets dLHS
- debugM $ "printOneComment:(dp,dp',dp'',dOff)=" ++ showGhc (dp,dp',dp'',dOff)
- setPriorEndD (ss2posEnd (anchor loc))
+ ddd <- fmap unTweakDelta $ adjustDeltaForOffsetM edp
+ debugM $ "printOneComment:ddd=" ++ show ddd
+ fmap unTweakDelta $ adjustDeltaForOffsetM edp
+ _ -> return dp
+ -- Start of debug printing
+ -- LayoutStartCol dOff <- getLayoutOffsetD
+ -- debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff)
+ -- End of debug printing
+ -- setPriorEndD (ss2posEnd (anchor loc))
+ updateAndApplyComment c dp'
printQueuedComment (anchor loc) c dp'
--- ---------------------------------------------------------------------
+-- | For comment-related deltas starting on a new line we have an
+-- off-by-one problem. Adjust
+unTweakDelta :: DeltaPos -> DeltaPos
+unTweakDelta (SameLine d) = SameLine d
+unTweakDelta (DifferentLine l d) = DifferentLine l (d+1)
+
-commentAllocation :: RealSrcSpan -> EPP [Comment]
+updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
+updateAndApplyComment (Comment str anc pp mo) dp = do
+ -- debugM $ "updateAndApplyComment: (dp,anc',co)=" ++ showAst (dp,anc',co)
+ applyComment (Comment str anc' pp mo)
+ where
+ anc' = anc { anchor_op = op}
+
+ (r,c) = ss2posEnd pp
+ la = anchor anc
+ dp'' = if r == 0
+ then (ss2delta (r,c+0) la)
+ else (ss2delta (r,c) la)
+ dp' = if pp == anchor anc
+ then dp
+ else dp''
+ op' = case dp' of
+ SameLine n -> if n >= 0
+ then MovedAnchor dp'
+ else MovedAnchor dp
+ _ -> MovedAnchor dp'
+ op = if str == "" && op' == MovedAnchor (SameLine 0) -- EOF comment
+ then MovedAnchor dp
+ -- else op'
+ else MovedAnchor dp
+
+-- ---------------------------------------------------------------------
+
+commentAllocation :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]
commentAllocation ss = do
cs <- getUnallocatedComments
-- Note: The CPP comment injection may change the file name in the
-- RealSrcSpan, which affects comparison, as the Ord instance for
-- RealSrcSpan compares the file first. So we sort via ss2pos
-- TODO: this is inefficient, use Pos all the way through
- let (earlier,later) = partition (\(Comment _str loc _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs
+ let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs
putUnallocatedComments later
-- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
return earlier
-- ---------------------------------------------------------------------
-
-markAnnotatedWithLayout :: ExactPrint ast => ast -> EPP ()
+markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast
markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a
-- ---------------------------------------------------------------------
-markTopLevelList :: ExactPrint ast => [ast] -> EPP ()
-markTopLevelList ls = mapM_ (\a -> setLayoutTopLevelP $ markAnnotated a) ls
+markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast]
+markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls
+
+-- ---------------------------------------------------------------------
+-- End of utility functions
+-- ---------------------------------------------------------------------
+-- Start of ExactPrint instances
+-- ---------------------------------------------------------------------
+
+-- | Bare Located elements are simply stripped off without further
+-- processing.
+instance (ExactPrint a) => ExactPrint (Located a) where
+ getAnnotationEntry (L l _) = case l of
+ UnhelpfulSpan _ -> NoEntryVal
+ _ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly
+
+ setAnnotationAnchor (L _ a) anc _cs = (L (hackAnchorToSrcSpan anc) a)
+ `debug` ("setAnnotationAnchor(Located):" ++ showAst anc)
+
+ exact (L l a) = L l <$> markAnnotated a
+
+instance (ExactPrint a) => ExactPrint (LocatedA a) where
+ getAnnotationEntry = entryFromLocatedA
+ setAnnotationAnchor la anc cs = setAnchorAn la anc cs
+ exact (L la a) = do
+ debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la)
+ a' <- markAnnotated a
+ ann' <- markALocatedA (ann la)
+ return (L (la { ann = ann'}) a')
+
+instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where
+ getAnnotationEntry = entryFromLocatedA
+ setAnnotationAnchor la anc cs = setAnchorAn la anc cs
+ exact (L la a) = do
+ a' <- markAnnotated a
+ return (L la a')
+
+instance (ExactPrint a) => ExactPrint [a] where
+ getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor ls _ _ = ls
+ exact ls = mapM markAnnotated ls
+
+instance (ExactPrint a) => ExactPrint (Maybe a) where
+ getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor ma _ _ = ma
+ exact ma = mapM markAnnotated ma
+
+-- ---------------------------------------------------------------------
+
+-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'
+instance ExactPrint (HsModule GhcPs) where
+ getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod)
+ -- A bit pointless actually changing anything here
+ setAnnotationAnchor hsmod anc cs = setAnchorHsModule hsmod anc cs
+ `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs))
+
+ exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod
+ exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do
+
+ mbDoc' <- markAnnotated mbDoc
+
+ (an0, mmn' , mdeprec', mexports') <-
+ case mmn of
+ Nothing -> return (an, mmn, mdeprec, mexports)
+ Just m -> do
+ an0 <- markEpAnnL an lam_main AnnModule
+ m' <- markAnnotated m
+
+ mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec
+
+ mexports' <- setLayoutTopLevelP $ markAnnotated mexports
+
+ an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere
+
+ return (an1, Just m', mdeprec', mexports')
+
+ let ann_decls = EpAnn (entry an) (am_decls $ anns an0) emptyComments
+ (ann_decls', (decls', imports')) <- markAnnList' False ann_decls $ do
+ imports' <- markTopLevelList imports
+ decls' <- markTopLevelList decls
+ return (decls', imports')
+ let am_decls' = case ann_decls' of
+ EpAnnNotUsed -> (am_decls $ anns an0)
+ EpAnn _ r _ -> r
+
+ let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}
+ debugM $ "HsModule, anf=" ++ showAst anf
+
+ return (HsModule (XModulePs anf lo mdeprec' mbDoc') mmn' mexports' imports' decls')
-- ---------------------------------------------------------------------
instance ExactPrint ModuleName where
getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor n _anc cs = n
+ `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs)
exact n = do
debugM $ "ModuleName: " ++ showPprUnsafe n
withPpr n
@@ -745,76 +1414,113 @@ instance ExactPrint ModuleName where
instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
getAnnotationEntry = entryFromLocatedA
- exact (L (SrcSpanAnn an _) (WarningTxt (L _ src) ws)) = do
- markAnnOpenP an src "{-# WARNING"
- markLocatedAAL an apr_rest AnnOpenS
- markAnnotated ws
- markLocatedAAL an apr_rest AnnCloseS
- markAnnCloseP an
+ setAnnotationAnchor = setAnchorAn
- exact (L (SrcSpanAnn an _) (DeprecatedTxt (L _ src) ws)) = do
- markAnnOpenP an src "{-# DEPRECATED"
- markLocatedAAL an apr_rest AnnOpenS
- markAnnotated ws
- markLocatedAAL an apr_rest AnnCloseS
- markAnnCloseP an
+ exact (L (SrcSpanAnn an l) (WarningTxt (L la src) ws)) = do
+ an0 <- markAnnOpenP an src "{-# WARNING"
+ an1 <- markEpAnnL an0 lapr_rest AnnOpenS
+ ws' <- markAnnotated ws
+ an2 <- markEpAnnL an1 lapr_rest AnnCloseS
+ an3 <- markAnnCloseP an2
+ return (L (SrcSpanAnn an3 l) (WarningTxt (L la src) ws'))
+
+ exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do
+ an0 <- markAnnOpenP an src "{-# DEPRECATED"
+ an1 <- markEpAnnL an0 lapr_rest AnnOpenS
+ ws' <- markAnnotated ws
+ an2 <- markEpAnnL an1 lapr_rest AnnCloseS
+ an3 <- markAnnCloseP an2
+ return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws'))
-- ---------------------------------------------------------------------
instance ExactPrint (ImportDecl GhcPs) where
getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl)
+ setAnnotationAnchor idecl anc cs = idecl { ideclExt
+ = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc cs} }
+
exact x@(ImportDecl{ ideclExt = XImportDeclPass{ ideclAnn = EpAnnNotUsed } }) = withPpr x
- exact (ImportDecl (XImportDeclPass ann@(EpAnn _ an _) msrc _impl) modname mpkg _src safeflag qualFlag mAs hiding) = do
+ exact (ImportDecl (XImportDeclPass ann msrc impl)
+ modname mpkg src safeflag qualFlag mAs hiding) = do
- markAnnKw ann importDeclAnnImport AnnImport
+ ann0 <- markLensKw ann limportDeclAnnImport AnnImport
+ let (EpAnn _anc an _cs) = ann0
-- "{-# SOURCE" and "#-}"
- case msrc of
- SourceText _txt -> do
- debugM $ "ImportDecl sourcetext"
- let mo = fmap fst $ importDeclAnnPragma an
- let mc = fmap snd $ importDeclAnnPragma an
- markAnnOpen' mo msrc "{-# SOURCE"
- printStringAtMkw mc "#-}"
- NoSourceText -> return ()
- when safeflag (markAnnKwM ann importDeclAnnSafe AnnSafe)
- case qualFlag of
- QualifiedPre -- 'qualified' appears in prepositive position.
- -> printStringAtMkw (importDeclAnnQualified an) "qualified"
- _ -> return ()
- case mpkg of
- RawPkgQual (StringLiteral src v _) ->
- printStringAtMkw (importDeclAnnPackage an) (sourceTextToString src (show v))
- _ -> return ()
-
- markAnnotated modname
-
- case qualFlag of
- QualifiedPost -- 'qualified' appears in postpositive position.
- -> printStringAtMkw (importDeclAnnQualified an) "qualified"
- _ -> return ()
-
- case mAs of
- Nothing -> return ()
- Just mn -> do
- printStringAtMkw (importDeclAnnAs an) "as"
- markAnnotated mn
-
- case hiding of
- Nothing -> return ()
- Just (_isHiding,lie) -> exact lie
- -- markTrailingSemi
+ importDeclAnnPragma' <-
+ case msrc of
+ SourceText _txt -> do
+ debugM $ "ImportDecl sourcetext"
+ case importDeclAnnPragma an of
+ Just (mo, mc) -> do
+ mo' <- markAnnOpen'' mo msrc "{-# SOURCE"
+ mc' <- printStringAtAA mc "#-}"
+ return $ Just (mo', mc')
+ Nothing -> do
+ _ <- markAnnOpen' Nothing msrc "{-# SOURCE"
+ printStringAtLsDelta (SameLine 1) "#-}"
+ return Nothing
+ NoSourceText -> return (importDeclAnnPragma an)
+ ann1 <- if safeflag
+ then (markLensKwM ann0 limportDeclAnnSafe AnnSafe)
+ else return ann0
+ ann2 <-
+ case qualFlag of
+ QualifiedPre -- 'qualified' appears in prepositive position.
+ -> printStringAtMLocL ann1 limportDeclAnnQualified "qualified"
+ _ -> return ann1
+ ann3 <-
+ case mpkg of
+ RawPkgQual (StringLiteral src' v _) ->
+ printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v))
+ _ -> return ann2
+ modname' <- markAnnotated modname
+
+ ann4 <-
+ case qualFlag of
+ QualifiedPost -- 'qualified' appears in postpositive position.
+ -> printStringAtMLocL ann3 limportDeclAnnQualified "qualified"
+ _ -> return ann3
+
+ (importDeclAnnAs', mAs') <-
+ case mAs of
+ Nothing -> return (importDeclAnnAs an, Nothing)
+ Just m0 -> do
+ a <- printStringAtMLoc' (importDeclAnnAs an) "as"
+ m'' <- markAnnotated m0
+ return (a, Just m'')
+
+ hiding' <-
+ case hiding of
+ Nothing -> return hiding
+ Just (isHiding,lie) -> do
+ lie' <- markAnnotated lie
+ return (Just (isHiding, lie'))
+
+ let (EpAnn anc' an' cs') = ann4
+ let an2 = an' { importDeclAnnAs = importDeclAnnAs'
+ , importDeclAnnPragma = importDeclAnnPragma'
+ }
+
+ return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl)
+ modname' mpkg src safeflag qualFlag mAs' hiding')
-- ---------------------------------------------------------------------
instance ExactPrint HsDocString where
getAnnotationEntry _ = NoEntryVal
- exact = printStringAdvance . exactPrintHsDocString
+ setAnnotationAnchor a _ _ = a
+ exact ds = do
+ (printStringAdvance . exactPrintHsDocString) ds
+ return ds
instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where
getAnnotationEntry _ = NoEntryVal
- exact = exact . hsDocString
+ setAnnotationAnchor a _ _ = a
+ exact (WithHsDocIdentifiers ds ids) = do
+ ds' <- exact ds
+ return (WithHsDocIdentifiers ds' ids)
-- ---------------------------------------------------------------------
@@ -834,20 +1540,24 @@ instance ExactPrint (HsDecl GhcPs) where
getAnnotationEntry (DocD _ _) = NoEntryVal
getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal
- exact (TyClD _ d) = markAnnotated d
- exact (InstD _ d) = markAnnotated d
- exact (DerivD _ d) = markAnnotated d
- exact (ValD _ d) = markAnnotated d
- exact (SigD _ d) = markAnnotated d
- exact (KindSigD _ d) = markAnnotated d
- exact (DefD _ d) = markAnnotated d
- exact (ForD _ d) = markAnnotated d
- exact (WarningD _ d) = markAnnotated d
- exact (AnnD _ d) = markAnnotated d
- exact (RuleD _ d) = markAnnotated d
- exact (SpliceD _ d) = markAnnotated d
- exact (DocD _ d) = markAnnotated d
- exact (RoleAnnotD _ d) = markAnnotated d
+ -- We do not recurse, the generic traversal using this feature
+ -- should do that for us.
+ setAnnotationAnchor d _ _ = d
+
+ exact (TyClD x d) = TyClD x <$> markAnnotated d
+ exact (InstD x d) = InstD x <$> markAnnotated d
+ exact (DerivD x d) = DerivD x <$> markAnnotated d
+ exact (ValD x d) = ValD x <$> markAnnotated d
+ exact (SigD x d) = SigD x <$> markAnnotated d
+ exact (KindSigD x d) = KindSigD x <$> markAnnotated d
+ exact (DefD x d) = DefD x <$> markAnnotated d
+ exact (ForD x d) = ForD x <$> markAnnotated d
+ exact (WarningD x d) = WarningD x <$> markAnnotated d
+ exact (AnnD x d) = AnnD x <$> markAnnotated d
+ exact (RuleD x d) = RuleD x <$> markAnnotated d
+ exact (SpliceD x d) = SpliceD x <$> markAnnotated d
+ exact (DocD x d) = DocD x <$> markAnnotated d
+ exact (RoleAnnotD x d) = RoleAnnotD x <$> markAnnotated d
-- ---------------------------------------------------------------------
@@ -856,29 +1566,74 @@ instance ExactPrint (InstDecl GhcPs) where
getAnnotationEntry (DataFamInstD _ _) = NoEntryVal
getAnnotationEntry (TyFamInstD _ _) = NoEntryVal
- exact (ClsInstD _ cid) = markAnnotated cid
- exact (DataFamInstD _ decl) = do
- exactDataFamInstDecl noAnn TopLevel decl
- exact (TyFamInstD _ eqn) = do
- markAnnotated eqn
+ setAnnotationAnchor d _ _ = d
+
+
+ exact (ClsInstD a cid) = do
+ cid' <- markAnnotated cid
+ return (ClsInstD a cid')
+ exact (DataFamInstD a decl) = do
+ d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl)
+ return (DataFamInstD a (dc_d d'))
+ exact (TyFamInstD a eqn) = do
+ eqn' <- markAnnotated eqn
+ return (TyFamInstD a eqn')
+
+-- ---------------------------------------------------------------------
+
+data DataFamInstDeclWithContext
+ = DataFamInstDeclWithContext
+ { _dc_a :: EpAnn [AddEpAnn]
+ , _dc_f :: TopLevelFlag
+ , dc_d :: DataFamInstDecl GhcPs
+ }
+
+instance ExactPrint DataFamInstDeclWithContext where
+ getAnnotationEntry (DataFamInstDeclWithContext _ _ (DataFamInstDecl (FamEqn { feqn_ext = an})))
+ = fromAnn an
+ setAnnotationAnchor (DataFamInstDeclWithContext a c (DataFamInstDecl fe)) anc cs
+ = (DataFamInstDeclWithContext a c (DataFamInstDecl (fe { feqn_ext = (setAnchorEpa (feqn_ext fe) anc cs)})))
+ exact (DataFamInstDeclWithContext an c d) = do
+ debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an
+ (an', d') <- exactDataFamInstDecl an c d
+ return (DataFamInstDeclWithContext an' c d')
-- ---------------------------------------------------------------------
-exactDataFamInstDecl :: EpAnn [AddEpAnn] -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP ()
+exactDataFamInstDecl :: (Monad m, Monoid w)
+ => EpAnn [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs
+ -> EP w m (EpAnn [AddEpAnn], DataFamInstDecl GhcPs)
exactDataFamInstDecl an top_lvl
- (DataFamInstDecl ( FamEqn { feqn_ext = an2
- , feqn_tycon = tycon
- , feqn_bndrs = bndrs
- , feqn_pats = pats
- , feqn_fixity = fixity
- , feqn_rhs = defn }))
- = exactDataDefn an2 pp_hdr defn -- See Note [an and an2 in exactDataFamInstDecl]
+ (DataFamInstDecl (FamEqn { feqn_ext = an2
+ , feqn_tycon = tycon
+ , feqn_bndrs = bndrs
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = defn })) = do
+ (an', an2', tycon', bndrs', _, _mc, defn') <- exactDataDefn an2 pp_hdr defn
+ -- See Note [an and an2 in exactDataFamInstDecl]
+ return
+ (an',
+ DataFamInstDecl ( FamEqn { feqn_ext = an2'
+ , feqn_tycon = tycon'
+ , feqn_bndrs = bndrs'
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = defn' }))
+ `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn'))
where
+ pp_hdr :: (Monad m, Monoid w)
+ => Maybe (LHsContext GhcPs)
+ -> EP w m ( EpAnn [AddEpAnn]
+ , LocatedN RdrName
+ , HsOuterTyVarBndrs () GhcPs
+ , HsTyPats GhcPs
+ , Maybe (LHsContext GhcPs))
pp_hdr mctxt = do
- case top_lvl of
- TopLevel -> markEpAnn an AnnInstance -- TODO: maybe in toplevel
- NotTopLevel -> return ()
- exactHsFamInstLHS an tycon bndrs pats fixity mctxt
+ an0 <- case top_lvl of
+ TopLevel -> markEpAnnL an lidl AnnInstance -- TODO: maybe in toplevel
+ NotTopLevel -> return an
+ exactHsFamInstLHS an0 tycon bndrs pats fixity mctxt
{-
Note [an and an2 in exactDataFamInstDecl]
@@ -894,31 +1649,16 @@ rendering the DataDefn are contained in the FamEqn, and are called
-- ---------------------------------------------------------------------
-exactTyFamInstDecl :: TopLevelFlag -> (TyFamInstDecl GhcPs) -> EPP ()
-exactTyFamInstDecl top_lvl (TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do
- markEpAnn an AnnType
- case top_lvl of
- TopLevel -> markEpAnn an AnnInstance
- NotTopLevel -> return ()
- markAnnotated eqn
-
--- ---------------------------------------------------------------------
-
instance ExactPrint (DerivDecl GhcPs) where
getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an
+ setAnnotationAnchor dd anc cs = dd { deriv_ext = setAnchorEpa (deriv_ext dd) anc cs }
exact (DerivDecl an typ ms mov) = do
- markEpAnn an AnnDeriving
- mapM_ markAnnotated ms
- markEpAnn an AnnInstance
- mapM_ markAnnotated mov
- markAnnotated typ
- -- markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do
- -- mark GHC.AnnDeriving
- -- markMaybe ms
- -- mark GHC.AnnInstance
- -- markMaybe mov
- -- markLocated typ
- -- markTrailingSemi
+ an0 <- markEpAnnL an lidl AnnDeriving
+ ms' <- mapM markAnnotated ms
+ an1 <- markEpAnnL an0 lidl AnnInstance
+ mov' <- mapM markAnnotated mov
+ typ' <- markAnnotated typ
+ return (DerivDecl an1 typ' ms' mov')
-- ---------------------------------------------------------------------
@@ -926,397 +1666,452 @@ instance ExactPrint (ForeignDecl GhcPs) where
getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an
getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an
+ setAnnotationAnchor (ForeignImport an a b c) anc cs = ForeignImport (setAnchorEpa an anc cs) a b c
+ setAnnotationAnchor (ForeignExport an a b c) anc cs = ForeignExport (setAnchorEpa an anc cs) a b c
+
exact (ForeignImport an n ty fimport) = do
- markEpAnn an AnnForeign
- markEpAnn an AnnImport
+ an0 <- markEpAnnL an lidl AnnForeign
+ an1 <- markEpAnnL an0 lidl AnnImport
- markAnnotated fimport
+ fimport' <- markAnnotated fimport
- markAnnotated n
- markEpAnn an AnnDcolon
- markAnnotated ty
+ n' <- markAnnotated n
+ an2 <- markEpAnnL an1 lidl AnnDcolon
+ ty' <- markAnnotated ty
+ return (ForeignImport an2 n' ty' fimport')
exact (ForeignExport an n ty fexport) = do
- markEpAnn an AnnForeign
- markEpAnn an AnnExport
- markAnnotated fexport
- markAnnotated n
- markEpAnn an AnnDcolon
- markAnnotated ty
+ an0 <- markEpAnnL an lidl AnnForeign
+ an1 <- markEpAnnL an0 lidl AnnExport
+ fexport' <- markAnnotated fexport
+ n' <- markAnnotated n
+ an2 <- markEpAnnL an1 lidl AnnDcolon
+ ty' <- markAnnotated ty
+ return (ForeignExport an2 n' ty' fexport')
-- ---------------------------------------------------------------------
instance ExactPrint (ForeignImport GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (CImport (L ls src) cconv safety@(L ll _) _mh _imp) = do
- markAnnotated cconv
- unless (ll == noSrcSpan) $ markAnnotated safety
- unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
+ setAnnotationAnchor a _ _ = a
+ exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do
+ cconv' <- markAnnotated cconv
+ unless (ll == noSrcSpan) $ markAnnotated safety >> return ()
+ unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return ()
+ return (CImport (L ls src) cconv' safety mh imp)
-- ---------------------------------------------------------------------
instance ExactPrint (ForeignExport GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact (CExport (L ls src) spec) = do
debugM $ "CExport starting"
- markAnnotated spec
+ spec' <- markAnnotated spec
unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
+ return (CExport (L ls src) spec')
-- ---------------------------------------------------------------------
instance ExactPrint CExportSpec where
getAnnotationEntry = const NoEntryVal
- exact (CExportStatic _st _lbl cconv) = do
+ setAnnotationAnchor a _ _ = a
+ exact (CExportStatic st lbl cconv) = do
debugM $ "CExportStatic starting"
- markAnnotated cconv
+ cconv' <- markAnnotated cconv
+ return (CExportStatic st lbl cconv')
-- ---------------------------------------------------------------------
instance ExactPrint Safety where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact = withPpr
-- ---------------------------------------------------------------------
instance ExactPrint CCallConv where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact = withPpr
-- ---------------------------------------------------------------------
instance ExactPrint (WarnDecls GhcPs) where
getAnnotationEntry (Warnings (an,_) _) = fromAnn an
+ setAnnotationAnchor (Warnings (an,a) b) anc cs = Warnings ((setAnchorEpa an anc cs),a) b
+
exact (Warnings (an,src) warns) = do
- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
- markAnnotated warns
- markLocatedAALS an id AnnClose (Just "#-}")
+ an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
+ warns' <- markAnnotated warns
+ an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")
+ return (Warnings (an1,src) warns')
-- ---------------------------------------------------------------------
instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry (Warning an _ _) = fromAnn an
+ setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b
exact (Warning an lns txt) = do
- markAnnotated lns
- markEpAnn an AnnOpenS -- "["
- case txt of
- WarningTxt _src ls -> markAnnotated ls
- DeprecatedTxt _src ls -> markAnnotated ls
- markEpAnn an AnnCloseS -- "]"
+ lns' <- markAnnotated lns
+ an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ txt' <-
+ case txt of
+ WarningTxt src ls -> do
+ ls' <- markAnnotated ls
+ return (WarningTxt src ls')
+ DeprecatedTxt src ls -> do
+ ls' <- markAnnotated ls
+ return (DeprecatedTxt src ls')
+ an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
+ return (Warning an1 lns' txt')
-- ---------------------------------------------------------------------
instance ExactPrint StringLiteral where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (StringLiteral src fs mcomma) = do
+ exact l@(StringLiteral src fs mcomma) = do
printSourceText src (show (unpackFS fs))
- mapM_ (\r -> printStringAtKw' r ",") mcomma
+ mapM_ (\r -> printStringAtRs r ",") mcomma
+ return l
-- ---------------------------------------------------------------------
instance ExactPrint FastString where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
-- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
-- exact fs = printStringAdvance (show (unpackFS fs))
- exact fs = printStringAdvance (unpackFS fs)
+ exact fs = printStringAdvance (unpackFS fs) >> return fs
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecls GhcPs) where
getAnnotationEntry (HsRules (an,_) _) = fromAnn an
+ setAnnotationAnchor (HsRules (an,a) b) anc cs = HsRules ((setAnchorEpa an anc cs),a) b
exact (HsRules (an, src) rules) = do
- case src of
- NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES")
- SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt)
- markAnnotated rules
- markLocatedAALS an id AnnClose (Just "#-}")
- -- markTrailingSemi
+ an0 <-
+ case src of
+ NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES")
+ SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt)
+ rules' <- markAnnotated rules
+ an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")
+ return (HsRules (an1,src) rules')
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecl GhcPs) where
getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an
+ setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc cs
+ = r { rd_ext = (setAnchorEpa an anc cs, a)}
exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do
debugM "HsRule entered"
- markAnnotated (L ln (nsrc, n))
+ (L ln' _) <- markAnnotated (L ln (nsrc, n))
debugM "HsRule after ln"
- markActivation an ra_rest act
+ an0 <- markActivation an lra_rest act
debugM "HsRule after act"
- case mtybndrs of
- Nothing -> return ()
- Just bndrs -> do
- markLocatedMAA an (\a -> fmap fst (ra_tyanns a)) -- AnnForall
- mapM_ markAnnotated bndrs
- markLocatedMAA an (\a -> fmap snd (ra_tyanns a)) -- AnnDot
-
- markLocatedMAA an (\a -> fmap fst (ra_tmanns a)) -- AnnForall
- mapM_ markAnnotated termbndrs
- markLocatedMAA an (\a -> fmap snd (ra_tmanns a)) -- AnnDot
-
- markAnnotated lhs
- markEpAnn' an ra_rest AnnEqual
- markAnnotated rhs
- -- markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do
- -- markLocated ln
- -- setContext (Set.singleton ExplicitNeverActive) $ markActivation l act
-
-
- -- mark GHC.AnnForall
- -- mapM_ markLocated termbndrs
- -- mark GHC.AnnDot
-
- -- markLocated lhs
- -- mark GHC.AnnEqual
- -- markLocated rhs
- -- inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi
- -- markTrailingSemi
-
-markActivation :: EpAnn a -> (a -> [AddEpAnn]) -> Activation -> Annotated ()
-markActivation an fn act = do
+ (an1, mtybndrs') <-
+ case mtybndrs of
+ Nothing -> return (an0, Nothing)
+ Just bndrs -> do
+ an1 <- markLensMAA an0 lra_tyanns_fst -- AnnForall
+ bndrs' <- mapM markAnnotated bndrs
+ an2 <- markLensMAA an1 lra_tyanns_snd -- AnnDot
+ return (an2, Just bndrs')
+
+ an2 <- markLensMAA an1 lra_tmanns_fst -- AnnForall
+ termbndrs' <- mapM markAnnotated termbndrs
+ an3 <- markLensMAA an2 lra_tmanns_snd -- AnnDot
+
+ lhs' <- markAnnotated lhs
+ an4 <- markEpAnnL an3 lra_rest AnnEqual
+ rhs' <- markAnnotated rhs
+ return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs')
+
+markActivation :: (Monad m, Monoid w)
+ => EpAnn a -> Lens a [AddEpAnn] -> Activation -> EP w m (EpAnn a)
+markActivation an l act = do
case act of
ActiveBefore src phase -> do
- markEpAnn' an fn AnnOpenS -- '['
- markEpAnn' an fn AnnTilde -- ~
- markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
- markEpAnn' an fn AnnCloseS -- ']'
+ an0 <- markEpAnnL an l AnnOpenS -- '['
+ an1 <- markEpAnnL an0 l AnnTilde -- ~
+ an2 <- markEpAnnLMS an1 l AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
+ an3 <- markEpAnnL an2 l AnnCloseS -- ']'
+ return an3
ActiveAfter src phase -> do
- markEpAnn' an fn AnnOpenS -- '['
- markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
- markEpAnn' an fn AnnCloseS -- ']'
+ an0 <- markEpAnnL an l AnnOpenS -- '['
+ an1 <- markEpAnnLMS an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
+ an2 <- markEpAnnL an1 l AnnCloseS -- ']'
+ return an2
NeverActive -> do
- markEpAnn' an fn AnnOpenS -- '['
- markEpAnn' an fn AnnTilde -- ~
- markEpAnn' an fn AnnCloseS -- ']'
- _ -> return ()
+ an0 <- markEpAnnL an l AnnOpenS -- '['
+ an1 <- markEpAnnL an0 l AnnTilde -- ~
+ an2 <- markEpAnnL an1 l AnnCloseS -- ']'
+ return an2
+ _ -> return an
-- ---------------------------------------------------------------------
instance ExactPrint (SpliceDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (SpliceDecl _ splice _flag) = do
- markAnnotated splice
+ exact (SpliceDecl x splice flag) = do
+ splice' <- markAnnotated splice
+ return (SpliceDecl x splice' flag)
-- ---------------------------------------------------------------------
instance ExactPrint (DocDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact v = case v of
- (DocCommentNext ds) -> exact ds
- (DocCommentPrev ds) -> exact ds
- (DocCommentNamed _s ds) -> exact ds
- (DocGroup _i ds) -> exact ds
+ (DocCommentNext ds) -> DocCommentNext <$> exact ds
+ (DocCommentPrev ds) -> DocCommentPrev <$> exact ds
+ (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds
+ (DocGroup i ds) -> DocGroup i <$> exact ds
-- ---------------------------------------------------------------------
instance ExactPrint (RoleAnnotDecl GhcPs) where
getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an
+ setAnnotationAnchor (RoleAnnotDecl an a b) anc cs = RoleAnnotDecl (setAnchorEpa an anc cs) a b
exact (RoleAnnotDecl an ltycon roles) = do
- markEpAnn an AnnType
- markEpAnn an AnnRole
- markAnnotated ltycon
- let markRole (L l (Just r)) = markAnnotated (L (locA l) r)
- markRole (L l Nothing) = printStringAtSs (locA l) "_"
- mapM_ markRole roles
+ an0 <- markEpAnnL an lidl AnnType
+ an1 <- markEpAnnL an0 lidl AnnRole
+ ltycon' <- markAnnotated ltycon
+ let markRole (L l (Just r)) = do
+ (L _ r') <- markAnnotated (L l r)
+ return (L l (Just r'))
+ markRole (L l Nothing) = do
+ printStringAtSs (locA l) "_"
+ return (L l Nothing)
+ roles' <- mapM markRole roles
+ return (RoleAnnotDecl an1 ltycon' roles')
-- ---------------------------------------------------------------------
instance ExactPrint Role where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact = withPpr
-- ---------------------------------------------------------------------
instance ExactPrint (RuleBndr GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
-{-
- = RuleBndr (XCRuleBndr pass) (Located (IdP pass))
- | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass)
--}
- exact (RuleBndr _ ln) = markAnnotated ln
- exact (RuleBndrSig an ln (HsPS _ ty)) = do
- markEpAnn an AnnOpenP -- "("
- markAnnotated ln
- markEpAnn an AnnDcolon
- markAnnotated ty
- markEpAnn an AnnCloseP -- ")"
-
--- ---------------------------------------------------------------------
-
--- instance ExactPrint (TyFamInstEqn GhcPs) where
--- instance (ExactPrint body) => ExactPrint (FamInstEqn GhcPs body) where
--- getAnnotationEntry = const NoEntryVal
--- exact (HsIB { hsib_body = FamEqn { feqn_ext = an
--- , feqn_tycon = tycon
--- , feqn_bndrs = bndrs
--- , feqn_pats = pats
--- , feqn_fixity = fixity
--- , feqn_rhs = rhs }}) = do
--- exactHsFamInstLHS an tycon bndrs pats fixity Nothing
--- markEpAnn an AnnEqual
--- markAnnotated rhs
+ exact (RuleBndr x ln) = do
+ ln' <- markAnnotated ln
+ return (RuleBndr x ln')
+ exact (RuleBndrSig an ln (HsPS x ty)) = do
+ an0 <- markEpAnnL an lidl AnnOpenP -- "("
+ ln' <- markAnnotated ln
+ an1 <- markEpAnnL an0 lidl AnnDcolon
+ ty' <- markAnnotated ty
+ an2 <- markEpAnnL an1 lidl AnnCloseP -- ")"
+ return (RuleBndrSig an2 ln' (HsPS x ty'))
+
+-- ---------------------------------------------------------------------
instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where
getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an
+ setAnnotationAnchor fe anc cs = fe {feqn_ext = setAnchorEpa (feqn_ext fe) anc cs}
exact (FamEqn { feqn_ext = an
, feqn_tycon = tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }) = do
- exactHsFamInstLHS an tycon bndrs pats fixity Nothing
- markEpAnn an AnnEqual
- markAnnotated rhs
+ (an0, tycon', bndrs', pats', _) <- exactHsFamInstLHS an tycon bndrs pats fixity Nothing
+ an1 <- markEpAnnL an0 lidl AnnEqual
+ rhs' <- markAnnotated rhs
+ return (FamEqn { feqn_ext = an1
+ , feqn_tycon = tycon'
+ , feqn_bndrs = bndrs'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' })
-- ---------------------------------------------------------------------
exactHsFamInstLHS ::
- EpAnn [AddEpAnn]
+ (Monad m, Monoid w)
+ => EpAnn [AddEpAnn]
-> LocatedN RdrName
- -- -> Maybe [LHsTyVarBndr () GhcPs]
-> HsOuterTyVarBndrs () GhcPs
-> HsTyPats GhcPs
-> LexicalFixity
-> Maybe (LHsContext GhcPs)
- -> EPP ()
+ -> EP w m ( EpAnn [AddEpAnn]
+ , LocatedN RdrName
+ , HsOuterTyVarBndrs () GhcPs
+ , HsTyPats GhcPs, Maybe (LHsContext GhcPs))
exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do
- markEpAnn an AnnForall
- markAnnotated bndrs
- markEpAnn an AnnDot
- mapM_ markAnnotated mb_ctxt
- exact_pats typats
+ an0 <- markEpAnnL an lidl AnnForall
+ bndrs' <- markAnnotated bndrs
+ an1 <- markEpAnnL an0 lidl AnnDot
+ mb_ctxt' <- mapM markAnnotated mb_ctxt
+ (an2, thing', typats') <- exact_pats an1 typats
+ return (an2, thing', bndrs', typats', mb_ctxt')
where
- exact_pats :: HsTyPats GhcPs -> EPP ()
- exact_pats (patl:patr:pats)
+ exact_pats :: (Monad m, Monoid w)
+ => EpAnn [AddEpAnn] -> HsTyPats GhcPs -> EP w m (EpAnn [AddEpAnn], LocatedN RdrName, HsTyPats GhcPs)
+ exact_pats an' (patl:patr:pats)
| Infix <- fixity
= let exact_op_app = do
- markAnnotated patl
- markAnnotated thing
- markAnnotated patr
+ an0 <- markEpAnnAllL an' lidl AnnOpenP
+ patl' <- markAnnotated patl
+ thing' <- markAnnotated thing
+ patr' <- markAnnotated patr
+ an1 <- markEpAnnAllL an0 lidl AnnCloseP
+ return (an1, thing', [patl',patr'])
in case pats of
[] -> exact_op_app
_ -> do
- markEpAnn an AnnOpenP
- exact_op_app
- markEpAnn an AnnCloseP
- mapM_ markAnnotated pats
+ (an0, thing', p) <- exact_op_app
+ pats' <- mapM markAnnotated pats
+ return (an0, thing', p++pats')
- exact_pats pats = do
- markAnnAll (epAnnAnns an) AnnOpenP
- markAnnotated thing
- markAnnotated pats
- markAnnAll (epAnnAnns an) AnnCloseP
+ exact_pats an' pats = do
+ an0 <- markEpAnnAllL an' lidl AnnOpenP
+ thing' <- markAnnotated thing
+ pats' <- markAnnotated pats
+ an1 <- markEpAnnAllL an0 lidl AnnCloseP
+ return (an1, thing', pats')
-- ---------------------------------------------------------------------
--- instance ExactPrint (LHsTypeArg GhcPs) where
instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)
=> ExactPrint (HsArg tm ty) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (HsValArg tm) = markAnnotated tm
- exact (HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty
+ exact a@(HsValArg tm) = markAnnotated tm >> return a
+ exact a@(HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty >> return a
exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source
-- ---------------------------------------------------------------------
instance ExactPrint (ClsInstDecl GhcPs) where
getAnnotationEntry cid = fromAnn (fst $ cid_ext cid)
+ setAnnotationAnchor cid anc cs
+ = cid { cid_ext = (setAnchorEpa (fst $ cid_ext cid) anc cs, (snd $ cid_ext cid)) }
exact (ClsInstDecl { cid_ext = (an, sortKey)
, cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
, cid_datafam_insts = adts })
- | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part
- = top_matter
-
- | otherwise -- Laid out
= do
- top_matter
- markEpAnn an AnnWhere
- markEpAnn an AnnOpenC
- markEpAnnAll an id AnnSemi
- -- = vcat [ top_matter <+> text "where"
- -- , nest 2 $ pprDeclList $
- -- map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++
- -- map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
- -- pprLHsBindsForUser binds sigs ]
- withSortKey sortKey
+ (an0, mbOverlap', inst_ty') <- top_matter
+ an1 <- markEpAnnL an0 lidl AnnOpenC
+ an2 <- markEpAnnAllL an1 lid AnnSemi
+ ds <- withSortKey sortKey
(prepareListAnnotationA ats
- ++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts
+ ++ prepareListAnnotationF an adts
++ prepareListAnnotationA (bagToList binds)
++ prepareListAnnotationA sigs
)
- markEpAnn an AnnCloseC -- '}'
+ an3 <- markEpAnnL an2 lidl AnnCloseC -- '}'
+ let
+ ats' = undynamic ds
+ adts' = undynamic ds
+ binds' = listToBag $ undynamic ds
+ sigs' = undynamic ds
+ return (ClsInstDecl { cid_ext = (an3, sortKey)
+ , cid_poly_ty = inst_ty', cid_binds = binds'
+ , cid_sigs = sigs', cid_tyfam_insts = ats'
+ , cid_overlap_mode = mbOverlap'
+ , cid_datafam_insts = adts' })
where
top_matter = do
- markEpAnn an AnnInstance
- mapM_ markAnnotated mbOverlap
- markAnnotated inst_ty
- markEpAnn an AnnWhere -- Optional
- -- text "instance" <+> ppOverlapPragma mbOverlap
- -- <+> ppr inst_ty
+ an0 <- markEpAnnL an lidl AnnInstance
+ mo <- mapM markAnnotated mbOverlap
+ it <- markAnnotated inst_ty
+ an1 <- markEpAnnL an0 lidl AnnWhere -- Optional
+ return (an1, mo,it)
-- ---------------------------------------------------------------------
instance ExactPrint (TyFamInstDecl GhcPs) where
getAnnotationEntry (TyFamInstDecl an _) = fromAnn an
- exact d@(TyFamInstDecl _an _eqn) =
- exactTyFamInstDecl TopLevel d
-
--- ---------------------------------------------------------------------
+ setAnnotationAnchor (TyFamInstDecl an a) anc cs = TyFamInstDecl (setAnchorEpa an anc cs) a
--- instance (ExactPrint body) => ExactPrint (HsImplicitBndrs GhcPs body) where
--- getAnnotationEntry (HsIB an _) = fromAnn an
--- exact (HsIB an t) = markAnnotated t
+ exact d@(TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do
+ an0 <- markEpAnnL an lidl AnnType
+ an1 <- markEpAnnL an0 lidl AnnInstance
+ eqn' <- markAnnotated eqn
+ return (d { tfid_xtn = an1, tfid_eqn = eqn' })
-- ---------------------------------------------------------------------
instance ExactPrint (LocatedP OverlapMode) where
getAnnotationEntry = entryFromLocatedA
+ setAnnotationAnchor = setAnchorAn
-- NOTE: NoOverlap is only used in the typechecker
- exact (L (SrcSpanAnn an _) (NoOverlap src)) = do
- markAnnOpenP an src "{-# NO_OVERLAP"
- markAnnCloseP an
+ exact (L (SrcSpanAnn an l) (NoOverlap src)) = do
+ an0 <- markAnnOpenP an src "{-# NO_OVERLAP"
+ an1 <- markAnnCloseP an0
+ return (L (SrcSpanAnn an1 l) (NoOverlap src))
- exact (L (SrcSpanAnn an _) (Overlappable src)) = do
- markAnnOpenP an src "{-# OVERLAPPABLE"
- markAnnCloseP an
+ exact (L (SrcSpanAnn an l) (Overlappable src)) = do
+ an0 <- markAnnOpenP an src "{-# OVERLAPPABLE"
+ an1 <- markAnnCloseP an0
+ return (L (SrcSpanAnn an1 l) (Overlappable src))
- exact (L (SrcSpanAnn an _) (Overlapping src)) = do
- markAnnOpenP an src "{-# OVERLAPPING"
- markAnnCloseP an
+ exact (L (SrcSpanAnn an l) (Overlapping src)) = do
+ an0 <- markAnnOpenP an src "{-# OVERLAPPING"
+ an1 <- markAnnCloseP an0
+ return (L (SrcSpanAnn an1 l) (Overlapping src))
- exact (L (SrcSpanAnn an _) (Overlaps src)) = do
- markAnnOpenP an src "{-# OVERLAPS"
- markAnnCloseP an
+ exact (L (SrcSpanAnn an l) (Overlaps src)) = do
+ an0 <- markAnnOpenP an src "{-# OVERLAPS"
+ an1 <- markAnnCloseP an0
+ return (L (SrcSpanAnn an1 l) (Overlaps src))
- exact (L (SrcSpanAnn an _) (Incoherent src)) = do
- markAnnOpenP an src "{-# INCOHERENT"
- markAnnCloseP an
+ exact (L (SrcSpanAnn an l) (Incoherent src)) = do
+ an0 <- markAnnOpenP an src "{-# INCOHERENT"
+ an1 <- markAnnCloseP an0
+ return (L (SrcSpanAnn an1 l) (Incoherent src))
-- ---------------------------------------------------------------------
instance ExactPrint (HsBind GhcPs) where
getAnnotationEntry FunBind{} = NoEntryVal
- getAnnotationEntry PatBind{} = NoEntryVal
+ getAnnotationEntry PatBind{pat_ext=an} = fromAnn an
getAnnotationEntry VarBind{} = NoEntryVal
getAnnotationEntry PatSynBind{} = NoEntryVal
- exact (FunBind _ _ matches) = do
- markAnnotated matches
- exact (PatBind _ pat grhss) = do
- markAnnotated pat
- markAnnotated grhss
- exact (PatSynBind _ bind) = markAnnotated bind
+ setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs}
+ setAnnotationAnchor a _ _ = a
+
+ exact (FunBind x fid matches) = do
+ matches' <- markAnnotated matches
+ let
+ fun_id' = case unLoc (mg_alts matches') of
+ [] -> fid
+ (L _ m:_) -> case m_ctxt m of
+ FunRhs f _ _ -> f
+ _ -> fid
+ return (FunBind x fun_id' matches')
+
+ exact (PatBind x pat grhss) = do
+ pat' <- markAnnotated pat
+ grhss' <- markAnnotated grhss
+ return (PatBind x pat' grhss')
+ exact (PatSynBind x bind) = do
+ bind' <- markAnnotated bind
+ return (PatSynBind x bind')
exact x = error $ "HsBind: exact for " ++ showAst x
@@ -1324,182 +2119,163 @@ instance ExactPrint (HsBind GhcPs) where
instance ExactPrint (PatSynBind GhcPs GhcPs) where
getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an
+ setAnnotationAnchor p anc cs = p { psb_ext = setAnchorEpa (psb_ext p) anc cs}
exact (PSB{ psb_ext = an
, psb_id = psyn, psb_args = details
, psb_def = pat
, psb_dir = dir }) = do
- markEpAnn an AnnPattern
- case details of
- InfixCon v1 v2 -> do
- markAnnotated v1
- markAnnotated psyn
- markAnnotated v2
- PrefixCon tvs vs -> do
- markAnnotated psyn
- markAnnotated tvs
- markAnnotated vs
- RecCon vs -> do
- markAnnotated psyn
- markEpAnn an AnnOpenC -- '{'
- markAnnotated vs
- markEpAnn an AnnCloseC -- '}'
-
- case dir of
- Unidirectional -> do
- markEpAnn an AnnLarrow
- markAnnotated pat
- ImplicitBidirectional -> do
- markEpAnn an AnnEqual
- markAnnotated pat
- ExplicitBidirectional mg -> do
- markEpAnn an AnnLarrow
- markAnnotated pat
- markEpAnn an AnnWhere
- markAnnotated mg
-
- -- case dir of
- -- GHC.ImplicitBidirectional -> mark GHC.AnnEqual
- -- _ -> mark GHC.AnnLarrow
-
- -- markLocated def
- -- case dir of
- -- GHC.Unidirectional -> return ()
- -- GHC.ImplicitBidirectional -> return ()
- -- GHC.ExplicitBidirectional mg -> do
- -- mark GHC.AnnWhere
- -- mark GHC.AnnOpenC -- '{'
- -- markMatchGroup l mg
- -- mark GHC.AnnCloseC -- '}'
-
- -- markTrailingSemi
+ an0 <- markEpAnnL an lidl AnnPattern
+ (an1, psyn', details') <-
+ case details of
+ InfixCon v1 v2 -> do
+ v1' <- markAnnotated v1
+ psyn' <- markAnnotated psyn
+ v2' <- markAnnotated v2
+ return (an0, psyn',InfixCon v1' v2')
+ PrefixCon tvs vs -> do
+ psyn' <- markAnnotated psyn
+ tvs' <- markAnnotated tvs
+ vs' <- markAnnotated vs
+ return (an0, psyn', PrefixCon tvs' vs')
+ RecCon vs -> do
+ psyn' <- markAnnotated psyn
+ an1 <- markEpAnnL an0 lidl AnnOpenC -- '{'
+ vs' <- markAnnotated vs
+ an2 <- markEpAnnL an1 lidl AnnCloseC -- '}'
+ return (an2, psyn', RecCon vs')
+
+ (an2, pat', dir') <-
+ case dir of
+ Unidirectional -> do
+ an2 <- markEpAnnL an1 lidl AnnLarrow
+ pat' <- markAnnotated pat
+ return (an2, pat', dir)
+ ImplicitBidirectional -> do
+ an2 <- markEpAnnL an1 lidl AnnEqual
+ pat' <- markAnnotated pat
+ return (an2, pat', dir)
+ ExplicitBidirectional mg -> do
+ an2 <- markEpAnnL an1 lidl AnnLarrow
+ pat' <- markAnnotated pat
+ an3 <- markEpAnnL an2 lidl AnnWhere
+ mg' <- markAnnotated mg
+ return (an3, pat', ExplicitBidirectional mg')
+
+ return (PSB{ psb_ext = an2
+ , psb_id = psyn', psb_args = details'
+ , psb_def = pat'
+ , psb_dir = dir' })
-- ---------------------------------------------------------------------
instance ExactPrint (RecordPatSynField GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (RecordPatSynField { recordPatSynField = v }) = markAnnotated v
+ setAnnotationAnchor a _ _ = a
+ exact r@(RecordPatSynField { recordPatSynField = v }) = markAnnotated v
+ >> return r
-- ---------------------------------------------------------------------
instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (Match ann _ _ _) = fromAnn ann
+ setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c
- -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match
- exact (Match an mctxt pats grhss) = do
+ exact (Match an mctxt pats grhss) =
exactMatch (Match an mctxt pats grhss)
-- -------------------------------------
instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (Match ann _ _ _) = fromAnn ann
+ setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c
- -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match
- exact (Match an mctxt pats grhss) = do
+ exact (Match an mctxt pats grhss) =
exactMatch (Match an mctxt pats grhss)
- -- -- Based on Expr.pprMatch
-
- -- debugM $ "exact Match entered"
-
- -- -- herald
- -- case mctxt of
- -- FunRhs fun fixity strictness -> do
- -- debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun
- -- case strictness of
- -- SrcStrict -> markEpAnn an AnnBang
- -- _ -> pure ()
- -- case fixity of
- -- Prefix -> do
- -- markAnnotated fun
- -- mapM_ markAnnotated pats
- -- Infix ->
- -- case pats of
- -- (p1:p2:rest)
- -- | null rest -> do
- -- markAnnotated p1
- -- markAnnotated fun
- -- markAnnotated p2
- -- | otherwise -> do
- -- markEpAnn an AnnOpenP
- -- markAnnotated p1
- -- markAnnotated fun
- -- markAnnotated p2
- -- markEpAnn an AnnCloseP
- -- mapM_ markAnnotated rest
- -- LambdaExpr -> do
- -- markEpAnn an AnnLam
- -- mapM_ markAnnotated pats
- -- CaseAlt -> do
- -- mapM_ markAnnotated pats
- -- LamCaseAlt _ ->
- -- mapM_ markAnnotated pats
- -- _ -> withPpr mctxt
-
- -- markAnnotated grhss
-
--- ---------------------------------------------------------------------
-
-exactMatch :: (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> Annotated ()
+
+-- ---------------------------------------------------------------------
+
+exactMatch :: (Monad m, Monoid w) => (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> EP w m (Match GhcPs body)
exactMatch (Match an mctxt pats grhss) = do
--- Based on Expr.pprMatch
debugM $ "exact Match entered"
- -- herald
- case mctxt of
- FunRhs fun fixity strictness -> do
- debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun
- case strictness of
- SrcStrict -> markEpAnn an AnnBang
- _ -> pure ()
- case fixity of
- Prefix -> do
- annotationsToCommentsA an [AnnOpenP,AnnCloseP]
- markAnnotated fun
- markAnnotated pats
- Infix ->
- case pats of
- (p1:p2:rest)
- | null rest -> do
- markAnnotated p1
- markAnnotated fun
- markAnnotated p2
- | otherwise -> do
- markEpAnn an AnnOpenP
- markAnnotated p1
- markAnnotated fun
- markAnnotated p2
- markEpAnn an AnnCloseP
- mapM_ markAnnotated rest
- _ -> panic "FunRhs"
- LambdaExpr -> do
- markEpAnn an AnnLam
- markAnnotated pats
- CaseAlt -> do
- markAnnotated pats
- LamCaseAlt _ -> do
- markAnnotated pats
- _ -> withPpr mctxt
-
- markAnnotated grhss
+ (an0, mctxt', pats') <-
+ case mctxt of
+ FunRhs fun fixity strictness -> do
+ debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun
+ an0' <-
+ case strictness of
+ SrcStrict -> markEpAnnL an lidl AnnBang
+ _ -> pure an
+ case fixity of
+ Prefix -> do
+ an' <- annotationsToComments an0' lidl [AnnOpenP,AnnCloseP]
+ fun' <- markAnnotated fun
+ pats' <- markAnnotated pats
+ return (an', FunRhs fun' fixity strictness, pats')
+ Infix ->
+ case pats of
+ (p1:p2:rest)
+ | null rest -> do
+ p1' <- markAnnotated p1
+ fun' <- markAnnotated fun
+ p2' <- markAnnotated p2
+ return (an0', FunRhs fun' fixity strictness, [p1',p2'])
+ | otherwise -> do
+ an0 <- markEpAnnL an0' lidl AnnOpenP
+ p1' <- markAnnotated p1
+ fun' <- markAnnotated fun
+ p2' <- markAnnotated p2
+ an1 <- markEpAnnL an0 lidl AnnCloseP
+ rest' <- mapM markAnnotated rest
+ return (an1, FunRhs fun' fixity strictness, p1':p2':rest')
+ _ -> panic "FunRhs"
+ LambdaExpr -> do
+ an0' <- markEpAnnL an lidl AnnLam
+ pats' <- markAnnotated pats
+ return (an0', LambdaExpr, pats')
+ CaseAlt -> do
+ pats' <- markAnnotated pats
+ return (an, CaseAlt, pats')
+ LamCaseAlt v -> do
+ pats' <- markAnnotated pats
+ return (an, LamCaseAlt v, pats')
+ _ -> do
+ mctxt' <- withPpr mctxt
+ return (an, mctxt', pats)
+
+ grhss' <- markAnnotated grhss
+
+ return (Match an0 mctxt' pats' grhss')
-- ---------------------------------------------------------------------
instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (GRHSs _ grhss binds) = do
- markAnnotated grhss
- markAnnotated binds
+ exact (GRHSs cs grhss binds) = do
+ addCommentsA $ priorComments cs
+ addCommentsA $ getFollowingComments cs
+ grhss' <- markAnnotated grhss
+ binds' <- markAnnotated binds
+ -- The comments will be added back as they are printed
+ return (GRHSs emptyComments grhss' binds')
instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (GRHSs _an grhss binds) = do
- markAnnotated grhss
- markAnnotated binds
+ exact (GRHSs cs grhss binds) = do
+ addCommentsA $ priorComments cs
+ addCommentsA $ getFollowingComments cs
+ grhss' <- markAnnotated grhss
+ binds' <- markAnnotated binds
+ -- The comments will be added back as they are printed
+ return (GRHSs emptyComments grhss' binds')
-- ---------------------------------------------------------------------
@@ -1508,8 +2284,13 @@ instance ExactPrint (HsLocalBinds GhcPs) where
getAnnotationEntry (HsIPBinds{}) = NoEntryVal
getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal
+ setAnnotationAnchor (HsValBinds an a) anc cs = HsValBinds (setAnchorEpaL an anc cs) a
+ setAnnotationAnchor a _ _ = a
+
exact (HsValBinds an valbinds) = do
- markLocatedAAL an al_rest AnnWhere
+ debugM $ "exact HsValBinds: an=" ++ showAst an
+ an0 <- markEpAnnL an lal_rest AnnWhere
+
let manc = case an of
EpAnnNotUsed -> Nothing
_ -> al_anchor $ anns an
@@ -1519,60 +2300,88 @@ instance ExactPrint (HsLocalBinds GhcPs) where
when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc)
_ -> return ()
- markAnnList False an $ markAnnotatedWithLayout valbinds
+ (an1, valbinds') <- markAnnList False an0 $ markAnnotatedWithLayout valbinds
+ debugM $ "exact HsValBinds: an1=" ++ showAst an1
+ return (HsValBinds an1 valbinds')
- exact (HsIPBinds an bs)
- = markAnnList True an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs)
- exact (EmptyLocalBinds _) = return ()
+ exact (HsIPBinds an bs) = do
+ (as, ipb) <- markAnnList True an (markEpAnnL an lal_rest AnnWhere
+ >> markAnnotated bs
+ >>= \bs' -> return (HsIPBinds an bs'::HsLocalBinds GhcPs))
+ case ipb of
+ HsIPBinds _ bs' -> return (HsIPBinds as bs'::HsLocalBinds GhcPs)
+ _ -> error "should not happen HsIPBinds"
+ exact b@(EmptyLocalBinds _) = return b
-- ---------------------------------------------------------------------
instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact (ValBinds sortKey binds sigs) = do
- setLayoutBoth $ withSortKey sortKey
+ ds <- setLayoutBoth $ withSortKey sortKey
(prepareListAnnotationA (bagToList binds)
++ prepareListAnnotationA sigs
)
+ let
+ binds' = listToBag $ undynamic ds
+ sigs' = undynamic ds
+ return (ValBinds sortKey binds' sigs')
exact (XValBindsLR _) = panic "XValBindsLR"
+undynamic :: Typeable a => [Dynamic] -> [a]
+undynamic ds = mapMaybe fromDynamic ds
+
-- ---------------------------------------------------------------------
instance ExactPrint (HsIPBinds GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (IPBinds _ binds) = setLayoutBoth $ markAnnotated binds
+ exact b@(IPBinds _ binds) = setLayoutBoth $ markAnnotated binds >> return b
-- ---------------------------------------------------------------------
instance ExactPrint (IPBind GhcPs) where
getAnnotationEntry (IPBind an _ _) = fromAnn an
+ setAnnotationAnchor (IPBind an a b) anc cs = IPBind (setAnchorEpa an anc cs) a b
exact (IPBind an lr rhs) = do
- markAnnotated lr
- markEpAnn an AnnEqual
- markAnnotated rhs
+ lr' <- markAnnotated lr
+ an0 <- markEpAnnL an lidl AnnEqual
+ rhs' <- markAnnotated rhs
+ return (IPBind an0 lr' rhs')
+
-- ---------------------------------------------------------------------
instance ExactPrint HsIPName where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs))
+ exact i@(HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) >> return i
-- ---------------------------------------------------------------------
-- Managing lists which have been separated, e.g. Sigs and Binds
-prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())]
-prepareListAnnotationF f ls
- = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls
+prepareListAnnotationF :: (Monad m, Monoid w) =>
+ EpAnn [AddEpAnn] -> [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)]
+prepareListAnnotationF an ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls
+ where
+ go (L l a) = do
+ d' <- markAnnotated (DataFamInstDeclWithContext an NotTopLevel a)
+ return (toDyn (L l (dc_d d')))
-prepareListAnnotationA :: ExactPrint (LocatedAn an a)
- => [LocatedAn an a] -> [(RealSrcSpan,EPP ())]
-prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls
+prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
+ => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)]
+prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls
+ where
+ go b = do
+ b' <- markAnnotated b
+ return (toDyn b')
-withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP ()
+withSortKey :: (Monad m, Monoid w) => AnnSortKey -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
withSortKey annSortKey xs = do
debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
let ordered = case annSortKey of
@@ -1584,7 +2393,7 @@ withSortKey annSortKey xs = do
-- map fst xs,
-- keys)
-- )
- mapM_ snd ordered
+ mapM snd ordered
orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering
orderByFst (a,_) (b,_) = compare a b
@@ -1603,222 +2412,217 @@ instance ExactPrint (Sig GhcPs) where
getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a
getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a
--- instance Annotate (Sig GhcPs) where
-
- exact (TypeSig an vars ty) = exactVarSig an vars ty
+ setAnnotationAnchor (TypeSig a x y) anc cs = (TypeSig (setAnchorEpa a anc cs) x y)
+ setAnnotationAnchor (PatSynSig a x y) anc cs = (PatSynSig (setAnchorEpa a anc cs) x y)
+ setAnnotationAnchor (ClassOpSig a x y z) anc cs = (ClassOpSig (setAnchorEpa a anc cs) x y z)
+ setAnnotationAnchor (FixSig a x) anc cs = (FixSig (setAnchorEpa a anc cs) x)
+ setAnnotationAnchor (InlineSig a x y) anc cs = (InlineSig (setAnchorEpa a anc cs) x y)
+ setAnnotationAnchor (SpecSig a x y z) anc cs = (SpecSig (setAnchorEpa a anc cs) x y z)
+ setAnnotationAnchor (SpecInstSig (a,x) y) anc cs = (SpecInstSig ((setAnchorEpa a anc cs),x) y)
+ setAnnotationAnchor (MinimalSig (a,x) y) anc cs = (MinimalSig ((setAnchorEpa a anc cs),x) y)
+ setAnnotationAnchor (SCCFunSig (a,x) y z) anc cs = (SCCFunSig ((setAnchorEpa a anc cs),x) y z)
+ setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc cs = (CompleteMatchSig ((setAnchorEpa a anc cs),x) y z)
+
+ exact (TypeSig an vars ty) = do
+ (an', vars', ty') <- exactVarSig an vars ty
+ return (TypeSig an' vars' ty')
exact (PatSynSig an lns typ) = do
- markLocatedAAL an asRest AnnPattern
- markAnnotated lns
- markLocatedAA an asDcolon
- markAnnotated typ
+ an0 <- markEpAnnL an lasRest AnnPattern
+ lns' <- markAnnotated lns
+ an1 <- markLensAA an0 lasDcolon
+ typ' <- markAnnotated typ
+ return (PatSynSig an1 lns' typ')
exact (ClassOpSig an is_deflt vars ty)
- | is_deflt = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty
- | otherwise = exactVarSig an vars ty
-
- exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do
+ | is_deflt = do
+ an0 <- markEpAnnL an lasRest AnnDefault
+ (an1, vars',ty') <- exactVarSig an0 vars ty
+ return (ClassOpSig an1 is_deflt vars' ty')
+ | otherwise = do
+ (an0, vars',ty') <- exactVarSig an vars ty
+ return (ClassOpSig an0 is_deflt vars' ty')
+
+ exact (FixSig an (FixitySig x names (Fixity src v fdir))) = do
let fixstr = case fdir of
InfixL -> "infixl"
InfixR -> "infixr"
InfixN -> "infix"
- markLocatedAALS an id AnnInfix (Just fixstr)
--- markSourceText src (show v)
- markLocatedAALS an id AnnVal (Just (sourceTextToString src (show v)))
- markAnnotated names
-
+ an0 <- markEpAnnLMS an lidl AnnInfix (Just fixstr)
+ an1 <- markEpAnnLMS an0 lidl AnnVal (Just (sourceTextToString src (show v)))
+ names' <- markAnnotated names
+ return (FixSig an1 (FixitySig x names' (Fixity src v fdir)))
exact (InlineSig an ln inl) = do
- markAnnOpen an (inl_src inl) "{-# INLINE"
- -- markActivation l (inl_act inl)
- markActivation an id (inl_act inl)
- markAnnotated ln
- -- markWithString AnnClose "#-}" -- '#-}'
+ an0 <- markAnnOpen an (inl_src inl) "{-# INLINE"
+ an1 <- markActivation an0 id (inl_act inl)
+ ln' <- markAnnotated ln
debugM $ "InlineSig:an=" ++ showAst an
p <- getPosP
debugM $ "InlineSig: p=" ++ show p
- markLocatedAALS an id AnnClose (Just "#-}")
+ an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}")
debugM $ "InlineSig:done"
+ return (InlineSig an2 ln' inl)
exact (SpecSig an ln typs inl) = do
- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
- markActivation an id (inl_act inl)
- markAnnotated ln
- markEpAnn an AnnDcolon
- markAnnotated typs
- markLocatedAALS an id AnnClose (Just "#-}")
-
- exact (SpecInstSig (an, src) typ) = do
- markAnnOpen an src "{-# SPECIALISE"
- markEpAnn an AnnInstance
- markAnnotated typ
- markLocatedAALS an id AnnClose (Just "#-}")
-
--- markAST _ (SpecInstSig _ src typ) = do
--- markAnnOpen src "{-# SPECIALISE"
--- mark AnnInstance
--- markLHsSigType typ
--- markWithString AnnClose "#-}" -- '#-}'
--- markTrailingSemi
-
- exact (MinimalSig (an, src) formula) = do
- markAnnOpen an src "{-# MINIMAL"
- markAnnotated formula
- markLocatedAALS an id AnnClose (Just "#-}")
-
--- markAST _ (MinimalSig _ src formula) = do
--- markAnnOpen src "{-# MINIMAL"
--- markLocated formula
--- markWithString AnnClose "#-}"
--- markTrailingSemi
-
- exact (SCCFunSig (an, src) ln ml) = do
- markAnnOpen an src "{-# SCC"
- markAnnotated ln
- markAnnotated ml
- markLocatedAALS an id AnnClose (Just "#-}")
-
- exact (CompleteMatchSig (an, src) cs mty) = do
- markAnnOpen an src "{-# COMPLETE"
- markAnnotated cs
- case mty of
- Nothing -> return ()
- Just ty -> do
- markEpAnn an AnnDcolon
- markAnnotated ty
- markLocatedAALS an id AnnClose (Just "#-}")
-
--- ---------------------------------------------------------------------
-
-exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP ()
+ an0 <- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ an1 <- markActivation an0 lidl (inl_act inl)
+ ln' <- markAnnotated ln
+ an2 <- markEpAnnL an1 lidl AnnDcolon
+ typs' <- markAnnotated typs
+ an3 <- markEpAnnLMS an2 lidl AnnClose (Just "#-}")
+ return (SpecSig an3 ln' typs' inl)
+
+ exact (SpecInstSig (an,src) typ) = do
+ an0 <- markAnnOpen an src "{-# SPECIALISE"
+ an1 <- markEpAnnL an0 lidl AnnInstance
+ typ' <- markAnnotated typ
+ an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}")
+ return (SpecInstSig (an2,src) typ')
+
+ exact (MinimalSig (an,src) formula) = do
+ an0 <- markAnnOpen an src "{-# MINIMAL"
+ formula' <- markAnnotated formula
+ an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")
+ return (MinimalSig (an1,src) formula')
+
+ exact (SCCFunSig (an,src) ln ml) = do
+ an0 <- markAnnOpen an src "{-# SCC"
+ ln' <- markAnnotated ln
+ ml' <- markAnnotated ml
+ an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")
+ return (SCCFunSig (an1,src) ln' ml')
+
+ exact (CompleteMatchSig (an,src) cs mty) = do
+ an0 <- markAnnOpen an src "{-# COMPLETE"
+ cs' <- markAnnotated cs
+ (an1, mty') <-
+ case mty of
+ Nothing -> return (an0, mty)
+ Just ty -> do
+ an1 <- markEpAnnL an0 lidl AnnDcolon
+ ty' <- markAnnotated ty
+ return (an1, Just ty')
+ an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}")
+ return (CompleteMatchSig (an2,src) cs' mty')
+
+-- ---------------------------------------------------------------------
+
+exactVarSig :: (Monad m, Monoid w, ExactPrint a)
+ => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EP w m (EpAnn AnnSig, [LocatedN RdrName], a)
exactVarSig an vars ty = do
- mapM_ markAnnotated vars
- markLocatedAA an asDcolon
- markAnnotated ty
-
--- ---------------------------------------------------------------------
+ vars' <- mapM markAnnotated vars
+ an0 <- markLensAA an lasDcolon
+ ty' <- markAnnotated ty
+ return (an0, vars', ty')
--- instance ExactPrint (FixitySig GhcPs) where
--- getAnnotationEntry = const NoEntryVal
-
--- exact (FixitySig an names (Fixity src v fdir)) = do
--- let fixstr = case fdir of
--- InfixL -> "infixl"
--- InfixR -> "infixr"
--- InfixN -> "infix"
--- markAnnotated names
--- markLocatedAALS an id AnnInfix (Just fixstr)
--- -- markAST _ (FixSig _ (FixitySig _ lns (Fixity src v fdir))) = do
--- -- let fixstr = case fdir of
--- -- InfixL -> "infixl"
--- -- InfixR -> "infixr"
--- -- InfixN -> "infix"
--- -- markWithString AnnInfix fixstr
--- -- markSourceText src (show v)
--- -- setContext (Set.singleton InfixOp) $ markListIntercalate lns
--- -- markTrailingSemi
-- ---------------------------------------------------------------------
instance ExactPrint (StandaloneKindSig GhcPs) where
getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an
+ setAnnotationAnchor (StandaloneKindSig an a b) anc cs = StandaloneKindSig (setAnchorEpa an anc cs) a b
exact (StandaloneKindSig an vars sig) = do
- markEpAnn an AnnType
- markAnnotated vars
- markEpAnn an AnnDcolon
- markAnnotated sig
+ an0 <- markEpAnnL an lidl AnnType
+ vars' <- markAnnotated vars
+ an1 <- markEpAnnL an0 lidl AnnDcolon
+ sig' <- markAnnotated sig
+ return (StandaloneKindSig an1 vars' sig')
-- ---------------------------------------------------------------------
instance ExactPrint (DefaultDecl GhcPs) where
getAnnotationEntry (DefaultDecl an _) = fromAnn an
+ setAnnotationAnchor (DefaultDecl an a) anc cs = DefaultDecl (setAnchorEpa an anc cs) a
exact (DefaultDecl an tys) = do
- markEpAnn an AnnDefault
- markEpAnn an AnnOpenP
- markAnnotated tys
- markEpAnn an AnnCloseP
+ an0 <- markEpAnnL an lidl AnnDefault
+ an1 <- markEpAnnL an0 lidl AnnOpenP
+ tys' <- markAnnotated tys
+ an2 <- markEpAnnL an1 lidl AnnCloseP
+ return (DefaultDecl an2 tys')
-- ---------------------------------------------------------------------
instance ExactPrint (AnnDecl GhcPs) where
getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an
+ setAnnotationAnchor (HsAnnotation (an,a) b c) anc cs = HsAnnotation ((setAnchorEpa an anc cs),a) b c
exact (HsAnnotation (an, src) prov e) = do
- markAnnOpenP an src "{-# ANN"
- case prov of
- (ValueAnnProvenance n) -> markAnnotated n
- (TypeAnnProvenance n) -> do
- markLocatedAAL an apr_rest AnnType
- markAnnotated n
- ModuleAnnProvenance -> markLocatedAAL an apr_rest AnnModule
-
- markAnnotated e
- markAnnCloseP an
+ an0 <- markAnnOpenP an src "{-# ANN"
+ (an1, prov') <-
+ case prov of
+ (ValueAnnProvenance n) -> do
+ n' <- markAnnotated n
+ return (an0, ValueAnnProvenance n')
+ (TypeAnnProvenance n) -> do
+ an1 <- markEpAnnL an0 lapr_rest AnnType
+ n' <- markAnnotated n
+ return (an1, TypeAnnProvenance n')
+ ModuleAnnProvenance -> do
+ an1 <- markEpAnnL an lapr_rest AnnModule
+ return (an1, prov)
+
+ e' <- markAnnotated e
+ an2 <- markAnnCloseP an1
+ return (HsAnnotation (an2,src) prov' e')
-- ---------------------------------------------------------------------
instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact (BF.Var x) = do
- markAnnotated x
- exact (BF.Or ls) = markAnnotated ls
+ x' <- markAnnotated x
+ return (BF.Var x')
+ exact (BF.Or ls) = do
+ ls' <- markAnnotated ls
+ return (BF.Or ls')
exact (BF.And ls) = do
- markAnnotated ls
+ ls' <- markAnnotated ls
+ return (BF.And ls')
exact (BF.Parens x) = do
- -- mark AnnOpenP -- '('
- markAnnotated x
- -- mark AnnCloseP -- ')'
-
--- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
--- markAST _ (GHC.Var x) = do
--- setContext (Set.singleton PrefixOp) $ markLocated x
--- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
--- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
--- markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls
--- markAST _ (GHC.And ls) = do
--- markListIntercalateWithFunLevel markLocated 2 ls
--- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
--- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
--- markAST _ (GHC.Parens x) = do
--- mark GHC.AnnOpenP -- '('
--- markLocated x
--- mark GHC.AnnCloseP -- ')'
--- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
--- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
-
--- ---------------------------------------------------------------------
-
--- instance ExactPrint (LHsSigWcType GhcPs) where
--- instance ExactPrint (HsWildCardBndrs GhcPs (LHsSigType GhcPs)) where
+ x' <- markAnnotated x
+ return (BF.Parens x')
+
+-- ---------------------------------------------------------------------
+
instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where
getAnnotationEntry = const NoEntryVal
- exact (HsWC _ ty) = markAnnotated ty
+ setAnnotationAnchor a _ _ = a
+ exact (HsWC x ty) = do
+ ty' <- markAnnotated ty
+ return (HsWC x ty')
-- ---------------------------------------------------------------------
instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry (GRHS an _ _) = fromAnn an
+ setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b
exact (GRHS an guards expr) = do
debugM $ "GRHS comments:" ++ showGhc (comments an)
- markAnnKwM an ga_vbar AnnVbar
- markAnnotated guards
+ an0 <- if null guards
+ then return an
+ else markLensKwM an lga_vbar AnnVbar
+ guards' <- markAnnotated guards
debugM $ "GRHS before matchSeparator"
- markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs
+ an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs
debugM $ "GRHS after matchSeparator"
- markAnnotated expr
- -- markLocatedAA an ga_sep
+ expr' <- markAnnotated expr
+ return (GRHS an1 guards' expr')
instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry (GRHS ann _ _) = fromAnn ann
+ setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b
exact (GRHS an guards expr) = do
- markAnnKwM an ga_vbar AnnVbar
- markAnnotated guards
- markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs
- markAnnotated expr
+ an0 <- markLensKwM an lga_vbar AnnVbar
+ guards' <- markAnnotated guards
+ an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs
+ expr' <- markAnnotated expr
+ return (GRHS an1 guards' expr')
-- ---------------------------------------------------------------------
@@ -1861,302 +2665,364 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsStatic an _) = fromAnn an
getAnnotationEntry (HsPragE{}) = NoEntryVal
-
- exact (HsVar _ n) = markAnnotated n
- exact x@(HsUnboundVar an _v) = do
+ setAnnotationAnchor a@(HsVar{}) _ _s = a
+ setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(HsRecSel{}) _ _s = a
+ setAnnotationAnchor (HsOverLabel an a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsIPVar an a) anc cs = (HsIPVar (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsOverLit an a) anc cs = (HsOverLit (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsLit an a) anc cs = (HsLit (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(HsLam _ _) _ _s = a
+ setAnnotationAnchor (HsLamCase an a b) anc cs = (HsLamCase (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsApp an a b) anc cs = (HsApp (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor a@(HsAppType {}) _ _s = a
+ setAnnotationAnchor (OpApp an a b c) anc cs = (OpApp (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (NegApp an a b) anc cs = (NegApp (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsPar an a b c) anc cs = (HsPar (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (SectionL an a b) anc cs = (SectionL (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (SectionR an a b) anc cs = (SectionR (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (ExplicitTuple an a b) anc cs = (ExplicitTuple (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (ExplicitSum an a b c) anc cs = (ExplicitSum (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (HsCase an a b) anc cs = (HsCase (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsIf an a b c) anc cs = (HsIf (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (HsMultiIf an a) anc cs = (HsMultiIf (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsLet an a b c d) anc cs = (HsLet (setAnchorEpa an anc cs) a b c d)
+ setAnnotationAnchor (HsDo an a b) anc cs = (HsDo (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (ExplicitList an a) anc cs = (ExplicitList (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (RecordCon an a b) anc cs = (RecordCon (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (RecordUpd an a b) anc cs = (RecordUpd (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsGetField an a b) anc cs = (HsGetField (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsProjection an a) anc cs = (HsProjection (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (ExprWithTySig an a b) anc cs = (ExprWithTySig (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (ArithSeq an a b) anc cs = (ArithSeq (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsTypedBracket an a) anc cs = (HsTypedBracket (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsUntypedBracket an a) anc cs = (HsUntypedBracket (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsTypedSplice (x,an) e) anc cs = (HsTypedSplice (x,(setAnchorEpa an anc cs)) e)
+ setAnnotationAnchor (HsUntypedSplice an e) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) e)
+ setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(HsPragE{}) _ _s = a
+
+ exact (HsVar x n) = do
+ n' <- markAnnotated n
+ return (HsVar x n')
+ exact x@(HsUnboundVar an _) = do
case an of
EpAnnNotUsed -> withPpr x
EpAnn _ (EpAnnUnboundVar (ob,cb) l) _ -> do
- printStringAtAA ob "`"
- printStringAtAA l "_"
- printStringAtAA cb "`"
- -- exact x@(HsRecSel{}) = withPpr x
+ printStringAtAA ob "`" >> return ()
+ printStringAtAA l "_" >> return ()
+ printStringAtAA cb "`" >> return ()
+ return x
exact x@(HsOverLabel _ _) = withPpr x
- exact (HsIPVar _ (HsIPName n))
- = printStringAdvance ("?" ++ unpackFS n)
+ exact x@(HsIPVar _ (HsIPName n))
+ = printStringAdvance ("?" ++ unpackFS n) >> return x
exact x@(HsOverLit _an ol) = do
let str = case ol_val ol of
HsIntegral (IL src _ _) -> src
HsFractional (FL { fl_text = src }) -> src
HsIsString src _ -> src
- -- markExternalSourceText l str ""
case str of
- SourceText s -> printStringAdvance s
- NoSourceText -> withPpr x
-
- exact (HsLit _an lit) = withPpr lit
- exact (HsLam _ (MG _ (L _ [match]))) = do
- markAnnotated match
- -- markExpr _ (HsLam _ (MG _ (L _ [match]) _)) = do
- -- setContext (Set.singleton LambdaExpr) $ do
- -- -- TODO: Change this, HsLam binds do not need obey layout rules.
- -- -- And will only ever have a single match
- -- markLocated match
- -- markExpr _ (HsLam _ _) = error $ "HsLam with other than one match"
- exact (HsLam _ _) = error $ "HsLam with other than one match"
+ SourceText s -> printStringAdvance s >> return ()
+ NoSourceText -> withPpr x >> return ()
+ return x
+
+ exact (HsLit an lit) = do
+ lit' <- withPpr lit
+ return (HsLit an lit')
+ exact (HsLam x mg) = do
+ mg' <- markAnnotated mg
+ return (HsLam x mg')
exact (HsLamCase an lc_variant mg) = do
- markEpAnn an AnnLam
- markEpAnn an case lc_variant of LamCase -> AnnCase
- LamCases -> AnnCases
- markAnnotated mg
+ an0 <- markEpAnnL an lidl AnnLam
+ an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase
+ LamCases -> AnnCases)
+ mg' <- markAnnotated mg
+ return (HsLamCase an1 lc_variant mg')
- exact (HsApp _an e1 e2) = do
+ exact (HsApp an e1 e2) = do
p <- getPosP
debugM $ "HsApp entered. p=" ++ show p
- markAnnotated e1
- markAnnotated e2
- exact (HsAppType _ fun at arg) = do
- markAnnotated fun
- markToken at
- markAnnotated arg
- exact (OpApp _an e1 e2 e3) = do
- markAnnotated e1
- markAnnotated e2
- markAnnotated e3
-
- exact (NegApp an e _) = do
- markEpAnn an AnnMinus
- markAnnotated e
-
- exact (HsPar _an lpar e rpar) = do
- markToken lpar
- markAnnotated e
+ e1' <- markAnnotated e1
+ e2' <- markAnnotated e2
+ return (HsApp an e1' e2')
+ exact (HsAppType ss fun at arg) = do
+ fun' <- markAnnotated fun
+ at' <- markToken at
+ arg' <- markAnnotated arg
+ return (HsAppType ss fun' at' arg')
+ exact (OpApp an e1 e2 e3) = do
+ e1' <- markAnnotated e1
+ e2' <- markAnnotated e2
+ e3' <- markAnnotated e3
+ return (OpApp an e1' e2' e3')
+
+ exact (NegApp an e s) = do
+ an0 <- markEpAnnL an lidl AnnMinus
+ e' <- markAnnotated e
+ return (NegApp an0 e' s)
+
+ exact (HsPar an lpar e rpar) = do
+ lpar' <- markToken lpar
+ e' <- markAnnotated e
debugM $ "HsPar closing paren"
- markToken rpar
+ rpar' <- markToken rpar
debugM $ "HsPar done"
+ return (HsPar an lpar' e' rpar')
- exact (SectionL _an expr op) = do
- markAnnotated expr
- markAnnotated op
+ exact (SectionL an expr op) = do
+ expr' <- markAnnotated expr
+ op' <- markAnnotated op
+ return (SectionL an expr' op')
- exact (SectionR _an op expr) = do
- markAnnotated op
- markAnnotated expr
+ exact (SectionR an op expr) = do
+ op' <- markAnnotated op
+ expr' <- markAnnotated expr
+ return (SectionR an op' expr')
exact (ExplicitTuple an args b) = do
- if b == Boxed then markEpAnn an AnnOpenP
- else markEpAnn an AnnOpenPH
+ an0 <- if b == Boxed then markEpAnnL an lidl AnnOpenP
+ else markEpAnnL an lidl AnnOpenPH
- mapM_ markAnnotated args
+ args' <- mapM markAnnotated args
- if b == Boxed then markEpAnn an AnnCloseP
- else markEpAnn an AnnClosePH
+ an1 <- if b == Boxed then markEpAnnL an0 lidl AnnCloseP
+ else markEpAnnL an0 lidl AnnClosePH
debugM $ "ExplicitTuple done"
+ return (ExplicitTuple an1 args' b)
- exact (ExplicitSum an _alt _arity expr) = do
- -- markEpAnn an AnnOpenPH
- markAnnKw an aesOpen AnnOpenPH
- markAnnKwAll an aesBarsBefore AnnVbar
- markAnnotated expr
- markAnnKwAll an aesBarsAfter AnnVbar
- markAnnKw an aesClose AnnClosePH
+ exact (ExplicitSum an alt arity expr) = do
+ an0 <- markLensKw an laesOpen AnnOpenPH
+ an1 <- markAnnKwAllL an0 laesBarsBefore AnnVbar
+ expr' <- markAnnotated expr
+ an2 <- markAnnKwAllL an1 laesBarsAfter AnnVbar
+ an3 <- markLensKw an2 laesClose AnnClosePH
+ return (ExplicitSum an3 alt arity expr')
exact (HsCase an e alts) = do
- markAnnKw an hsCaseAnnCase AnnCase
- markAnnotated e
- markAnnKw an hsCaseAnnOf AnnOf
- markEpAnn' an hsCaseAnnsRest AnnOpenC
- markEpAnnAll an hsCaseAnnsRest AnnSemi
- setLayoutBoth $ markAnnotated alts
- markEpAnn' an hsCaseAnnsRest AnnCloseC
-
- -- exact x@(HsCase EpAnnNotUsed _ _) = withPpr x
+ an0 <- markAnnKwL an lhsCaseAnnCase AnnCase
+ e' <- markAnnotated e
+ an1 <- markAnnKwL an0 lhsCaseAnnOf AnnOf
+ an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC
+ an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi
+ alts' <- setLayoutBoth $ markAnnotated alts
+ an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC
+ return (HsCase an4 e' alts')
+
exact (HsIf an e1 e2 e3) = do
- markAnnKw an aiIf AnnIf
- markAnnotated e1
- markAnnKwM an aiThenSemi AnnSemi
- markAnnKw an aiThen AnnThen
- markAnnotated e2
- markAnnKwM an aiElseSemi AnnSemi
- markAnnKw an aiElse AnnElse
- markAnnotated e3
+ an0 <- markAnnKwL an laiIf AnnIf
+ e1' <- markAnnotated e1
+ an1 <- markLensKwM an0 laiThenSemi AnnSemi
+ an2 <- markAnnKwL an1 laiThen AnnThen
+ e2' <- markAnnotated e2
+ an3 <- markLensKwM an2 laiElseSemi AnnSemi
+ an4 <- markAnnKwL an3 laiElse AnnElse
+ e3' <- markAnnotated e3
+ return (HsIf an4 e1' e2' e3')
exact (HsMultiIf an mg) = do
- markEpAnn an AnnIf
- markEpAnn an AnnOpenC -- optional
- markAnnotated mg
- markEpAnn an AnnCloseC -- optional
+ an0 <- markEpAnnL an lidl AnnIf
+ an1 <- markEpAnnL an0 lidl AnnOpenC -- optional
+ mg' <- markAnnotated mg
+ an2 <- markEpAnnL an1 lidl AnnCloseC -- optional
+ return (HsMultiIf an2 mg')
- exact (HsLet _an tkLet binds tkIn e) = do
+ exact (HsLet an tkLet binds tkIn e) = do
setLayoutBoth $ do -- Make sure the 'in' gets indented too
- markToken tkLet
+ tkLet' <- markToken tkLet
debugM $ "HSlet:binds coming"
- setLayoutBoth $ markAnnotated binds
+ binds' <- setLayoutBoth $ markAnnotated binds
debugM $ "HSlet:binds done"
- markToken tkIn
+ tkIn' <- markToken tkIn
debugM $ "HSlet:expr coming"
- markAnnotated e
+ e' <- markAnnotated e
+ return (HsLet an tkLet' binds' tkIn' e')
exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
- markAnnList True an $ exactDo an do_or_list_comp stmts
+ (an',stmts') <- markAnnListA True an $ \a -> exactDo a do_or_list_comp stmts
+ return (HsDo an' do_or_list_comp stmts')
exact (ExplicitList an es) = do
debugM $ "ExplicitList start"
- markLocatedMAA an al_open
- markAnnotated es
- markLocatedMAA an al_close
+ an0 <- markLensMAA an lal_open
+ es' <- markAnnotated es
+ an1 <- markLensMAA an0 lal_close
debugM $ "ExplicitList end"
+ return (ExplicitList an1 es')
exact (RecordCon an con_id binds) = do
- markAnnotated con_id
- markEpAnn an AnnOpenC
- markAnnotated binds
- markEpAnn an AnnCloseC
+ con_id' <- markAnnotated con_id
+ an0 <- markEpAnnL an lidl AnnOpenC
+ binds' <- markAnnotated binds
+ an1 <- markEpAnnL an0 lidl AnnCloseC
+ return (RecordCon an1 con_id' binds')
exact (RecordUpd an expr fields) = do
- markAnnotated expr
- markEpAnn an AnnOpenC
- markAnnotated fields
- markEpAnn an AnnCloseC
- exact (HsGetField _an expr field) = do
- markAnnotated expr
- markAnnotated field
+ expr' <- markAnnotated expr
+ an0 <- markEpAnnL an lidl AnnOpenC
+ fields' <- markAnnotated fields
+ an1 <- markEpAnnL an0 lidl AnnCloseC
+ return (RecordUpd an1 expr' fields')
+ exact (HsGetField an expr field) = do
+ expr' <- markAnnotated expr
+ field' <- markAnnotated field
+ return (HsGetField an expr' field')
exact (HsProjection an flds) = do
- markAnnKw an apOpen AnnOpenP
- markAnnotated flds
- markAnnKw an apClose AnnCloseP
+ an0 <- markAnnKwL an lapOpen AnnOpenP
+ flds' <- mapM markAnnotated flds
+ an1 <- markAnnKwL an0 lapClose AnnCloseP
+ return (HsProjection an1 flds')
exact (ExprWithTySig an expr sig) = do
- markAnnotated expr
- markEpAnn an AnnDcolon
- markAnnotated sig
- exact (ArithSeq an _ seqInfo) = do
- markEpAnn an AnnOpenS -- '['
- case seqInfo of
+ expr' <- markAnnotated expr
+ an0 <- markEpAnnL an lidl AnnDcolon
+ sig' <- markAnnotated sig
+ return (ExprWithTySig an0 expr' sig')
+ exact (ArithSeq an s seqInfo) = do
+ an0 <- markEpAnnL an lidl AnnOpenS -- '['
+ (an1, seqInfo') <-
+ case seqInfo of
From e -> do
- markAnnotated e
- markEpAnn an AnnDotdot
+ e' <- markAnnotated e
+ an' <- markEpAnnL an0 lidl AnnDotdot
+ return (an', From e')
FromTo e1 e2 -> do
- markAnnotated e1
- markEpAnn an AnnDotdot
- markAnnotated e2
+ e1' <- markAnnotated e1
+ an' <- markEpAnnL an0 lidl AnnDotdot
+ e2' <- markAnnotated e2
+ return (an', FromTo e1' e2')
FromThen e1 e2 -> do
- markAnnotated e1
- markEpAnn an AnnComma
- markAnnotated e2
- markEpAnn an AnnDotdot
+ e1' <- markAnnotated e1
+ an' <- markEpAnnL an0 lidl AnnComma
+ e2' <- markAnnotated e2
+ an'' <- markEpAnnL an' lidl AnnDotdot
+ return (an'', FromThen e1' e2')
FromThenTo e1 e2 e3 -> do
- markAnnotated e1
- markEpAnn an AnnComma
- markAnnotated e2
- markEpAnn an AnnDotdot
- markAnnotated e3
- markEpAnn an AnnCloseS -- ']'
+ e1' <- markAnnotated e1
+ an' <- markEpAnnL an0 lidl AnnComma
+ e2' <- markAnnotated e2
+ an'' <- markEpAnnL an' lidl AnnDotdot
+ e3' <- markAnnotated e3
+ return (an'', FromThenTo e1' e2' e3')
+ an2 <- markEpAnnL an1 lidl AnnCloseS -- ']'
+ return (ArithSeq an2 s seqInfo')
exact (HsTypedBracket an e) = do
- markLocatedAALS an id AnnOpen (Just "[||")
- markLocatedAALS an id AnnOpenE (Just "[e||")
- markAnnotated e
- markLocatedAALS an id AnnClose (Just "||]")
-
- exact (HsUntypedBracket an (ExpBr _ e)) = do
- markEpAnn an AnnOpenEQ -- "[|"
- markEpAnn an AnnOpenE -- "[e|" -- optional
- markAnnotated e
- markEpAnn an AnnCloseQ -- "|]"
- exact (HsUntypedBracket an (PatBr _ e)) = do
- markLocatedAALS an id AnnOpen (Just "[p|")
- markAnnotated e
- markEpAnn an AnnCloseQ -- "|]"
- exact (HsUntypedBracket an (DecBrL _ e)) = do
- markLocatedAALS an id AnnOpen (Just "[d|")
- markAnnotated e
- markEpAnn an AnnCloseQ -- "|]"
- -- -- exact (HsUntypedBracket an (DecBrG _ _)) =
- -- -- traceM "warning: DecBrG introduced after renamer"
- exact (HsUntypedBracket an (TypBr _ e)) = do
- markLocatedAALS an id AnnOpen (Just "[t|")
- markAnnotated e
- markEpAnn an AnnCloseQ -- "|]"
- exact (HsUntypedBracket an (VarBr _ b e)) = do
- if b
+ an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||")
+ an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||")
+ e' <- markAnnotated e
+ an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]")
+ return (HsTypedBracket an2 e')
+
+ exact (HsUntypedBracket an (ExpBr a e)) = do
+ an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|"
+ an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional
+ e' <- markAnnotated e
+ an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]"
+ return (HsUntypedBracket an2 (ExpBr a e'))
+
+ exact (HsUntypedBracket an (PatBr a e)) = do
+ an0 <- markEpAnnLMS an lidl AnnOpen (Just "[p|")
+ e' <- markAnnotated e
+ an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]"
+ return (HsUntypedBracket an1 (PatBr a e'))
+
+ exact (HsUntypedBracket an (DecBrL a e)) = do
+ an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|")
+ an1 <- markEpAnnL an lidl AnnOpenC
+ e' <- markAnnotated e
+ an2 <- markEpAnnL an1 lidl AnnCloseC
+ an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]"
+ return (HsUntypedBracket an3 (DecBrL a e'))
+
+ exact (HsUntypedBracket an (TypBr a e)) = do
+ an0 <- markEpAnnLMS an lidl AnnOpen (Just "[t|")
+ e' <- markAnnotated e
+ an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]"
+ return (HsUntypedBracket an1 (TypBr a e'))
+
+ exact (HsUntypedBracket an (VarBr a b e)) = do
+ (an0, e') <- if b
then do
- markEpAnn an AnnSimpleQuote
- markAnnotated e
+ an' <- markEpAnnL an lidl AnnSimpleQuote
+ e' <- markAnnotated e
+ return (an', e')
else do
- markEpAnn an AnnThTyQuote
- markAnnotated e
-
- exact (HsTypedSplice (_, an) e) = do
- markEpAnn an AnnDollarDollar
- markAnnotated e
- exact (HsUntypedSplice _ sp) = markAnnotated sp
+ an' <- markEpAnnL an lidl AnnThTyQuote
+ e' <- markAnnotated e
+ return (an', e')
+ return (HsUntypedBracket an0 (VarBr a b e'))
+
+ exact (HsTypedSplice (x,an) s) = do
+ an0 <- markEpAnnL an lidl AnnDollarDollar
+ s' <- exact s
+ return (HsTypedSplice (x,an0) s')
+ exact (HsUntypedSplice an s) = do
+ s' <- exact s
+ return (HsUntypedSplice an s')
exact (HsProc an p c) = do
debugM $ "HsProc start"
- markEpAnn an AnnProc
- markAnnotated p
- markEpAnn an AnnRarrow
+ an0 <- markEpAnnL an lidl AnnProc
+ p' <- markAnnotated p
+ an1 <- markEpAnnL an0 lidl AnnRarrow
debugM $ "HsProc after AnnRarrow"
- markAnnotated c
+ c' <- markAnnotated c
+ return (HsProc an1 p' c')
exact (HsStatic an e) = do
- markEpAnn an AnnStatic
- markAnnotated e
-
- exact (HsPragE _ prag e) = do
- markAnnotated prag
- markAnnotated e
+ an0 <- markEpAnnL an lidl AnnStatic
+ e' <- markAnnotated e
+ return (HsStatic an0 e')
+
+ exact (HsPragE a prag e) = do
+ prag' <- markAnnotated prag
+ e' <- markAnnotated e
+ return (HsPragE a prag' e')
exact x = error $ "exact HsExpr for:" ++ showAst x
-- ---------------------------------------------------------------------
-exactDo :: (ExactPrint body)
- => EpAnn AnnList -> HsDoFlavour -> body -> EPP ()
-exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >> markAnnotatedWithLayout stmts
-exactDo an GhciStmtCtxt stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts
-exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >> markAnnotatedWithLayout stmts
-exactDo _ ListComp stmts = markAnnotatedWithLayout stmts
-exactDo _ MonadComp stmts = markAnnotatedWithLayout stmts
+exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
+ => EpAnn AnnList -> HsDoFlavour -> LocatedAn an a
+ -> EP w m (EpAnn AnnList, LocatedAn an a)
+exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts
+exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts
+exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts
+exactDo an ListComp stmts = markMaybeDodgyStmts an stmts
+exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts
-exactMdo :: EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP ()
-exactMdo an Nothing kw = markLocatedAAL an al_rest kw
-exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n)
+exactMdo :: (Monad m, Monoid w)
+ => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList)
+exactMdo an Nothing kw = markEpAnnL an lal_rest kw
+exactMdo an (Just module_name) kw = markEpAnnLMS an lal_rest kw (Just n)
where
- n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw))
+ n = (moduleNameString module_name) ++ "." ++ (keywordToString kw)
+markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
+ => EpAnn AnnList -> LocatedAn an a -> EP w m (EpAnn AnnList, LocatedAn an a)
+markMaybeDodgyStmts an stmts =
+ if isGoodSrcSpan (getLocA stmts)
+ then do
+ r <- markAnnotatedWithLayout stmts
+ return (an, r)
+ else return (an, stmts)
-- ---------------------------------------------------------------------
instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (HsPragSCC (an, st) sl) = do
- markAnnOpenP an st "{-# SCC"
+ exact (HsPragSCC (an,st) sl) = do
+ an0 <- markAnnOpenP an st "{-# SCC"
let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)
- markLocatedAALS an apr_rest AnnVal (Just txt) -- optional
- markLocatedAALS an apr_rest AnnValStr (Just txt) -- optional
- markAnnCloseP an
-
- -- markExpr _ (GHC.HsPragE _ prag e) = do
- -- case prag of
- -- (GHC.HsPragSCC _ src csFStr) -> do
- -- markAnnOpen src "{-# SCC"
- -- let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
- -- markWithStringOptional GHC.AnnVal txt
- -- markWithString GHC.AnnValStr txt
- -- markWithString GHC.AnnClose "#-}"
- -- markLocated e
-
- -- (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> do
- -- -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
- -- markAnnOpen src "{-# GENERATED"
- -- markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING
-
- -- let
- -- markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v)
- -- markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s
-
- -- markOne 1 v1 s1 -- INTEGER
- -- markOffset GHC.AnnColon 0 -- ':'
- -- markOne 2 v2 s2 -- INTEGER
- -- mark GHC.AnnMinus -- '-'
- -- markOne 3 v3 s3 -- INTEGER
- -- markOffset GHC.AnnColon 1 -- ':'
- -- markOne 4 v4 s4 -- INTEGER
- -- markWithString GHC.AnnClose "#-}"
- -- markLocated e
+ an1 <- markEpAnnLMS an0 lapr_rest AnnVal (Just txt) -- optional
+ an2 <- markEpAnnLMS an1 lapr_rest AnnValStr (Just txt) -- optional
+ an3 <- markAnnCloseP an2
+ return (HsPragSCC (an3,st) sl)
+
-- ---------------------------------------------------------------------
@@ -2164,91 +3030,112 @@ instance ExactPrint (HsUntypedSplice GhcPs) where
getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an
getAnnotationEntry (HsQuasiQuote _ _ _) = NoEntryVal
- exact (HsUntypedSpliceExpr an b) = do
- markEpAnn an AnnDollar
- markAnnotated b
+ setAnnotationAnchor (HsUntypedSpliceExpr an e) anc cs = HsUntypedSpliceExpr (setAnchorEpa an anc cs) e
+ setAnnotationAnchor a@HsQuasiQuote {} _ _ = a
- exact (HsQuasiQuote _ q (L (SrcSpanAnn _ ss) fs)) = do
+ exact (HsUntypedSpliceExpr an e) = do
+ an0 <- markEpAnnL an lidl AnnDollar
+ e' <- markAnnotated e
+ return (HsUntypedSpliceExpr an0 e')
+
+ exact (HsQuasiQuote an q (L l fs)) = do
-- The quasiquote string does not honour layout offsets. Store
-- the colOffset for now.
-- TODO: use local?
oldOffset <- getLayoutOffsetP
- setLayoutOffsetP 0
+ EPState{pMarkLayout} <- get
+ unless pMarkLayout $ setLayoutOffsetP 0
printStringAdvance
-- Note: Lexer.x does not provide unicode alternative. 2017-02-26
("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]")
- setLayoutOffsetP oldOffset
- p <- getPosP
- debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss)
+ unless pMarkLayout $ setLayoutOffsetP oldOffset
+ return (HsQuasiQuote an q (L l fs))
-- ---------------------------------------------------------------------
-- TODO:AZ: combine these instances
instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
getAnnotationEntry = const NoEntryVal
- exact (MG _ matches) = do
+ setAnnotationAnchor a _ _ = a
+ exact (MG x matches) = do
-- TODO:AZ use SortKey, in MG ann.
- markAnnotated matches
+ matches' <- if isGoodSrcSpan (getLocA matches)
+ then markAnnotated matches
+ else return matches
+ return (MG x matches')
instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where
getAnnotationEntry = const NoEntryVal
- exact (MG _ matches) = do
+ setAnnotationAnchor a _ _ = a
+ exact (MG x matches) = do
-- TODO:AZ use SortKey, in MG ann.
- markAnnotated matches
+ matches' <- if isGoodSrcSpan (getLocA matches)
+ then markAnnotated matches
+ else return matches
+ return (MG x matches')
-- ---------------------------------------------------------------------
instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact (HsRecFields fields mdot) = do
- markAnnotated fields
+ fields' <- markAnnotated fields
case mdot of
Nothing -> return ()
Just (L ss _) ->
- printStringAtSs ss ".."
+ printStringAtSs ss ".." >> return ()
-- Note: mdot contains the SrcSpan where the ".." appears, if present
+ return (HsRecFields fields' mdot)
-- ---------------------------------------------------------------------
--- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where
instance (ExactPrint body)
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) body) where
getAnnotationEntry x = fromAnn (hfbAnn x)
+ setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun)
exact (HsFieldBind an f arg isPun) = do
debugM $ "HsFieldBind"
- markAnnotated f
- if isPun then return ()
+ f' <- markAnnotated f
+ (an0, arg') <- if isPun then return (an, arg)
else do
- markEpAnn an AnnEqual
- markAnnotated arg
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
+ return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
instance (ExactPrint body)
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where
getAnnotationEntry x = fromAnn (hfbAnn x)
+ setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun)
+
exact (HsFieldBind an f arg isPun) = do
debugM $ "HsFieldBind FieldLabelStrings"
- markAnnotated f
- if isPun then return ()
+ f' <- markAnnotated f
+ (an0, arg') <- if isPun then return (an, arg)
else do
- markEpAnn an AnnEqual
- markAnnotated arg
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
+ return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
--- instance ExactPrint (HsRecUpdField GhcPs ) where
instance (ExactPrint (LocatedA body))
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
--- instance (ExactPrint body)
- -- => ExactPrint (HsFieldBind (AmbiguousFieldOcc GhcPs) body) where
getAnnotationEntry x = fromAnn (hfbAnn x)
+ setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun)
exact (HsFieldBind an f arg isPun) = do
debugM $ "HsRecUpdField"
- markAnnotated f
- if isPun then return ()
- else markEpAnn an AnnEqual
- unless ((locA $ getLoc arg) == noSrcSpan ) $ markAnnotated arg
+ f' <- markAnnotated f
+ an0 <- if isPun then return an
+ else markEpAnnL an lidl AnnEqual
+ arg' <- if ((locA $ getLoc arg) == noSrcSpan )
+ then return arg
+ else markAnnotated arg
+ return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
instance
@@ -2258,25 +3145,31 @@ instance
(Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)]
[LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where
getAnnotationEntry = const NoEntryVal
- exact (Left rbinds) = markAnnotated rbinds
- exact (Right pbinds) = markAnnotated pbinds
+ setAnnotationAnchor a _ _ = a
+
+ exact (Left rbinds) = Left <$> markAnnotated rbinds
+ exact (Right pbinds) = Right <$> markAnnotated pbinds
-- ---------------------------------------------------------------------
instance ExactPrint (FieldLabelStrings GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (FieldLabelStrings fs) = markAnnotated fs
+ setAnnotationAnchor a _ _ = a
+ exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs
-- ---------------------------------------------------------------------
instance ExactPrint (DotFieldOcc GhcPs) where
getAnnotationEntry (DotFieldOcc an _) = fromAnn an
+ setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a
+
exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do
- markAnnKwM an afDot AnnDot
+ an0 <- markLensKwM an lafDot AnnDot
-- The field name has a SrcSpanAnnN, print it as a
-- LocatedN RdrName
- markAnnotated (L loc (mkVarUnqual fs))
+ L loc' _ <- markAnnotated (L loc (mkVarUnqual fs))
+ return (DotFieldOcc an0 (L loc' (FieldLabelString fs)))
-- ---------------------------------------------------------------------
@@ -2284,16 +3177,20 @@ instance ExactPrint (HsTupArg GhcPs) where
getAnnotationEntry (Present an _) = fromAnn an
getAnnotationEntry (Missing an) = fromAnn an
- exact (Present _ e) = markAnnotated e
+ setAnnotationAnchor (Present an a) anc cs = Present (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (Missing an) anc cs = Missing (setAnchorEpa an anc cs)
+
+ exact (Present a e) = Present a <$> markAnnotated e
- exact (Missing EpAnnNotUsed) = return ()
- exact (Missing _) = printStringAdvance ","
+ exact a@(Missing EpAnnNotUsed) = return a
+ exact a@(Missing _) = printStringAdvance "," >> return a
-- ---------------------------------------------------------------------
instance ExactPrint (HsCmdTop GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (HsCmdTop _ cmd) = markAnnotated cmd
+ setAnnotationAnchor a _ _ = a
+ exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd
-- ---------------------------------------------------------------------
@@ -2309,99 +3206,104 @@ instance ExactPrint (HsCmd GhcPs) where
getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an
getAnnotationEntry (HsCmdDo an _) = fromAnn an
-
-
- exact (HsCmdArrApp an arr arg _o isRightToLeft) = do
+ setAnnotationAnchor (HsCmdArrApp an a b c d) anc cs = (HsCmdArrApp (setAnchorEpa an anc cs) a b c d)
+ setAnnotationAnchor (HsCmdArrForm an a b c d ) anc cs = (HsCmdArrForm (setAnchorEpa an anc cs) a b c d )
+ setAnnotationAnchor (HsCmdApp an a b ) anc cs = (HsCmdApp (setAnchorEpa an anc cs) a b )
+ setAnnotationAnchor a@(HsCmdLam {}) _ _s = a
+ setAnnotationAnchor (HsCmdPar an a b c) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (HsCmdCase an a b) anc cs = (HsCmdCase (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsCmdLamCase an a b) anc cs = (HsCmdLamCase (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsCmdIf an a b c d) anc cs = (HsCmdIf (setAnchorEpa an anc cs) a b c d)
+ setAnnotationAnchor (HsCmdLet an a b c d) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b c d)
+ setAnnotationAnchor (HsCmdDo an a) anc cs = (HsCmdDo (setAnchorEpa an anc cs) a)
+
+ exact (HsCmdArrApp an arr arg o isRightToLeft) = do
if isRightToLeft
then do
- markAnnotated arr
- markKw (anns an)
- markAnnotated arg
+ arr' <- markAnnotated arr
+ an0 <- markKw (anns an)
+ arg' <- markAnnotated arg
+ let an1 = an{anns = an0}
+ return (HsCmdArrApp an1 arr' arg' o isRightToLeft)
else do
- markAnnotated arg
- markKw (anns an)
- markAnnotated arr
-
- exact (HsCmdArrForm an e fixity _mf cs) = do
- markLocatedMAA an al_open
- case (fixity, cs) of
+ arg' <- markAnnotated arg
+ an0 <- markKw (anns an)
+ arr' <- markAnnotated arr
+ let an1 = an {anns = an0}
+ return (HsCmdArrApp an1 arr' arg' o isRightToLeft)
+
+ exact (HsCmdArrForm an e fixity mf cs) = do
+ an0 <- markLensMAA an lal_open
+ (e',cs') <- case (fixity, cs) of
(Infix, (arg1:argrest)) -> do
- markAnnotated arg1
- markAnnotated e
- markAnnotated argrest
+ arg1' <- markAnnotated arg1
+ e' <- markAnnotated e
+ argrest' <- markAnnotated argrest
+ return (e', arg1':argrest')
(Prefix, _) -> do
- markAnnotated e
- markAnnotated cs
+ e' <- markAnnotated e
+ cs' <- markAnnotated cs
+ return (e', cs')
(Infix, []) -> error "Not possible"
- markLocatedMAA an al_close
+ an1 <- markLensMAA an0 lal_close
+ return (HsCmdArrForm an1 e' fixity mf cs')
- exact (HsCmdApp _an e1 e2) = do
- markAnnotated e1
- markAnnotated e2
+ exact (HsCmdApp an e1 e2) = do
+ e1' <- markAnnotated e1
+ e2' <- markAnnotated e2
+ return (HsCmdApp an e1' e2')
- exact (HsCmdLam _ match) = markAnnotated match
+ exact (HsCmdLam a match) = do
+ match' <- markAnnotated match
+ return (HsCmdLam a match')
- exact (HsCmdPar _an lpar e rpar) = do
- markToken lpar
- markAnnotated e
- markToken rpar
+ exact (HsCmdPar an lpar e rpar) = do
+ lpar' <- markToken lpar
+ e' <- markAnnotated e
+ rpar' <- markToken rpar
+ return (HsCmdPar an lpar' e' rpar')
exact (HsCmdCase an e alts) = do
- markAnnKw an hsCaseAnnCase AnnCase
- markAnnotated e
- markAnnKw an hsCaseAnnOf AnnOf
- markEpAnn' an hsCaseAnnsRest AnnOpenC
- markEpAnnAll an hsCaseAnnsRest AnnSemi
- markAnnotated alts
- markEpAnn' an hsCaseAnnsRest AnnCloseC
+ an0 <- markLensKw an lhsCaseAnnCase AnnCase
+ e' <- markAnnotated e
+ an1 <- markLensKw an0 lhsCaseAnnOf AnnOf
+ an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC
+ an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi
+ alts' <- markAnnotated alts
+ an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC
+ return (HsCmdCase an4 e' alts')
exact (HsCmdLamCase an lc_variant matches) = do
- markEpAnn an AnnLam
- markEpAnn an case lc_variant of LamCase -> AnnCase
- LamCases -> AnnCases
- markAnnotated matches
-
- exact (HsCmdIf an _ e1 e2 e3) = do
- markAnnKw an aiIf AnnIf
- markAnnotated e1
- markAnnKwM an aiThenSemi AnnSemi
- markAnnKw an aiThen AnnThen
- markAnnotated e2
- markAnnKwM an aiElseSemi AnnSemi
- markAnnKw an aiElse AnnElse
- markAnnotated e3
-
--- markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do
--- mark GHC.AnnLet
--- markOptional GHC.AnnOpenC
--- markLocalBindsWithLayout binds
--- markOptional GHC.AnnCloseC
--- mark GHC.AnnIn
--- markLocated e
+ an0 <- markEpAnnL an lidl AnnLam
+ an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase
+ LamCases -> AnnCases)
+ matches' <- markAnnotated matches
+ return (HsCmdLamCase an1 lc_variant matches')
+
+ exact (HsCmdIf an a e1 e2 e3) = do
+ an0 <- markLensKw an laiIf AnnIf
+ e1' <- markAnnotated e1
+ an1 <- markLensKwM an0 laiThenSemi AnnSemi
+ an2 <- markLensKw an1 laiThen AnnThen
+ e2' <- markAnnotated e2
+ an3 <- markLensKwM an2 laiElseSemi AnnSemi
+ an4 <- markLensKw an3 laiElse AnnElse
+ e3' <- markAnnotated e3
+ return (HsCmdIf an4 a e1' e2' e3')
+
+ exact (HsCmdLet an tkLet binds tkIn e) = do
+ setLayoutBoth $ do -- Make sure the 'in' gets indented too
+ tkLet' <- markToken tkLet
+ binds' <- setLayoutBoth $ markAnnotated binds
+ tkIn' <- markToken tkIn
+ e' <- markAnnotated e
+ return (HsCmdLet an tkLet' binds' tkIn' e')
exact (HsCmdDo an es) = do
debugM $ "HsCmdDo"
- markEpAnn' an al_rest AnnDo
- markAnnotated es
-
--- markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do
--- mark GHC.AnnDo
--- markOptional GHC.AnnOpenC
--- markListWithLayout es
--- markOptional GHC.AnnCloseC
-
--- markAST _ (GHC.HsCmdWrap {}) =
--- traceM "warning: HsCmdWrap introduced after renaming"
-
--- markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showPprUnsafe x
-
- exact x = error $ "exact HsCmd for:" ++ showAst x
-
--- ---------------------------------------------------------------------
-
--- instance ExactPrint (CmdLStmt GhcPs) where
--- getAnnotationEntry = const NoEntryVal
--- exact (L _ a) = markAnnotated a
+ an0 <- markEpAnnL an lal_rest AnnDo
+ es' <- markAnnotated es
+ return (HsCmdDo an0 es')
-- ---------------------------------------------------------------------
@@ -2422,142 +3324,95 @@ instance (
-----------------------------------------------------------------
- exact (LastStmt _ body _ _) = do
+ setAnnotationAnchor a@(LastStmt _ _ _ _) _ _s = a
+ setAnnotationAnchor (BindStmt an a b) anc cs = (BindStmt (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor a@(ApplicativeStmt _ _ _) _ _s = a
+ setAnnotationAnchor a@(BodyStmt _ _ _ _) _ _s = a
+ setAnnotationAnchor (LetStmt an a) anc cs = (LetStmt (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(ParStmt _ _ _ _) _ _s = a
+ setAnnotationAnchor (TransStmt an a b c d e f g h) anc cs = (TransStmt (setAnchorEpa an anc cs) a b c d e f g h)
+ setAnnotationAnchor (RecStmt an a b c d e f) anc cs = (RecStmt (setAnchorEpa an anc cs) a b c d e f)
+
+ -----------------------------------------------------------------
+
+ exact (LastStmt a body b c) = do
debugM $ "LastStmt"
- markAnnotated body
+ body' <- markAnnotated body
+ return (LastStmt a body' b c)
exact (BindStmt an pat body) = do
debugM $ "BindStmt"
- markAnnotated pat
- markEpAnn an AnnLarrow
- markAnnotated body
+ pat' <- markAnnotated pat
+ an0 <- markEpAnnL an lidl AnnLarrow
+ body' <- markAnnotated body
+ return (BindStmt an0 pat' body')
exact (ApplicativeStmt _ _body _) = do
- debugM $ "ApplicativeStmt"
- -- TODO: ApplicativeStmt
- -- markAnnotated body
- error $ "need to complete ApplicativeStmt"
+ error $ "ApplicativeStmt is introduced in the renamer"
- exact (BodyStmt _ body _ _) = do
+ exact (BodyStmt a body b c) = do
debugM $ "BodyStmt"
- markAnnotated body
+ body' <- markAnnotated body
+ return (BodyStmt a body' b c)
exact (LetStmt an binds) = do
debugM $ "LetStmt"
- markEpAnn an AnnLet
- markAnnotated binds
+ an0 <- markEpAnnL an lidl AnnLet
+ binds' <- markAnnotated binds
+ return (LetStmt an0 binds')
- exact (ParStmt _ pbs _ _) = do
+ exact (ParStmt a pbs b c) = do
debugM $ "ParStmt"
- markAnnotated pbs
-
- -- markAST l (GHC.ParStmt _ pbs _ _) = do
- -- -- Within a given parallel list comprehension,one of the sections to be done
- -- -- in parallel. It is a normal list comprehension, so has a list of
- -- -- ParStmtBlock, one for each part of the sub- list comprehension
-
-
- -- ifInContext (Set.singleton Intercalate)
- -- (
-
- -- unsetContext Intercalate $
- -- markListWithContextsFunction
- -- (LC (Set.singleton Intercalate) -- only
- -- Set.empty -- first
- -- Set.empty -- middle
- -- (Set.singleton Intercalate) -- last
- -- ) (markAST l) pbs
- -- )
- -- (
- -- unsetContext Intercalate $
- -- markListWithContextsFunction
- -- (LC Set.empty -- only
- -- (Set.fromList [AddVbar]) -- first
- -- (Set.fromList [AddVbar]) -- middle
- -- Set.empty -- last
- -- ) (markAST l) pbs
- -- )
- -- markTrailingSemi
-
-
--- pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
--- , trS_using = using, trS_form = form })
--- = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
-
- exact (TransStmt an form stmts _b using by _ _ _) = do
- debugM $ "TransStmt"
- markAnnotated stmts
- exactTransStmt an by using form
-
- -- markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do
- -- setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts
- -- case form of
- -- GHC.ThenForm -> do
- -- mark GHC.AnnThen
- -- unsetContext Intercalate $ markLocated using
- -- case by of
- -- Just b -> do
- -- mark GHC.AnnBy
- -- unsetContext Intercalate $ markLocated b
- -- Nothing -> return ()
- -- GHC.GroupForm -> do
- -- mark GHC.AnnThen
- -- mark GHC.AnnGroup
- -- case by of
- -- Just b -> mark GHC.AnnBy >> markLocated b
- -- Nothing -> return ()
- -- mark GHC.AnnUsing
- -- markLocated using
- -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
- -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
- -- markTrailingSemi
-
- exact (RecStmt an stmts _ _ _ _ _) = do
- debugM $ "RecStmt"
- markLocatedAAL an al_rest AnnRec
- markAnnList True an (markAnnotated stmts)
-
- -- markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do
- -- mark GHC.AnnRec
- -- markOptional GHC.AnnOpenC
- -- markInside GHC.AnnSemi
- -- markListWithLayout stmts
- -- markOptional GHC.AnnCloseC
- -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
- -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
- -- markTrailingSemi
+ pbs' <- markAnnotated pbs
+ return (ParStmt a pbs' b c)
- -- exact x = error $ "exact CmdLStmt for:" ++ showAst x
- -- exact x = error $ "exact CmdLStmt for:"
+ exact (TransStmt an form stmts b using by c d e) = do
+ debugM $ "TransStmt"
+ stmts' <- markAnnotated stmts
+ (an', by', using') <- exactTransStmt an by using form
+ return (TransStmt an' form stmts' b using' by' c d e)
+ exact (RecStmt an stmts a b c d e) = do
+ debugM $ "RecStmt"
+ an0 <- markEpAnnL an lal_rest AnnRec
+ (an1, stmts') <- markAnnList True an0 (markAnnotated stmts)
+ return (RecStmt an1 stmts' a b c d e)
-- ---------------------------------------------------------------------
instance ExactPrint (ParStmtBlock GhcPs GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts
-
-exactTransStmt :: EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP ()
+ setAnnotationAnchor a _ _ = a
+ exact (ParStmtBlock a stmts b c) = do
+ stmts' <- markAnnotated stmts
+ return (ParStmtBlock a stmts' b c)
+
+exactTransStmt :: (Monad m, Monoid w)
+ => EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm
+ -> EP w m (EpAnn [AddEpAnn], Maybe (LHsExpr GhcPs), (LHsExpr GhcPs))
exactTransStmt an by using ThenForm = do
debugM $ "exactTransStmt:ThenForm"
- markEpAnn an AnnThen
- markAnnotated using
+ an0 <- markEpAnnL an lidl AnnThen
+ using' <- markAnnotated using
case by of
- Nothing -> return ()
+ Nothing -> return (an0, by, using')
Just b -> do
- markEpAnn an AnnBy
- markAnnotated b
+ an1 <- markEpAnnL an0 lidl AnnBy
+ b' <- markAnnotated b
+ return (an1, Just b', using')
exactTransStmt an by using GroupForm = do
debugM $ "exactTransStmt:GroupForm"
- markEpAnn an AnnThen
- markEpAnn an AnnGroup
- case by of
+ an0 <- markEpAnnL an lidl AnnThen
+ an1 <- markEpAnnL an0 lidl AnnGroup
+ (an2, by') <- case by of
+ Nothing -> return (an1, by)
Just b -> do
- markEpAnn an AnnBy
- markAnnotated b
- Nothing -> return ()
- markEpAnn an AnnUsing
- markAnnotated using
+ an2 <- markEpAnnL an1 lidl AnnBy
+ b' <- markAnnotated b
+ return (an2, Just b')
+ an3 <- markEpAnnL an2 lidl AnnUsing
+ using' <- markAnnotated using
+ return (an3, by', using')
-- ---------------------------------------------------------------------
@@ -2567,57 +3422,44 @@ instance ExactPrint (TyClDecl GhcPs) where
getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an
getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an
- exact (FamDecl _ decl) = do
- markAnnotated decl
+ setAnnotationAnchor a@FamDecl{} _ _s = a
+ setAnnotationAnchor x@SynDecl{} anc cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc cs }
+ setAnnotationAnchor x@DataDecl{} anc cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc cs }
+ setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a, b) }
+ where
+ (an,a,b) = tcdCExt x
+
+ exact (FamDecl a decl) = do
+ decl' <- markAnnotated decl
+ return (FamDecl a decl')
exact (SynDecl { tcdSExt = an
, tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
, tcdRhs = rhs }) = do
- -- There may be arbitrary parens around parts of the constructor that are
- -- infix.
- -- Turn these into comments so that they feed into the right place automatically
- annotationsToComments (epAnnAnns an) [AnnOpenP,AnnCloseP]
- markEpAnn an AnnType
-
- -- markTyClass Nothing fixity ln tyvars
- exactVanillaDeclHead ltycon tyvars fixity Nothing
- markEpAnn an AnnEqual
- markAnnotated rhs
-
- -- ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
- -- , tcdRhs = rhs })
- -- = hang (text "type" <+>
- -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals)
- -- 4 (ppr rhs)
--- {-
--- SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs
--- , tcdLName :: Located (IdP pass) -- ^ Type constructor
--- , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an
--- -- associated type these
--- -- include outer binders
--- , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
--- , tcdRhs :: LHsType pass } -- ^ RHS of type declaration
-
--- -}
--- markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do
--- -- There may be arbitrary parens around parts of the constructor that are
--- -- infix.
--- -- Turn these into comments so that they feed into the right place automatically
--- -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
--- mark GHC.AnnType
-
--- markTyClass Nothing fixity ln tyvars
--- mark GHC.AnnEqual
--- markLocated typ
--- markTrailingSemi
-
+ -- There may be arbitrary parens around parts of the constructor
+ -- that are infix. Turn these into comments so that they feed
+ -- into the right place automatically
+ an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP]
+ an1 <- markEpAnnL an0 lidl AnnType
+
+ (_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing
+ an2 <- markEpAnnL an1 lidl AnnEqual
+ rhs' <- markAnnotated rhs
+ return (SynDecl { tcdSExt = an2
+ , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity
+ , tcdRhs = rhs' })
+
+ -- TODO: add a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20452
exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars
- , tcdFixity = fixity, tcdDataDefn = defn }) =
- exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn
+ , tcdFixity = fixity, tcdDataDefn = defn }) = do
+ (_, an', ltycon', tyvars', _, _mctxt', defn') <-
+ exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn
+ return (DataDecl { tcdDExt = an', tcdLName = ltycon', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdDataDefn = defn' })
-- -----------------------------------
- exact (ClassDecl {tcdCExt = (an, sortKey, _),
+ exact (ClassDecl {tcdCExt = (an, sortKey, lo),
tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdFDs = fds,
@@ -2627,47 +3469,74 @@ instance ExactPrint (TyClDecl GhcPs) where
-- TODO: add a test that demonstrates tcdDocs
| null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
= do
- top_matter
- markEpAnn an AnnOpenC
- markEpAnn an AnnCloseC
+ (an0, fds', lclas', tyvars',context') <- top_matter
+ an1 <- markEpAnnL an0 lidl AnnOpenC
+ an2 <- markEpAnnL an1 lidl AnnCloseC
+ return (ClassDecl {tcdCExt = (an2, sortKey, lo),
+ tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',
+ tcdFixity = fixity,
+ tcdFDs = fds',
+ tcdSigs = sigs, tcdMeths = methods,
+ tcdATs = ats, tcdATDefs = at_defs,
+ tcdDocs = _docs})
| otherwise -- Laid out
= do
- top_matter
- markEpAnn an AnnOpenC
- markEpAnnAll an id AnnSemi
- withSortKey sortKey
+ (an0, fds', lclas', tyvars',context') <- top_matter
+ an1 <- markEpAnnL an0 lidl AnnOpenC
+ an2 <- markEpAnnAllL an1 lidl AnnSemi
+ ds <- withSortKey sortKey
(prepareListAnnotationA sigs
++ prepareListAnnotationA (bagToList methods)
++ prepareListAnnotationA ats
++ prepareListAnnotationA at_defs
-- ++ prepareListAnnotation docs
)
- markEpAnn an AnnCloseC
+ an3 <- markEpAnnL an2 lidl AnnCloseC
+ let
+ sigs' = undynamic ds
+ methods' = listToBag $ undynamic ds
+ ats' = undynamic ds
+ at_defs' = undynamic ds
+ return (ClassDecl {tcdCExt = (an3, sortKey, lo),
+ tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',
+ tcdFixity = fixity,
+ tcdFDs = fds',
+ tcdSigs = sigs', tcdMeths = methods',
+ tcdATs = ats', tcdATDefs = at_defs',
+ tcdDocs = _docs})
where
top_matter = do
- annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP]
- markEpAnn an AnnClass
- exactVanillaDeclHead lclas tyvars fixity context
- unless (null fds) $ do
- markEpAnn an AnnVbar
- markAnnotated fds
- markEpAnn an AnnWhere
+ an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
+ an0 <- markEpAnnL an' lidl AnnClass
+ (_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context
+ (an1, fds') <- if (null fds)
+ then return (an0, fds)
+ else do
+ an1 <- markEpAnnL an0 lidl AnnVbar
+ fds' <- markAnnotated fds
+ return (an1, fds')
+ an2 <- markEpAnnL an1 lidl AnnWhere
+ return (an2, fds', lclas', tyvars',context')
+
-- ---------------------------------------------------------------------
instance ExactPrint (FunDep GhcPs) where
getAnnotationEntry (FunDep an _ _) = fromAnn an
+ setAnnotationAnchor (FunDep an a b) anc cs = FunDep (setAnchorEpa an anc cs) a b
exact (FunDep an ls rs') = do
- markAnnotated ls
- markEpAnn an AnnRarrow
- markAnnotated rs'
+ ls' <- markAnnotated ls
+ an0 <- markEpAnnL an lidl AnnRarrow
+ rs'' <- markAnnotated rs'
+ return (FunDep an0 ls' rs'')
-- ---------------------------------------------------------------------
instance ExactPrint (FamilyDecl GhcPs) where
getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an
+ setAnnotationAnchor x anc cs = x { fdExt = setAnchorEpa (fdExt x) anc cs}
exact (FamilyDecl { fdExt = an
, fdInfo = info
@@ -2675,162 +3544,192 @@ instance ExactPrint (FamilyDecl GhcPs) where
, fdLName = ltycon
, fdTyVars = tyvars
, fdFixity = fixity
- , fdResultSig = L _ result
+ , fdResultSig = L lr result
, fdInjectivityAnn = mb_inj }) = do
- -- = vcat [ pprFlavour info <+> pp_top_level <+>
- -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+>
- -- pp_kind <+> pp_inj <+> pp_where
- -- , nest 2 $ pp_eqns ]
- exactFlavour an info
- exact_top_level
- annotationsToCommentsA an [AnnOpenP,AnnCloseP]
- exactVanillaDeclHead ltycon tyvars fixity Nothing
- exact_kind
- case mb_inj of
- Nothing -> return ()
- Just inj -> do
- markEpAnn an AnnVbar
- markAnnotated inj
- case info of
- ClosedTypeFamily mb_eqns -> do
- markEpAnn an AnnWhere
- markEpAnn an AnnOpenC
- case mb_eqns of
- Nothing -> markEpAnn an AnnDotdot
- Just eqns -> markAnnotated eqns
- markEpAnn an AnnCloseC
- _ -> return ()
+ an0 <- exactFlavour an info
+ an1 <- exact_top_level an0
+ an2 <- annotationsToComments an1 lidl [AnnOpenP,AnnCloseP]
+ (_, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing
+ (an3, result') <- exact_kind an2
+ (an4, mb_inj') <-
+ case mb_inj of
+ Nothing -> return (an3, mb_inj)
+ Just inj -> do
+ an4 <- markEpAnnL an3 lidl AnnVbar
+ inj' <- markAnnotated inj
+ return (an4, Just inj')
+ (an5, info') <-
+ case info of
+ ClosedTypeFamily mb_eqns -> do
+ an5 <- markEpAnnL an4 lidl AnnWhere
+ an6 <- markEpAnnL an5 lidl AnnOpenC
+ (an7, mb_eqns') <-
+ case mb_eqns of
+ Nothing -> do
+ an7 <- markEpAnnL an6 lidl AnnDotdot
+ return (an7, mb_eqns)
+ Just eqns -> do
+ eqns' <- markAnnotated eqns
+ return (an6, Just eqns')
+ an8 <- markEpAnnL an7 lidl AnnCloseC
+ return (an8, ClosedTypeFamily mb_eqns')
+ _ -> return (an4, info)
+ return (FamilyDecl { fdExt = an5
+ , fdInfo = info'
+ , fdTopLevel = top_level
+ , fdLName = ltycon'
+ , fdTyVars = tyvars'
+ , fdFixity = fixity
+ , fdResultSig = L lr result'
+ , fdInjectivityAnn = mb_inj' })
where
- exact_top_level = case top_level of
- TopLevel -> markEpAnn an AnnFamily
- NotTopLevel -> do
- -- It seems that in some kind of legacy
- -- mode the 'family' keyword is still
- -- accepted.
- markEpAnn an AnnFamily
- return ()
-
- exact_kind = case result of
- NoSig _ -> return ()
- KindSig _ kind -> markEpAnn an AnnDcolon >> markAnnotated kind
- TyVarSig _ tv_bndr -> markEpAnn an AnnEqual >> markAnnotated tv_bndr
-
- -- exact_inj = case mb_inj of
- -- Just (L _ (InjectivityAnn _ lhs rhs)) ->
- -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
- -- Nothing -> empty
- -- (pp_where, pp_eqns) = case info of
- -- ClosedTypeFamily mb_eqns ->
- -- ( text "where"
- -- , case mb_eqns of
- -- Nothing -> text ".."
- -- Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
- -- _ -> (empty, empty)
-
-exactFlavour :: EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EPP ()
-exactFlavour an DataFamily = markEpAnn an AnnData
-exactFlavour an OpenTypeFamily = markEpAnn an AnnType
-exactFlavour an (ClosedTypeFamily {}) = markEpAnn an AnnType
-
--- instance Outputable (FamilyInfo pass) where
--- ppr info = pprFlavour info <+> text "family"
-
--- ---------------------------------------------------------------------
-
-exactDataDefn :: EpAnn [AddEpAnn]
- -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header
- -> HsDataDefn GhcPs
- -> EPP ()
+ exact_top_level an' =
+ case top_level of
+ TopLevel -> markEpAnnL an' lidl AnnFamily
+ NotTopLevel -> do
+ -- It seems that in some kind of legacy
+ -- mode the 'family' keyword is still
+ -- accepted.
+ markEpAnnL an' lidl AnnFamily
+
+ exact_kind an' =
+ case result of
+ NoSig _ -> return (an', result)
+ KindSig x kind -> do
+ an0 <- markEpAnnL an' lidl AnnDcolon
+ kind' <- markAnnotated kind
+ return (an0, KindSig x kind')
+ TyVarSig x tv_bndr -> do
+ an0 <- markEpAnnL an' lidl AnnEqual
+ tv_bndr' <- markAnnotated tv_bndr
+ return (an0, TyVarSig x tv_bndr')
+
+
+exactFlavour :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EP w m (EpAnn [AddEpAnn])
+exactFlavour an DataFamily = markEpAnnL an lidl AnnData
+exactFlavour an OpenTypeFamily = markEpAnnL an lidl AnnType
+exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType
+
+-- ---------------------------------------------------------------------
+
+exactDataDefn
+ :: (Monad m, Monoid w)
+ => EpAnn [AddEpAnn]
+ -> (Maybe (LHsContext GhcPs) -> EP w m (EpAnn [AddEpAnn]
+ , LocatedN RdrName
+ , a
+ , b
+ , Maybe (LHsContext GhcPs))) -- Printing the header
+ -> HsDataDefn GhcPs
+ -> EP w m ( EpAnn [AddEpAnn] -- ^ from exactHdr
+ , EpAnn [AddEpAnn] -- ^ updated one passed in
+ , LocatedN RdrName, a, b, Maybe (LHsContext GhcPs), HsDataDefn GhcPs)
exactDataDefn an exactHdr
- (HsDataDefn { dd_ctxt = context
+ (HsDataDefn { dd_ext = x, dd_ctxt = context
, dd_cType = mb_ct
, dd_kindSig = mb_sig
, dd_cons = condecls, dd_derivs = derivings }) = do
- annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP]
- markEpAnn an $ case condecls of
+
+ an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
+
+ an0 <- markEpAnnL an' lidl $ case condecls of
DataTypeCons _ _ -> AnnData
- NewTypeCon _ -> AnnNewtype
- markEpAnn an AnnInstance -- optional
- mapM_ markAnnotated mb_ct
- exactHdr context
- case mb_sig of
- Nothing -> return ()
- Just kind -> do
- markEpAnn an AnnDcolon
- markAnnotated kind
- when (isGadt condecls) $ markEpAnn an AnnWhere
- markEpAnn an AnnOpenC
- exact_condecls an (toList condecls)
- markEpAnn an AnnCloseC
- mapM_ markAnnotated derivings
- return ()
+ NewTypeCon _ -> AnnNewtype
-exactVanillaDeclHead :: LocatedN RdrName
+ an1 <- markEpAnnL an0 lidl AnnInstance -- optional
+ mb_ct' <- mapM markAnnotated mb_ct
+ (anx, ln', tvs', b, mctxt') <- exactHdr context
+ (an2, mb_sig') <- case mb_sig of
+ Nothing -> return (an1, Nothing)
+ Just kind -> do
+ an2 <- markEpAnnL an1 lidl AnnDcolon
+ kind' <- markAnnotated kind
+ return (an2, Just kind')
+ an3 <- if (needsWhere condecls)
+ then markEpAnnL an2 lidl AnnWhere
+ else return an2
+ an4 <- markEpAnnL an3 lidl AnnOpenC
+ (an5, condecls') <- exact_condecls an4 (toList condecls)
+ let condecls'' = case condecls of
+ DataTypeCons d _ -> DataTypeCons d condecls'
+ NewTypeCon _ -> case condecls' of
+ [decl] -> NewTypeCon decl
+ _ -> panic "exacprint NewTypeCon"
+ an6 <- markEpAnnL an5 lidl AnnCloseC
+ derivings' <- mapM markAnnotated derivings
+ return (anx, an6, ln', tvs', b, mctxt',
+ (HsDataDefn { dd_ext = x, dd_ctxt = context
+ , dd_cType = mb_ct'
+ , dd_kindSig = mb_sig'
+ , dd_cons = condecls'', dd_derivs = derivings' }))
+
+
+exactVanillaDeclHead :: (Monad m, Monoid w)
+ => LocatedN RdrName
-> LHsQTyVars GhcPs
-> LexicalFixity
-> Maybe (LHsContext GhcPs)
- -> EPP ()
-exactVanillaDeclHead thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do
+ -> EP w m ( EpAnn [AddEpAnn]
+ , LocatedN RdrName
+ , LHsQTyVars GhcPs
+ , (), Maybe (LHsContext GhcPs))
+exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do
let
- exact_tyvars :: [LHsTyVarBndr () GhcPs] -> EPP ()
exact_tyvars (varl:varsr)
| fixity == Infix && length varsr > 1 = do
- -- = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)
- -- , (ppr.unLoc) (head varsr), char ')'
- -- , hsep (map (ppr.unLoc) (tail vaprsr))]
- markAnnotated varl
- markAnnotated thing
- markAnnotated (head varsr)
- markAnnotated (tail varsr)
- return ()
+ varl' <- markAnnotated varl
+ thing' <- markAnnotated thing
+ hvarsr <- markAnnotated (head varsr)
+ tvarsr <- markAnnotated (tail varsr)
+ return (thing', varl':hvarsr:tvarsr)
| fixity == Infix = do
- -- = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
- -- , hsep (map (ppr.unLoc) varsr)]
- markAnnotated varl
- markAnnotated thing
- markAnnotated varsr
- return ()
+ varl' <- markAnnotated varl
+ thing' <- markAnnotated thing
+ varsr' <- markAnnotated varsr
+ return (thing', varl':varsr')
| otherwise = do
- -- hsep [ pprPrefixOcc (unLoc thing)
- -- , hsep (map (ppr.unLoc) (varl:varsr))]
- markAnnotated thing
- mapM_ markAnnotated (varl:varsr)
- return ()
+ thing' <- markAnnotated thing
+ vs <- mapM markAnnotated (varl:varsr)
+ return (thing', vs)
exact_tyvars [] = do
- -- pprPrefixOcc (unLoc thing)
- markAnnotated thing
- mapM_ markAnnotated context
- exact_tyvars tyvars
+ thing' <- markAnnotated thing
+ return (thing', [])
+ context' <- mapM markAnnotated context
+ (thing', tyvars') <- exact_tyvars tyvars
+ return (EpAnnNotUsed, thing', tvs { hsq_explicit = tyvars' }, (), context')
-- ---------------------------------------------------------------------
instance ExactPrint (InjectivityAnn GhcPs) where
getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an
+ setAnnotationAnchor (InjectivityAnn an a b) anc cs = InjectivityAnn (setAnchorEpa an anc cs) a b
exact (InjectivityAnn an lhs rhs) = do
- markEpAnn an AnnVbar
- markAnnotated lhs
- markEpAnn an AnnRarrow
- mapM_ markAnnotated rhs
- -- Just (L _ (InjectivityAnn _ lhs rhs)) ->
- -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
- -- Nothing -> empty
+ an0 <- markEpAnnL an lidl AnnVbar
+ lhs' <- markAnnotated lhs
+ an1 <- markEpAnnL an0 lidl AnnRarrow
+ rhs' <- mapM markAnnotated rhs
+ return (InjectivityAnn an1 lhs' rhs')
-- ---------------------------------------------------------------------
class Typeable flag => ExactPrintTVFlag flag where
- exactTVDelimiters :: EpAnn [AddEpAnn] -> flag -> Annotated () -> Annotated ()
+ exactTVDelimiters :: (Monad m, Monoid w)
+ => EpAnn [AddEpAnn] -> flag -> EP w m (HsTyVarBndr flag GhcPs)
+ -> EP w m (EpAnn [AddEpAnn], (HsTyVarBndr flag GhcPs))
instance ExactPrintTVFlag () where
exactTVDelimiters an _ thing_inside = do
- markEpAnnAll an id AnnOpenP
- thing_inside
- markEpAnnAll an id AnnCloseP
+ an0 <- markEpAnnAllL an lid AnnOpenP
+ r <- thing_inside
+ an1 <- markEpAnnAllL an0 lid AnnCloseP
+ return (an1, r)
instance ExactPrintTVFlag Specificity where
exactTVDelimiters an s thing_inside = do
- markEpAnnAll an id open
- thing_inside
- markEpAnnAll an id close
+ an0 <- markEpAnnAllL an lid open
+ r <- thing_inside
+ an1 <- markEpAnnAllL an0 lid close
+ return (an1, r)
where
(open, close) = case s of
SpecifiedSpec -> (AnnOpenP, AnnCloseP)
@@ -2840,19 +3739,27 @@ instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where
getAnnotationEntry (UserTyVar an _ _) = fromAnn an
getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
- exact (UserTyVar an flag n) =
- exactTVDelimiters an flag $ markAnnotated n
- exact (KindedTyVar an flag n k) = exactTVDelimiters an flag $ do
- markAnnotated n
- markEpAnn an AnnDcolon
- markAnnotated k
+ setAnnotationAnchor (UserTyVar an a b) anc cs = UserTyVar (setAnchorEpa an anc cs) a b
+ setAnnotationAnchor (KindedTyVar an a b c) anc cs = KindedTyVar (setAnchorEpa an anc cs) a b c
--- ---------------------------------------------------------------------
+ exact (UserTyVar an flag n) = do
+ r <- exactTVDelimiters an flag $ do
+ n' <- markAnnotated n
+ return (UserTyVar an flag n')
+ case r of
+ (an', UserTyVar _ flag'' n'') -> return (UserTyVar an' flag'' n'')
+ _ -> error "KindedTyVar should never happen here"
+ exact (KindedTyVar an flag n k) = do
+ r <- exactTVDelimiters an flag $ do
+ n' <- markAnnotated n
+ an0 <- markEpAnnL an lidl AnnDcolon
+ k' <- markAnnotated k
+ return (KindedTyVar an0 flag n' k')
+ case r of
+ (an',KindedTyVar _ flag'' n'' k'') -> return (KindedTyVar an' flag'' n'' k'')
+ _ -> error "UserTyVar should never happen here"
--- NOTE: this is also an alias for LHsKind
--- instance ExactPrint (LHsType GhcPs) where
--- getAnnotationEntry = entryFromLocatedA
--- exact (L _ a) = markAnnotated a
+-- ---------------------------------------------------------------------
instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal
@@ -2879,95 +3786,145 @@ instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsWildCardTy _) = NoEntryVal
getAnnotationEntry (XHsType _) = NoEntryVal
-
- exact (HsForAllTy { hst_xforall = _an
+ setAnnotationAnchor a@(HsForAllTy _ _ _) _ _s = a
+ setAnnotationAnchor a@(HsQualTy _ _ _) _ _s = a
+ setAnnotationAnchor (HsTyVar an a b) anc cs = (HsTyVar (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor a@(HsAppTy _ _ _) _ _s = a
+ setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _s = a
+ setAnnotationAnchor (HsFunTy an a b c) anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsSumTy an a) anc cs = (HsSumTy (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _s = a
+ setAnnotationAnchor (HsParTy an a) anc cs = (HsParTy (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsIParamTy an a b) anc cs = (HsIParamTy (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor a@(HsStarTy _ _) _ _s = a
+ setAnnotationAnchor (HsKindSig an a b) anc cs = (HsKindSig (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor a@(HsSpliceTy _ _) _ _s = a
+ setAnnotationAnchor (HsDocTy an a b) anc cs = (HsDocTy (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsBangTy an a b) anc cs = (HsBangTy (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsRecTy an a) anc cs = (HsRecTy (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (HsExplicitListTy an a b) anc cs = (HsExplicitListTy (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsExplicitTupleTy an a) anc cs = (HsExplicitTupleTy (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(HsTyLit _ _) _ _s = a
+ setAnnotationAnchor a@(HsWildCardTy _) _ _s = a
+ setAnnotationAnchor a@(XHsType _) _ _s = a
+
+ exact (HsForAllTy { hst_xforall = an
, hst_tele = tele, hst_body = ty }) = do
- markAnnotated tele
- markAnnotated ty
-
- exact (HsQualTy _ ctxt ty) = do
- markAnnotated ctxt
- -- markEpAnn an AnnDarrow
- markAnnotated ty
+ tele' <- markAnnotated tele
+ ty' <- markAnnotated ty
+ return (HsForAllTy { hst_xforall = an
+ , hst_tele = tele', hst_body = ty' })
+
+ exact (HsQualTy an ctxt ty) = do
+ ctxt' <- markAnnotated ctxt
+ ty' <- markAnnotated ty
+ return (HsQualTy an ctxt' ty')
exact (HsTyVar an promoted name) = do
- when (promoted == IsPromoted) $ markEpAnn an AnnSimpleQuote
- markAnnotated name
-
- exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2
+ an0 <- if (promoted == IsPromoted)
+ then markEpAnnL an lidl AnnSimpleQuote
+ else return an
+ name' <- markAnnotated name
+ return (HsTyVar an0 promoted name')
+ exact (HsAppTy an t1 t2) = do
+ t1' <- markAnnotated t1
+ t2' <- markAnnotated t2
+ return (HsAppTy an t1' t2')
exact (HsAppKindTy ss ty ki) = do
- markAnnotated ty
+ ty' <- markAnnotated ty
printStringAtSs ss "@"
- markAnnotated ki
- exact (HsFunTy _an mult ty1 ty2) = do
- markAnnotated ty1
- markArrow mult
- markAnnotated ty2
+ ki' <- markAnnotated ki
+ return (HsAppKindTy ss ty' ki')
+ exact (HsFunTy an mult ty1 ty2) = do
+ ty1' <- markAnnotated ty1
+ mult' <- markArrow mult
+ ty2' <- markAnnotated ty2
+ return (HsFunTy an mult' ty1' ty2')
exact (HsListTy an tys) = do
- markOpeningParen an
- markAnnotated tys
- markClosingParen an
- exact (HsTupleTy an _con tys) = do
- markOpeningParen an
- markAnnotated tys
- markClosingParen an
+ an0 <- markOpeningParen an
+ tys' <- markAnnotated tys
+ an1 <- markClosingParen an0
+ return (HsListTy an1 tys')
+ exact (HsTupleTy an con tys) = do
+ an0 <- markOpeningParen an
+ tys' <- markAnnotated tys
+ an1 <- markClosingParen an0
+ return (HsTupleTy an1 con tys')
exact (HsSumTy an tys) = do
- markOpeningParen an
- markAnnotated tys
- markClosingParen an
+ an0 <- markOpeningParen an
+ tys' <- markAnnotated tys
+ an1 <- markClosingParen an0
+ return (HsSumTy an1 tys')
exact (HsOpTy an promoted t1 lo t2) = do
- when (isPromoted promoted) $ markEpAnn an AnnSimpleQuote
- markAnnotated t1
- markAnnotated lo
- markAnnotated t2
+ an0 <- if (isPromoted promoted)
+ then markEpAnnL an lidl AnnSimpleQuote
+ else return an
+ t1' <- markAnnotated t1
+ lo' <- markAnnotated lo
+ t2' <- markAnnotated t2
+ return (HsOpTy an0 promoted t1' lo' t2')
exact (HsParTy an ty) = do
- markOpeningParen an
- markAnnotated ty
- markClosingParen an
+ an0 <- markOpeningParen an
+ ty' <- markAnnotated ty
+ an1 <- markClosingParen an0
+ return (HsParTy an1 ty')
exact (HsIParamTy an n t) = do
- markAnnotated n
- markEpAnn an AnnDcolon
- markAnnotated t
- exact (HsStarTy _an isUnicode)
- = if isUnicode
+ n' <- markAnnotated n
+ an0 <- markEpAnnL an lidl AnnDcolon
+ t' <- markAnnotated t
+ return (HsIParamTy an0 n' t')
+ exact (HsStarTy an isUnicode) = do
+ if isUnicode
then printStringAdvance "\x2605" -- Unicode star
else printStringAdvance "*"
+ return (HsStarTy an isUnicode)
exact (HsKindSig an ty k) = do
- markAnnotated ty
- markEpAnn an AnnDcolon
- markAnnotated k
- exact (HsSpliceTy _ splice) = do
- markAnnotated splice
- -- exact x@(HsDocTy an _ _) = withPpr x
- exact (HsBangTy an (HsSrcBang mt _up str) ty) = do
- case mt of
- NoSourceText -> return ()
- SourceText src -> do
- debugM $ "HsBangTy: src=" ++ showAst src
- markLocatedAALS an id AnnOpen (Just src)
- markLocatedAALS an id AnnClose (Just "#-}")
- debugM $ "HsBangTy: done unpackedness"
- case str of
- SrcLazy -> markEpAnn an AnnTilde
- SrcStrict -> markEpAnn an AnnBang
- NoSrcStrict -> return ()
- markAnnotated ty
- -- exact x@(HsRecTy an _) = withPpr x
+ ty' <- markAnnotated ty
+ an0 <- markEpAnnL an lidl AnnDcolon
+ k' <- markAnnotated k
+ return (HsKindSig an0 ty' k')
+ exact (HsSpliceTy a splice) = do
+ splice' <- markAnnotated splice
+ return (HsSpliceTy a splice')
+ exact (HsBangTy an (HsSrcBang mt up str) ty) = do
+ an0 <-
+ case mt of
+ NoSourceText -> return an
+ SourceText src -> do
+ debugM $ "HsBangTy: src=" ++ showAst src
+ an0 <- markEpAnnLMS an lid AnnOpen (Just src)
+ an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}")
+ debugM $ "HsBangTy: done unpackedness"
+ return an1
+ an1 <-
+ case str of
+ SrcLazy -> markEpAnnL an0 lidl AnnTilde
+ SrcStrict -> markEpAnnL an0 lidl AnnBang
+ NoSrcStrict -> return an0
+ ty' <- markAnnotated ty
+ return (HsBangTy an1 (HsSrcBang mt up str) ty')
exact (HsExplicitListTy an prom tys) = do
- when (isPromoted prom) $ markEpAnn an AnnSimpleQuote
- markEpAnn an AnnOpenS
- markAnnotated tys
- markEpAnn an AnnCloseS
+ an0 <- if (isPromoted prom)
+ then markEpAnnL an lidl AnnSimpleQuote
+ else return an
+ an1 <- markEpAnnL an0 lidl AnnOpenS
+ tys' <- markAnnotated tys
+ an2 <- markEpAnnL an1 lidl AnnCloseS
+ return (HsExplicitListTy an2 prom tys')
exact (HsExplicitTupleTy an tys) = do
- markEpAnn an AnnSimpleQuote
- markEpAnn an AnnOpenP
- markAnnotated tys
- markEpAnn an AnnCloseP
- exact (HsTyLit _ lit) = do
+ an0 <- markEpAnnL an lidl AnnSimpleQuote
+ an1 <- markEpAnnL an0 lidl AnnOpenP
+ tys' <- markAnnotated tys
+ an2 <- markEpAnnL an1 lidl AnnCloseP
+ return (HsExplicitTupleTy an2 tys')
+ exact (HsTyLit a lit) = do
case lit of
(HsNumTy src v) -> printSourceText src (show v)
(HsStrTy src v) -> printSourceText src (show v)
(HsCharTy src v) -> printSourceText src (show v)
- exact (HsWildCardTy _) = printStringAdvance "_"
+ return (HsTyLit a lit)
+ exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t
exact x = error $ "missing match for HsType:" ++ showAst x
-- ---------------------------------------------------------------------
@@ -2976,45 +3933,42 @@ instance ExactPrint (HsForAllTelescope GhcPs) where
getAnnotationEntry (HsForAllVis an _) = fromAnn an
getAnnotationEntry (HsForAllInvis an _) = fromAnn an
+ setAnnotationAnchor (HsForAllVis an a) anc cs = HsForAllVis (setAnchorEpa an anc cs) a
+ setAnnotationAnchor (HsForAllInvis an a) anc cs = HsForAllInvis (setAnchorEpa an anc cs) a
+
exact (HsForAllVis an bndrs) = do
- markLocatedAA an fst -- AnnForall
- markAnnotated bndrs
- markLocatedAA an snd -- AnnRarrow
+ an0 <- markLensAA an lfst -- AnnForall
+ bndrs' <- markAnnotated bndrs
+ an1 <- markLensAA an0 lsnd -- AnnRarrow
+ return (HsForAllVis an1 bndrs')
exact (HsForAllInvis an bndrs) = do
- markLocatedAA an fst -- AnnForall
- markAnnotated bndrs
- markLocatedAA an snd -- AnnDot
+ an0 <- markLensAA an lfst -- AnnForall
+ bndrs' <- markAnnotated bndrs
+ an1 <- markLensAA an0 lsnd -- AnnDot
+ return (HsForAllInvis an1 bndrs')
-- ---------------------------------------------------------------------
instance ExactPrint (HsDerivingClause GhcPs) where
getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d)
+ setAnnotationAnchor x anc cs = (x { deriv_clause_ext = setAnchorEpa (deriv_clause_ext x) anc cs})
+ `debug` ("setAnnotationAnchor HsDerivingClause: (anc,cs):" ++ showAst (anc,cs))
exact (HsDerivingClause { deriv_clause_ext = an
, deriv_clause_strategy = dcs
, deriv_clause_tys = dct }) = do
- -- = hsep [ text "deriving"
- -- , pp_strat_before
- -- , pp_dct dct
- -- , pp_strat_after ]
- markEpAnn an AnnDeriving
+ an0 <- markEpAnnL an lidl AnnDeriving
exact_strat_before
- markAnnotated dct
+ dct' <- markAnnotated dct
exact_strat_after
+ return (HsDerivingClause { deriv_clause_ext = an0
+ , deriv_clause_strategy = dcs
+ , deriv_clause_tys = dct' })
where
- -- -- This complexity is to distinguish between
- -- -- deriving Show
- -- -- deriving (Show)
- -- pp_dct [HsIB { hsib_body = ty }]
- -- = ppr (parenthesizeHsType appPrec ty)
- -- pp_dct _ = parens (interpp'SP dct)
-
- -- @via@ is unique in that in comes /after/ the class being derived,
- -- so we must special-case it.
(exact_strat_before, exact_strat_after) =
case dcs of
- Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v)
+ Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v >> pure ())
_ -> (mapM_ markAnnotated dcs, pure ())
-- ---------------------------------------------------------------------
@@ -3025,104 +3979,151 @@ instance ExactPrint (DerivStrategy GhcPs) where
getAnnotationEntry (NewtypeStrategy an) = fromAnn an
getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an
- exact (StockStrategy an) = markEpAnn an AnnStock
- exact (AnyclassStrategy an) = markEpAnn an AnnAnyclass
- exact (NewtypeStrategy an) = markEpAnn an AnnNewtype
- exact (ViaStrategy (XViaStrategyPs an ty))
- = markEpAnn an AnnVia >> markAnnotated ty
+ setAnnotationAnchor (StockStrategy an) anc cs = (StockStrategy (setAnchorEpa an anc cs))
+ setAnnotationAnchor (AnyclassStrategy an) anc cs = (AnyclassStrategy (setAnchorEpa an anc cs))
+ setAnnotationAnchor (NewtypeStrategy an) anc cs = (NewtypeStrategy (setAnchorEpa an anc cs))
+ setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc cs) a))
+
+ exact (StockStrategy an) = do
+ an0 <- markEpAnnL an lid AnnStock
+ return (StockStrategy an0)
+ exact (AnyclassStrategy an) = do
+ an0 <- markEpAnnL an lid AnnAnyclass
+ return (AnyclassStrategy an0)
+ exact (NewtypeStrategy an) = do
+ an0 <- markEpAnnL an lid AnnNewtype
+ return (NewtypeStrategy an0)
+ exact (ViaStrategy (XViaStrategyPs an ty)) = do
+ an0 <- markEpAnnL an lid AnnVia
+ ty' <- markAnnotated ty
+ return (ViaStrategy (XViaStrategyPs an0 ty'))
-- ---------------------------------------------------------------------
instance (ExactPrint a) => ExactPrint (LocatedC a) where
getAnnotationEntry (L sann _) = fromAnn sann
+ setAnnotationAnchor = setAnchorAn
- exact (L (SrcSpanAnn EpAnnNotUsed _) a) = markAnnotated a
- exact (L (SrcSpanAnn (EpAnn _ (AnnContext ma opens closes) _) _) a) = do
- -- case ma of
- -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs
- -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs
- -- Nothing -> pure ()
- mapM_ (markKwA AnnOpenP) (sortBy (comparing unsafeGetEpaLoc) opens)
- markAnnotated a
- mapM_ (markKwA AnnCloseP) (sortBy (comparing unsafeGetEpaLoc) closes)
- case ma of
- Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r
- Just (NormalSyntax, r) -> markKwA AnnDarrow r
- Nothing -> pure ()
+ exact (L (SrcSpanAnn EpAnnNotUsed l) a) = do
+ a' <- markAnnotated a
+ return (L (SrcSpanAnn EpAnnNotUsed l) a')
+ exact (L (SrcSpanAnn (EpAnn anc (AnnContext ma opens closes) cs) l) a) = do
+ opens' <- mapM (markKwA AnnOpenP) opens
+ a' <- markAnnotated a
+ closes' <- mapM (markKwA AnnCloseP) closes
+ ma' <- case ma of
+ Just (UnicodeSyntax, r) -> Just . (UnicodeSyntax,) <$> markKwA AnnDarrowU r
+ Just (NormalSyntax, r) -> Just . (NormalSyntax,) <$> markKwA AnnDarrow r
+ Nothing -> pure Nothing
+ return (L (SrcSpanAnn (EpAnn anc (AnnContext ma' opens' closes') cs) l) a')
-- ---------------------------------------------------------------------
instance ExactPrint (DerivClauseTys GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (DctSingle _ ty) = markAnnotated ty
- exact (DctMulti _ tys) = do
- -- parens (interpp'SP tys)
- markAnnotated tys
+ exact (DctSingle x ty) = do
+ ty' <- markAnnotated ty
+ return (DctSingle x ty')
+ exact (DctMulti x tys) = do
+ tys' <- markAnnotated tys
+ return (DctMulti x tys')
-- ---------------------------------------------------------------------
instance ExactPrint (HsSigType GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (HsSig _ bndrs ty) = do
- markAnnotated bndrs
- markAnnotated ty
+ exact (HsSig a bndrs ty) = do
+ bndrs' <- markAnnotated bndrs
+ ty' <- markAnnotated ty
+ return (HsSig a bndrs' ty')
-- ---------------------------------------------------------------------
instance ExactPrint (LocatedN RdrName) where
getAnnotationEntry (L sann _) = fromAnn sann
-
- exact (L (SrcSpanAnn EpAnnNotUsed l) n) = do
- p <- getPosP
- debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n)
- let str = case (showPprUnsafe n) of
- -- TODO: unicode support?
- "forall" -> if spanLength (realSrcSpan l) == 1 then "∀" else "forall"
- s -> s
- printStringAtSs l str
- exact (L (SrcSpanAnn (EpAnn _anchor ann _cs) _ll) n) = do
- case ann of
- NameAnn a o l c t -> do
- markName a o (Just (l,n)) c
- markTrailing t
- NameAnnCommas a o cs c t -> do
- let (kwo,kwc) = adornments a
- markKw (AddEpAnn kwo o)
- forM_ cs (\loc -> markKw (AddEpAnn AnnComma loc))
- markKw (AddEpAnn kwc c)
- markTrailing t
- NameAnnBars a o bs c t -> do
- let (kwo,kwc) = adornments a
- markKw (AddEpAnn kwo o)
- forM_ bs (\loc -> markKw (AddEpAnn AnnVbar loc))
- markKw (AddEpAnn kwc c)
- markTrailing t
- NameAnnOnly a o c t -> do
- markName a o Nothing c
- markTrailing t
- NameAnnRArrow nl t -> do
- markKw (AddEpAnn AnnRarrow nl)
- markTrailing t
- NameAnnQuote q name t -> do
- debugM $ "NameAnnQuote"
- markKw (AddEpAnn AnnSimpleQuote q)
- markAnnotated (L name n)
- markTrailing t
- NameAnnTrailing t -> do
- printStringAdvance (showPprUnsafe n)
- markTrailing t
-
-markName :: NameAdornment
- -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation -> EPP ()
+ setAnnotationAnchor = setAnchorAn
+
+ exact x@(L (SrcSpanAnn EpAnnNotUsed l) n) = do
+ _ <- printUnicode (spanAsAnchor l) n
+ return x
+ exact (L (SrcSpanAnn (EpAnn anc ann cs) ll) n) = do
+ ann' <-
+ case ann of
+ NameAnn a o l c t -> do
+ mn <- markName a o (Just (l,n)) c
+ case mn of
+ (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')
+ t' <- markTrailing t
+ return (NameAnn a o' l' c' t')
+ _ -> error "ExactPrint (LocatedN RdrName)"
+ NameAnnCommas a o commas c t -> do
+ let (kwo,kwc) = adornments a
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o)
+ commas' <- forM commas (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnComma loc))
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c)
+ t' <- markTrailing t
+ return (NameAnnCommas a o' commas' c' t')
+ NameAnnBars a o bars c t -> do
+ let (kwo,kwc) = adornments a
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o)
+ bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc))
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c)
+ t' <- markTrailing t
+ return (NameAnnBars a o' bars' c' t')
+ NameAnnOnly a o c t -> do
+ (o',_,c') <- markName a o Nothing c
+ t' <- markTrailing t
+ return (NameAnnOnly a o' c' t')
+ NameAnnRArrow nl t -> do
+ (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ t' <- markTrailing t
+ return (NameAnnRArrow nl' t')
+ NameAnnQuote q name t -> do
+ debugM $ "NameAnnQuote"
+ (AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
+ (L name' _) <- markAnnotated (L name n)
+ t' <- markTrailing t
+ return (NameAnnQuote q' name' t')
+ NameAnnTrailing t -> do
+ _anc' <- printUnicode anc n
+ t' <- markTrailing t
+ return (NameAnnTrailing t')
+ return (L (SrcSpanAnn (EpAnn anc ann' cs) ll) n)
+
+locFromAdd :: AddEpAnn -> EpaLocation
+locFromAdd (AddEpAnn _ loc) = loc
+
+printUnicode :: (Monad m, Monoid w) => Anchor -> RdrName -> EP w m Anchor
+printUnicode anc n = do
+ let str = case (showPprUnsafe n) of
+ -- TODO: unicode support?
+ "forall" -> if spanLength (anchor anc) == 1 then "∀" else "forall"
+ s -> s
+ loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str
+ case loc of
+ EpaSpan _ -> return anc
+ EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp }
+ EpaDelta _ _cs -> error "printUnicode should not capture comments"
+
+
+markName :: (Monad m, Monoid w)
+ => NameAdornment -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation
+ -> EP w m (EpaLocation, Maybe (EpaLocation,RdrName), EpaLocation)
markName adorn open mname close = do
let (kwo,kwc) = adornments adorn
- markKw (AddEpAnn kwo open)
- case mname of
- Nothing -> return ()
- Just (name, a) -> printStringAtAA name (showPprUnsafe a)
- markKw (AddEpAnn kwc close)
+ (AddEpAnn _ open') <- markKwC CaptureComments (AddEpAnn kwo open)
+ mname' <-
+ case mname of
+ Nothing -> return Nothing
+ Just (name, a) -> do
+ name' <- printStringAtAAC CaptureComments name (showPprUnsafe a)
+ return (Just (name',a))
+ (AddEpAnn _ close') <- markKwC CaptureComments (AddEpAnn kwc close)
+ return (open', mname', close')
adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId)
adornments NameParens = (AnnOpenP, AnnCloseP)
@@ -3130,32 +4131,34 @@ adornments NameParensHash = (AnnOpenPH, AnnClosePH)
adornments NameBackquotes = (AnnBackquote, AnnBackquote)
adornments NameSquare = (AnnOpenS, AnnCloseS)
-markTrailing :: [TrailingAnn] -> EPP ()
+
+markTrailingL :: (Monad m, Monoid w) => EpAnn a -> Lens a [TrailingAnn] -> EP w m (EpAnn a)
+markTrailingL EpAnnNotUsed _ = return EpAnnNotUsed
+markTrailingL (EpAnn anc an cs) l = do
+ ts <- mapM markKwT (view l an)
+ return (EpAnn anc (set l ts an) cs)
+
+markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn]
markTrailing ts = do
p <- getPosP
debugM $ "markTrailing:" ++ showPprUnsafe (p,ts)
- mapM_ markKwT (sortBy (comparing (unsafeGetEpaLoc . k)) ts)
- where
- k (AddSemiAnn l) = l
- k (AddCommaAnn l) = l
- k (AddVbarAnn l) = l
+ mapM markKwT ts
-- ---------------------------------------------------------------------
-- based on pp_condecls in Decls.hs
-exact_condecls :: EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EPP ()
+exact_condecls :: (Monad m, Monoid w)
+ => EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EP w m (EpAnn [AddEpAnn],[LConDecl GhcPs])
exact_condecls an cs
| gadt_syntax -- In GADT syntax
- -- = hang (text "where") 2 (vcat (map ppr cs))
= do
- -- printStringAdvance "exact_condecls:gadt"
- mapM_ markAnnotated cs
+ cs' <- mapM markAnnotated cs
+ return (an, cs')
| otherwise -- In H98 syntax
- -- = equals <+> sep (punctuate (text " |") (map ppr cs))
= do
- -- printStringAdvance "exact_condecls:not gadt"
- markEpAnn an AnnEqual
- mapM_ markAnnotated cs
+ an0 <- markEpAnnL an lidl AnnEqual
+ cs' <- mapM markAnnotated cs
+ return (an0, cs')
where
gadt_syntax = case cs of
[] -> False
@@ -3168,6 +4171,9 @@ instance ExactPrint (ConDecl GhcPs) where
getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x)
getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x)
+ setAnnotationAnchor x@ConDeclGADT{} anc cs = x { con_g_ext = setAnchorEpa (con_g_ext x) anc cs}
+ setAnnotationAnchor x@ConDeclH98{} anc cs = x { con_ext = setAnchorEpa (con_ext x) anc cs}
+
-- based on pprConDecl
exact (ConDeclH98 { con_ext = an
, con_name = con
@@ -3176,36 +4182,45 @@ instance ExactPrint (ConDecl GhcPs) where
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc }) = do
- -- = sep [ ppr_mbDoc doc
- -- , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt
- -- , ppr_details args ]
- mapM_ markAnnotated doc
- when has_forall $ markEpAnn an AnnForall
- mapM_ markAnnotated ex_tvs
- when has_forall $ markEpAnn an AnnDot
- -- exactHsForall (mkHsForAllInvisTele ex_tvs) mcxt
- mapM_ markAnnotated mcxt
- when (isJust mcxt) $ markEpAnn an AnnDarrow
-
- exact_details args
-
- -- case args of
- -- InfixCon _ _ -> return ()
- -- _ -> markAnnotated con
+ doc' <- mapM markAnnotated doc
+ an0 <- if has_forall
+ then markEpAnnL an lidl AnnForall
+ else return an
+ ex_tvs' <- mapM markAnnotated ex_tvs
+ an1 <- if has_forall
+ then markEpAnnL an0 lidl AnnDot
+ else return an0
+ mcxt' <- mapM markAnnotated mcxt
+ an2 <- if (isJust mcxt)
+ then markEpAnnL an1 lidl AnnDarrow
+ else return an1
+
+ (con', args') <- exact_details args
+ return (ConDeclH98 { con_ext = an2
+ , con_name = con'
+ , con_forall = has_forall
+ , con_ex_tvs = ex_tvs'
+ , con_mb_cxt = mcxt'
+ , con_args = args'
+ , con_doc = doc' })
+
where
-- -- In ppr_details: let's not print the multiplicities (they are always 1, by
-- -- definition) as they do not appear in an actual declaration.
exact_details (InfixCon t1 t2) = do
- markAnnotated t1
- markAnnotated con
- markAnnotated t2
+ t1' <- markAnnotated t1
+ con' <- markAnnotated con
+ t2' <- markAnnotated t2
+ return (con', InfixCon t1' t2')
exact_details (PrefixCon tyargs tys) = do
- markAnnotated con
- markAnnotated tyargs
- markAnnotated tys
+ con' <- markAnnotated con
+ tyargs' <- markAnnotated tyargs
+ tys' <- markAnnotated tys
+ return (con', PrefixCon tyargs' tys')
exact_details (RecCon fields) = do
- markAnnotated con
- markAnnotated fields
+ con' <- markAnnotated con
+ fields' <- markAnnotated fields
+ return (con', RecCon fields')
-- -----------------------------------
@@ -3215,77 +4230,43 @@ instance ExactPrint (ConDecl GhcPs) where
, con_bndrs = bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc }) = do
- mapM_ markAnnotated doc
- mapM_ markAnnotated cons
- markUniToken dcol
- markEpAnn an AnnDcolon
- annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP]
- -- when has_forall $ markEpAnn an AnnForall
- markAnnotated bndrs
- -- mapM_ markAnnotated qvars
- -- when has_forall $ markEpAnn an AnnDot
- mapM_ markAnnotated mcxt
- when (isJust mcxt) $ markEpAnn an AnnDarrow
- -- mapM_ markAnnotated args
- case args of
- PrefixConGADT args' -> mapM_ markAnnotated args'
- RecConGADT fields arr -> do
- markAnnotated fields
- markUniToken arr
- -- mapM_ markAnnotated (unLoc fields)
- markAnnotated res_ty
- -- markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do
- -- setContext (Set.singleton PrefixOp) $ markListIntercalate lns
- -- mark GHC.AnnDcolon
- -- annotationsToComments [GHC.AnnOpenP]
- -- markLocated (GHC.L l (ResTyGADTHook forall qvars))
- -- markMaybe mbCxt
- -- markHsConDeclDetails False True lns args
- -- markLocated typ
- -- markManyOptional GHC.AnnCloseP
- -- markTrailingSemi
-
--- pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
--- , con_mb_cxt = mcxt, con_args = args
--- , con_res_ty = res_ty, con_doc = doc })
--- = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
--- <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) mcxt,
--- ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
--- where
--- get_args (PrefixCon args) = map ppr args
--- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
--- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr_con_names cons)
-
--- ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
--- ppr_arrow_chain [] = empty
-
--- ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
--- ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
-
-
--- ---------------------------------------------------------------------
-
--- exactHsForall :: HsForAllTelescope GhcPs
--- -> Maybe (LHsContext GhcPs) -> EPP ()
--- exactHsForall = exactHsForAllExtra False
-
--- exactHsForAllExtra :: Bool
--- -> HsForAllTelescope GhcPs
--- -> Maybe (LHsContext GhcPs) -> EPP ()
--- exactHsForAllExtra show_extra Nothing = return ()
--- exactHsForAllExtra show_extra lctxt@(Just ctxt)
--- | not show_extra = markAnnotated ctxt
--- -- | null ctxt = char '_' <+> darrow
--- | null ctxt = return ()
--- | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow
--- where
--- ctxt' = map ppr ctxt ++ [char '_']
+ doc' <- mapM markAnnotated doc
+ cons' <- mapM markAnnotated cons
+ dcol' <- markUniToken dcol
+ an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
+
+ -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558
+ bndrs' <- case bndrs of
+ L _ (HsOuterImplicit _) -> return bndrs
+ _ -> markAnnotated bndrs
+
+ mcxt' <- mapM markAnnotated mcxt
+ an2 <- if (isJust mcxt)
+ then markEpAnnL an1 lidl AnnDarrow
+ else return an1
+ args' <-
+ case args of
+ (PrefixConGADT args0) -> do
+ args0' <- mapM markAnnotated args0
+ return (PrefixConGADT args0')
+ (RecConGADT fields rarr) -> do
+ fields' <- markAnnotated fields
+ rarr' <- markUniToken rarr
+ return (RecConGADT fields' rarr')
+ res_ty' <- markAnnotated res_ty
+ return (ConDeclGADT { con_g_ext = an2
+ , con_names = cons'
+ , con_dcolon = dcol'
+ , con_bndrs = bndrs'
+ , con_mb_cxt = mcxt', con_g_args = args'
+ , con_res_ty = res_ty', con_doc = doc' })
-- ---------------------------------------------------------------------
instance ExactPrint Void where
getAnnotationEntry = const NoEntryVal
- exact _ = return ()
+ setAnnotationAnchor a _ _ = a
+ exact x = return x
-- ---------------------------------------------------------------------
@@ -3293,74 +4274,84 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher
getAnnotationEntry (HsOuterImplicit _) = NoEntryVal
getAnnotationEntry (HsOuterExplicit an _) = fromAnn an
- exact (HsOuterImplicit _) = pure ()
+ setAnnotationAnchor (HsOuterImplicit a) _ _ = HsOuterImplicit a
+ setAnnotationAnchor (HsOuterExplicit an a) anc cs = HsOuterExplicit (setAnchorEpa an anc cs) a
+
+ exact b@(HsOuterImplicit _) = pure b
exact (HsOuterExplicit an bndrs) = do
- markLocatedAA an fst -- "forall"
- markAnnotated bndrs
- markLocatedAA an snd -- "."
+ an0 <- markLensAA an lfst -- "forall"
+ bndrs' <- markAnnotated bndrs
+ an1 <- markLensAA an0 lsnd -- "."
+ return (HsOuterExplicit an1 bndrs')
-- ---------------------------------------------------------------------
instance ExactPrint (ConDeclField GhcPs) where
getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f)
+ setAnnotationAnchor x anc cs = x { cd_fld_ext = setAnchorEpa (cd_fld_ext x) anc cs}
+
exact (ConDeclField an names ftype mdoc) = do
- markAnnotated names
- markEpAnn an AnnDcolon
- markAnnotated ftype
- mapM_ markAnnotated mdoc
+ names' <- markAnnotated names
+ an0 <- markEpAnnL an lidl AnnDcolon
+ ftype' <- markAnnotated ftype
+ mdoc' <- mapM markAnnotated mdoc
+ return (ConDeclField an0 names' ftype' mdoc')
-- ---------------------------------------------------------------------
instance ExactPrint (FieldOcc GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (FieldOcc _ n) = markAnnotated n
+ setAnnotationAnchor a _ _ = a
+ exact f@(FieldOcc _ n) = markAnnotated n >> return f
-- ---------------------------------------------------------------------
instance ExactPrint (AmbiguousFieldOcc GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (Unambiguous _ n) = markAnnotated n
- exact (Ambiguous _ n) = markAnnotated n
+ setAnnotationAnchor a _ _ = a
+ exact f@(Unambiguous _ n) = markAnnotated n >> return f
+ exact f@(Ambiguous _ n) = markAnnotated n >> return f
-- ---------------------------------------------------------------------
instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact (HsScaled arr t) = do
- markAnnotated t
- markArrow arr
-
--- ---------------------------------------------------------------------
-
--- instance ExactPrint (LHsContext GhcPs) where
--- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
--- exact = withPpr
+ t' <- markAnnotated t
+ arr' <- markArrow arr
+ return (HsScaled arr' t')
-- ---------------------------------------------------------------------
instance ExactPrint (LocatedP CType) where
getAnnotationEntry = entryFromLocatedA
+ setAnnotationAnchor = setAnchorAn
- exact (L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct
- exact (L (SrcSpanAnn an _ll)
+ exact x@(L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct >> return x
+ exact (L (SrcSpanAnn an ll)
(CType stp mh (stct,ct))) = do
- markAnnOpenP an stp "{-# CTYPE"
- case mh of
- Nothing -> return ()
- Just (Header srcH _h) ->
- markLocatedAALS an apr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" ""))
- markLocatedAALS an apr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) ""))
- markAnnCloseP an
+ an0 <- markAnnOpenP an stp "{-# CTYPE"
+ an1 <- case mh of
+ Nothing -> return an0
+ Just (Header srcH _h) ->
+ markEpAnnLMS an0 lapr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" ""))
+ an2 <- markEpAnnLMS an1 lapr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) ""))
+ an3 <- markAnnCloseP an2
+ return (L (SrcSpanAnn an3 ll)
+ (CType stp mh (stct,ct)))
-- ---------------------------------------------------------------------
instance ExactPrint (SourceText, RuleName) where
-- We end up at the right place from the Located wrapper
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact (st, rn)
= printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "")
+ >> return (st, rn)
-- =====================================================================
@@ -3374,98 +4365,75 @@ instance ExactPrint (SourceText, RuleName) where
-- applied.
-- ---------------------------------------------------------------------
--- instance (ExactPrint body) => ExactPrint (LocatedL body) where
--- getAnnotationEntry = entryFromLocatedA
--- exact (L (SrcSpanAnn an _) b) = do
--- markLocatedMAA an al_open
--- markEpAnnAll an al_rest AnnSemi
--- markAnnotated b
--- markLocatedMAA an al_close
-
instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where
getAnnotationEntry = entryFromLocatedA
+ setAnnotationAnchor = setAnchorAn
- exact (L (SrcSpanAnn ann _) ies) = do
+ exact (L (SrcSpanAnn an l) ies) = do
debugM $ "LocatedL [LIE"
- markLocatedAAL ann al_rest AnnHiding
+ an0 <- markEpAnnL an lal_rest AnnHiding
p <- getPosP
debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p
- markAnnList True ann (markAnnotated ies)
+ (an1, ies') <- markAnnList True an0 (markAnnotated ies)
+ return (L (SrcSpanAnn an1 l) ies')
--- instance (ExactPrint (LocatedA body), (ExactPrint (Match GhcPs (LocatedA body)))) => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where
instance (ExactPrint (Match GhcPs (LocatedA body)))
=> ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where
getAnnotationEntry = entryFromLocatedA
+ setAnnotationAnchor = setAnchorAn
exact (L la a) = do
+ let an = ann la
debugM $ "LocatedL [LMatch"
-- TODO: markAnnList?
- markEpAnnAll (ann la) al_rest AnnWhere
- markLocatedMAA (ann la) al_open
- markEpAnnAll (ann la) al_rest AnnSemi
- markAnnotated a
- markLocatedMAA (ann la) al_close
-
-{-
--- AZ:TODO: combine with next instance
-instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))]) where
- getAnnotationEntry = entryFromLocatedA
- exact (L la a) = do
- debugM $ "LocatedL [LMatch"
- -- TODO: markAnnList?
- markEpAnnAll (ann la) al_rest AnnWhere
- markLocatedMAA (ann la) al_open
- markEpAnnAll (ann la) al_rest AnnSemi
- markAnnotated a
- markLocatedMAA (ann la) al_close
-
-instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsCmd GhcPs)))]) where
- getAnnotationEntry = entryFromLocatedA
- exact (L la a) = do
- debugM $ "LocatedL [LMatch"
- -- TODO: markAnnList?
- markEpAnnAll (ann la) al_rest AnnWhere
- markLocatedMAA (ann la) al_open
- markEpAnnAll (ann la) al_rest AnnSemi
- markAnnotated a
- markLocatedMAA (ann la) al_close
--}
+ an0 <- markEpAnnAllL an lal_rest AnnWhere
+ an1 <- markLensMAA an0 lal_open
+ an2 <- markEpAnnAllL an1 lal_rest AnnSemi
+ a' <- markAnnotated a
+ an3 <- markLensMAA an2 lal_close
+ return (L (la { ann = an3}) a')
--- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where
instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where
getAnnotationEntry = entryFromLocatedA
- exact (L (SrcSpanAnn an _) stmts) = do
+ setAnnotationAnchor = setAnchorAn
+ exact (L (SrcSpanAnn an l) stmts) = do
debugM $ "LocatedL [ExprLStmt"
- markAnnList True an $ do
- -- markLocatedMAA an al_open
+ (an'', stmts') <- markAnnList True an $ do
case snocView stmts of
Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
debugM $ "LocatedL [ExprLStmt: snocView"
- markAnnotated ls
- markAnnotated initStmts
- _ -> markAnnotated stmts
- -- x -> error $ "pprDo:ListComp" ++ showAst x
- -- markLocatedMAA an al_close
+ ls' <- markAnnotated ls
+ initStmts' <- markAnnotated initStmts
+ return (initStmts' ++ [ls'])
+ _ -> do
+ markAnnotated stmts
+ return (L (SrcSpanAnn an'' l) stmts')
-- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where
instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
getAnnotationEntry = entryFromLocatedA
- exact (L (SrcSpanAnn ann _) es) = do
+ setAnnotationAnchor = setAnchorAn
+ exact (L (SrcSpanAnn ann l) es) = do
debugM $ "LocatedL [CmdLStmt"
- markLocatedMAA ann al_open
- mapM_ markAnnotated es
- markLocatedMAA ann al_close
+ an0 <- markLensMAA ann lal_open
+ es' <- mapM markAnnotated es
+ an1 <- markLensMAA an0 lal_close
+ return (L (SrcSpanAnn an1 l) es')
instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
getAnnotationEntry = entryFromLocatedA
- exact (L (SrcSpanAnn an _) fs) = do
+ setAnnotationAnchor = setAnchorAn
+ exact (L (SrcSpanAnn an l) fs) = do
debugM $ "LocatedL [LConDeclField"
- markAnnList True an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_
+ (an', fs') <- markAnnList True an (markAnnotated fs)
+ return (L (SrcSpanAnn an' l) fs')
instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
getAnnotationEntry = entryFromLocatedA
- exact (L (SrcSpanAnn an _) bf) = do
+ setAnnotationAnchor = setAnchorAn
+ exact (L (SrcSpanAnn an l) bf) = do
debugM $ "LocatedL [LBooleanFormula"
- markAnnList True an (markAnnotated bf)
+ (an', bf') <- markAnnList True an (markAnnotated bf)
+ return (L (SrcSpanAnn an' l) bf')
-- ---------------------------------------------------------------------
-- LocatedL instances end --
@@ -3481,66 +4449,73 @@ instance ExactPrint (IE GhcPs) where
getAnnotationEntry (IEDoc _ _) = NoEntryVal
getAnnotationEntry (IEDocNamed _ _) = NoEntryVal
- exact (IEVar _ ln) = markAnnotated ln
- exact (IEThingAbs _ thing) = markAnnotated thing
+ setAnnotationAnchor a@(IEVar _ _) _ _s = a
+ setAnnotationAnchor (IEThingAbs an a) anc cs = (IEThingAbs (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (IEThingAll an a) anc cs = (IEThingAll (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (IEThingWith an a b c) anc cs = (IEThingWith (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (IEModuleContents an a) anc cs = (IEModuleContents (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor a@(IEGroup _ _ _) _ _s = a
+ setAnnotationAnchor a@(IEDoc _ _) _ _s = a
+ setAnnotationAnchor a@(IEDocNamed _ _) _ _s = a
+
+ exact (IEVar x ln) = do
+ ln' <- markAnnotated ln
+ return (IEVar x ln')
+ exact (IEThingAbs x thing) = do
+ thing' <- markAnnotated thing
+ return (IEThingAbs x thing')
exact (IEThingAll an thing) = do
- markAnnotated thing
- markEpAnn an AnnOpenP
- markEpAnn an AnnDotdot
- markEpAnn an AnnCloseP
+ thing' <- markAnnotated thing
+ an0 <- markEpAnnL an lidl AnnOpenP
+ an1 <- markEpAnnL an0 lidl AnnDotdot
+ an2 <- markEpAnnL an1 lidl AnnCloseP
+ return (IEThingAll an2 thing')
exact (IEThingWith an thing wc withs) = do
- markAnnotated thing
- markEpAnn an AnnOpenP
- case wc of
- NoIEWildcard -> markAnnotated withs
- IEWildcard pos -> do
- let (bs, as) = splitAt pos withs
- markAnnotated bs
- markEpAnn an AnnDotdot
- markEpAnn an AnnComma
- markAnnotated as
- markEpAnn an AnnCloseP
-
- exact (IEModuleContents an mn) = do
- markEpAnn an AnnModule
- markAnnotated mn
-
- -- exact (IEGroup _ _ _) = NoEntryVal
- -- exact (IEDoc _ _) = NoEntryVal
- -- exact (IEDocNamed _ _) = NoEntryVal
+ thing' <- markAnnotated thing
+ an0 <- markEpAnnL an lidl AnnOpenP
+ (an1, wc', withs') <-
+ case wc of
+ NoIEWildcard -> do
+ withs'' <- markAnnotated withs
+ return (an0, wc, withs'')
+ IEWildcard pos -> do
+ let (bs, as) = splitAt pos withs
+ bs' <- markAnnotated bs
+ an1 <- markEpAnnL an0 lidl AnnDotdot
+ an2 <- markEpAnnL an1 lidl AnnComma
+ as' <- markAnnotated as
+ return (an2, wc, bs'++as')
+ an2 <- markEpAnnL an1 lidl AnnCloseP
+ return (IEThingWith an2 thing' wc' withs')
+
+ exact (IEModuleContents an m) = do
+ an0 <- markEpAnnL an lidl AnnModule
+ m' <- markAnnotated m
+ return (IEModuleContents an0 m')
+
exact x = error $ "missing match for IE:" ++ showAst x
-- ---------------------------------------------------------------------
instance ExactPrint (IEWrappedName GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
- exact (IEName _ n) = markAnnotated n
+ exact (IEName x n) = do
+ n' <- markAnnotated n
+ return (IEName x n')
exact (IEPattern r n) = do
- printStringAtAA r "pattern"
- markAnnotated n
+ r' <- printStringAtAA r "pattern"
+ n' <- markAnnotated n
+ return (IEPattern r' n')
exact (IEType r n) = do
- printStringAtAA r "type"
- markAnnotated n
-
--- markIEWrapped :: EpAnn -> LIEWrappedName RdrName -> EPP ()
--- markIEWrapped an (L _ (IEName n))
--- = markAnnotated n
--- markIEWrapped an (L _ (IEPattern n))
--- = markEpAnn an AnnPattern >> markAnnotated n
--- markIEWrapped an (L _ (IEType n))
--- = markEpAnn an AnnType >> markAnnotated n
+ r' <- printStringAtAA r "type"
+ n' <- markAnnotated n
+ return (IEType r' n')
-- ---------------------------------------------------------------------
--- instance ExactPrint (LocatedA (Pat GhcPs)) where
--- -- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
--- getAnnotationEntry = entryFromLocatedA
--- exact (L _ a) = do
--- debugM $ "exact:LPat:" ++ showPprUnsafe a
--- markAnnotated a
-
instance ExactPrint (Pat GhcPs) where
getAnnotationEntry (WildPat _) = NoEntryVal
getAnnotationEntry (VarPat _ _) = NoEntryVal
@@ -3559,84 +4534,126 @@ instance ExactPrint (Pat GhcPs) where
getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
getAnnotationEntry (SigPat an _ _) = fromAnn an
- exact (WildPat _) = do
+ setAnnotationAnchor a@(WildPat _) _ _s = a
+ setAnnotationAnchor a@(VarPat _ _) _ _s = a
+ setAnnotationAnchor (LazyPat an a) anc cs = (LazyPat (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (AsPat an a at b) anc cs = (AsPat (setAnchorEpa an anc cs) a at b)
+ setAnnotationAnchor (ParPat an a b c) anc cs = (ParPat (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (BangPat an a) anc cs = (BangPat (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (ListPat an a) anc cs = (ListPat (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (TuplePat an a b) anc cs = (TuplePat (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (SumPat an a b c) anc cs = (SumPat (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (ConPat an a b) anc cs = (ConPat (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (ViewPat an a b) anc cs = (ViewPat (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor a@(SplicePat _ _) _ _s = a
+ setAnnotationAnchor a@(LitPat _ _) _ _s = a
+ setAnnotationAnchor (NPat an a b c) anc cs = (NPat (setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e)
+ setAnnotationAnchor (SigPat an a b) anc cs = (SigPat (setAnchorEpa an anc cs) a b)
+
+ exact (WildPat w) = do
anchor <- getAnchorU
debugM $ "WildPat:anchor=" ++ show anchor
- printStringAtRs anchor "_"
- exact (VarPat _ n) = do
- -- The parser inserts a placeholder value for a record pun rhs. This must be
- -- filtered.
- let pun_RDR = "pun-right-hand-side"
- when (showPprUnsafe n /= pun_RDR) $ markAnnotated n
+ _ <- printStringAtRs anchor "_"
+ return (WildPat w)
+ exact (VarPat x n) = do
+ -- The parser inserts a placeholder value for a record pun rhs. This must be
+ -- filtered.
+ let pun_RDR = "pun-right-hand-side"
+ n' <- if (showPprUnsafe n /= pun_RDR)
+ then markAnnotated n
+ else return n
+ return (VarPat x n')
exact (LazyPat an pat) = do
- markEpAnn an AnnTilde
- markAnnotated pat
- exact (AsPat _an n at pat) = do
- markAnnotated n
- markToken at
- markAnnotated pat
- exact (ParPat _an lpar pat rpar) = do
- markToken lpar
- markAnnotated pat
- markToken rpar
+ an0 <- markEpAnnL an lidl AnnTilde
+ pat' <- markAnnotated pat
+ return (LazyPat an0 pat')
+ exact (AsPat an n at pat) = do
+ n' <- markAnnotated n
+ at' <- markToken at
+ pat' <- markAnnotated pat
+ return (AsPat an n' at' pat')
+ exact (ParPat an lpar pat rpar) = do
+ lpar' <- markToken lpar
+ pat' <- markAnnotated pat
+ rpar' <- markToken rpar
+ return (ParPat an lpar' pat' rpar')
exact (BangPat an pat) = do
- markEpAnn an AnnBang
- markAnnotated pat
+ an0 <- markEpAnnL an lidl AnnBang
+ pat' <- markAnnotated pat
+ return (BangPat an0 pat')
- exact (ListPat an pats) = markAnnList True an (markAnnotated pats)
+ exact (ListPat an pats) = do
+ (an', pats') <- markAnnList True an (markAnnotated pats)
+ return (ListPat an' pats')
exact (TuplePat an pats boxity) = do
- case boxity of
- Boxed -> markEpAnn an AnnOpenP
- Unboxed -> markEpAnn an AnnOpenPH
- markAnnotated pats
- case boxity of
- Boxed -> markEpAnn an AnnCloseP
- Unboxed -> markEpAnn an AnnClosePH
-
- exact (SumPat an pat _alt _arity) = do
- markLocatedAAL an sumPatParens AnnOpenPH
- markAnnKwAll an sumPatVbarsBefore AnnVbar
- markAnnotated pat
- markAnnKwAll an sumPatVbarsAfter AnnVbar
- markLocatedAAL an sumPatParens AnnClosePH
+ an0 <- case boxity of
+ Boxed -> markEpAnnL an lidl AnnOpenP
+ Unboxed -> markEpAnnL an lidl AnnOpenPH
+ pats' <- markAnnotated pats
+ an1 <- case boxity of
+ Boxed -> markEpAnnL an0 lidl AnnCloseP
+ Unboxed -> markEpAnnL an0 lidl AnnClosePH
+ return (TuplePat an1 pats' boxity)
+
+ exact (SumPat an pat alt arity) = do
+ an0 <- markEpAnnL an lsumPatParens AnnOpenPH
+ an1 <- markAnnKwAllL an0 lsumPatVbarsBefore AnnVbar
+ pat' <- markAnnotated pat
+ an2 <- markAnnKwAllL an1 lsumPatVbarsAfter AnnVbar
+ an3 <- markEpAnnL an2 lsumPatParens AnnClosePH
+ return (SumPat an3 pat' alt arity)
-- | ConPat an con args)
- exact (ConPat an con details) = exactUserCon an con details
+ exact (ConPat an con details) = do
+ (an', con', details') <- exactUserCon an con details
+ return (ConPat an' con' details')
exact (ViewPat an expr pat) = do
- markAnnotated expr
- markEpAnn an AnnRarrow
- markAnnotated pat
- exact (SplicePat _ splice) = markAnnotated splice
- exact (LitPat _ lit) = printStringAdvance (hsLit2String lit)
- exact (NPat an ol mn _) = do
- when (isJust mn) $ markEpAnn an AnnMinus
- markAnnotated ol
+ expr' <- markAnnotated expr
+ an0 <- markEpAnnL an lidl AnnRarrow
+ pat' <- markAnnotated pat
+ return (ViewPat an0 expr' pat')
+ exact (SplicePat x splice) = do
+ splice' <- markAnnotated splice
+ return (SplicePat x splice')
+ exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p
+ exact (NPat an ol mn z) = do
+ an0 <- if (isJust mn)
+ then markEpAnnL an lidl AnnMinus
+ else return an
+ ol' <- markAnnotated ol
+ return (NPat an0 ol' mn z)
-- | NPlusKPat an n lit1 lit2 _ _)
- exact (NPlusKPat an n k _lit2 _ _) = do
- markAnnotated n
- printStringAtAnn an id "+"
- markAnnotated k
-
+ exact (NPlusKPat an n k lit2 a b) = do
+ n' <- markAnnotated n
+ an' <- printStringAtAAL an lid "+"
+ k' <- markAnnotated k
+ return (NPlusKPat an' n' k' lit2 a b)
exact (SigPat an pat sig) = do
- markAnnotated pat
- markEpAnn an AnnDcolon
- markAnnotated sig
- -- exact x = error $ "missing match for Pat:" ++ showAst x
+ pat' <- markAnnotated pat
+ an0 <- markEpAnnL an lidl AnnDcolon
+ sig' <- markAnnotated sig
+ return (SigPat an0 pat' sig')
-- ---------------------------------------------------------------------
instance ExactPrint (HsPatSigType GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (HsPS _ ty) = markAnnotated ty
+ setAnnotationAnchor a _ _ = a
+
+ exact (HsPS an ty) = do
+ ty' <- markAnnotated ty
+ return (HsPS an ty')
-- ---------------------------------------------------------------------
instance ExactPrint (HsOverLit GhcPs) where
getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ = a
exact ol =
let str = case ol_val ol of
@@ -3645,8 +4662,8 @@ instance ExactPrint (HsOverLit GhcPs) where
HsIsString src _ -> src
in
case str of
- SourceText s -> printStringAdvance s
- NoSourceText -> return ()
+ SourceText s -> printStringAdvance s >> return ol
+ NoSourceText -> return ol
-- ---------------------------------------------------------------------
@@ -3668,7 +4685,6 @@ hsLit2String lit =
HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl ""
HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#"
HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##"
- -- (XLit x) -> error $ "got XLit for:" ++ showPprUnsafe x
toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String
toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix
@@ -3680,22 +4696,42 @@ sourceTextToString (SourceText txt) _ = txt
-- ---------------------------------------------------------------------
-exactUserCon :: (ExactPrint con) => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs -> EPP ()
-exactUserCon _ c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2
-exactUserCon an c details = do
- markAnnotated c
- markEpAnn an AnnOpenC
- exactConArgs details
- markEpAnn an AnnCloseC
+exactUserCon :: (Monad m, Monoid w, ExactPrint con)
+ => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs
+ -> EP w m (EpAnn [AddEpAnn], con, HsConPatDetails GhcPs)
+exactUserCon an c (InfixCon p1 p2) = do
+ p1' <- markAnnotated p1
+ c' <- markAnnotated c
+ p2' <- markAnnotated p2
+ return (an, c', InfixCon p1' p2')
+exactUserCon an c details = do
+ c' <- markAnnotated c
+ an0 <- markEpAnnL an lidl AnnOpenC
+ details' <- exactConArgs details
+ an1 <- markEpAnnL an0 lidl AnnCloseC
+ return (an1, c', details')
instance ExactPrint (HsConPatTyArg GhcPs) where
getAnnotationEntry _ = NoEntryVal
- exact (HsConPatTyArg at tyarg) = markToken at >> markAnnotated tyarg
-
-exactConArgs ::HsConPatDetails GhcPs -> EPP ()
-exactConArgs (PrefixCon tyargs pats) = markAnnotated tyargs >> markAnnotated pats
-exactConArgs (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated p2
-exactConArgs (RecCon rpats) = markAnnotated rpats
+ setAnnotationAnchor a _ _ = a
+ exact (HsConPatTyArg at tyarg) = do
+ at' <- markToken at
+ tyarg' <- markAnnotated tyarg
+ return (HsConPatTyArg at' tyarg')
+
+exactConArgs :: (Monad m, Monoid w)
+ => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs)
+exactConArgs (PrefixCon tyargs pats) = do
+ tyargs' <- markAnnotated tyargs
+ pats' <- markAnnotated pats
+ return (PrefixCon tyargs' pats')
+exactConArgs (InfixCon p1 p2) = do
+ p1' <- markAnnotated p1
+ p2' <- markAnnotated p2
+ return (InfixCon p1' p2')
+exactConArgs (RecCon rpats) = do
+ rpats' <- markAnnotated rpats
+ return (RecCon rpats')
-- ---------------------------------------------------------------------
@@ -3717,7 +4753,10 @@ printStringAtLsDelta cl s = do
if isGoodDeltaWithOffset cl colOffset
then do
printStringAt (undelta p cl colOffset) s
- `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))
+ -- `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))
+ p' <- getPosP
+ d <- getPriorEndD
+ debugM $ "printStringAtLsDelta:(pos,p',d,s):" ++ show (undelta p cl colOffset,p',d,s)
else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s))
-- ---------------------------------------------------------------------
@@ -3726,53 +4765,27 @@ isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool
isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c)
where (l,c) = undelta (0,0) dp colOffset
+-- | Print a comment, using the current layout offset to convert the
+-- @DeltaPos@ to an absolute position.
printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m ()
-printQueuedComment loc Comment{commentContents} dp = do
+printQueuedComment _loc Comment{commentContents} dp = do
p <- getPosP
+ d <- getPriorEndD
colOffset <- getLayoutOffsetP
let (dr,dc) = undelta (0,0) dp colOffset
-- do not lose comments against the left margin
when (isGoodDelta (deltaPos dr (max 0 dc))) $ do
printCommentAt (undelta p dp colOffset) commentContents
- setPriorEndASTD False loc
p' <- getPosP
+ d' <- getPriorEndD
+ debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d')
debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset)
-{-
--- Print version
-printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
-printQueuedComment Comment{commentContents} dp = do
- p <- getPos
- colOffset <- getLayoutOffset
- let (dr,dc) = undelta (0,0) dp colOffset
- -- do not lose comments against the left margin
- when (isGoodDelta (DP (dr,max 0 dc))) $
- printCommentAt (undelta p dp colOffset) commentContents
-
--}
-
--- ---------------------------------------------------------------------
-
--- withContext :: (Monad m, Monoid w)
--- => [(KeywordId, DeltaPos)]
--- -> Annotation
--- -> EP w m a -> EP w m a
--- withContext kds an x = withKds kds (withOffset an x)
-
--- ---------------------------------------------------------------------
---
--- | Given an annotation associated with a specific SrcSpan,
--- determines a new offset relative to the previous offset
---
-withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a)
-withOffset a =
- local (\s -> s { epAnn = a })
-
------------------------------------------------------------------------
-setLayoutBoth :: (Monad m, Monoid w) => EP w m () -> EP w m ()
+setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a
setLayoutBoth k = do
- oldLHS <- gets dLHS
+ oldLHS <- getLayoutOffsetD
oldAnchorOffset <- getLayoutOffsetP
debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)
modify (\a -> a { dMarkLayout = True
@@ -3786,15 +4799,16 @@ setLayoutBoth k = do
k <* reset
-- Use 'local', designed for this
-setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m () -> EP w m ()
+setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m a -> EP w m a
setLayoutTopLevelP k = do
debugM $ "setLayoutTopLevelP entered"
oldAnchorOffset <- getLayoutOffsetP
modify (\a -> a { pMarkLayout = False
- , pLHS = 0} )
- k
+ , pLHS = 1} )
+ r <- k
debugM $ "setLayoutTopLevelP:resetting"
setLayoutOffsetP oldAnchorOffset
+ return r
------------------------------------------------------------------------
@@ -3803,7 +4817,7 @@ getPosP = gets epPos
setPosP :: (Monad m, Monoid w) => Pos -> EP w m ()
setPosP l = do
- debugM $ "setPosP:" ++ show l
+ -- debugM $ "setPosP:" ++ show l
modify (\s -> s {epPos = l})
getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor)
@@ -3822,12 +4836,11 @@ getAnchorU = gets uAnchorSpan
setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m ()
setPriorEndD pe = do
- -- setLayoutStartIfNeededD (snd pe)
setPriorEndNoLayoutD pe
setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m ()
setPriorEndNoLayoutD pe = do
- debugM $ "setPriorEndNoLayout:pe=" ++ show pe
+ debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe
modify (\s -> s { dPriorEndPosition = pe })
setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m ()
@@ -3847,6 +4860,9 @@ setLayoutStartD p = do
modify (\s -> s { dMarkLayout = False
, dLHS = LayoutStartCol p})
+getLayoutOffsetD :: (Monad m, Monoid w) => EP w m LayoutStartCol
+getLayoutOffsetD = gets dLHS
+
setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
setAnchorU rss = do
debugM $ "setAnchorU:" ++ show (rs2range rss)
@@ -3858,6 +4874,45 @@ getUnallocatedComments = gets epComments
putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m ()
putUnallocatedComments cs = modify (\s -> s { epComments = cs } )
+-- | Push a fresh stack frame for the applied comments gatherer
+pushAppliedComments :: (Monad m, Monoid w) => EP w m ()
+pushAppliedComments = modify (\s -> s { epCommentsApplied = []:(epCommentsApplied s) })
+
+-- | Return the comments applied since the last call
+-- takeAppliedComments, and clear them, not popping the stack
+takeAppliedComments :: (Monad m, Monoid w) => EP w m [Comment]
+takeAppliedComments = do
+ ccs <- gets epCommentsApplied
+ case ccs of
+ [] -> do
+ modify (\s -> s { epCommentsApplied = [] })
+ return []
+ h:t -> do
+ modify (\s -> s { epCommentsApplied = []:t })
+ return (reverse h)
+
+-- | Return the comments applied since the last call
+-- takeAppliedComments, and clear them, popping the stack
+takeAppliedCommentsPop :: (Monad m, Monoid w) => EP w m [Comment]
+takeAppliedCommentsPop = do
+ ccs <- gets epCommentsApplied
+ case ccs of
+ [] -> do
+ modify (\s -> s { epCommentsApplied = [] })
+ return []
+ h:t -> do
+ modify (\s -> s { epCommentsApplied = t })
+ return (reverse h)
+
+-- | Mark a comment as being applied. This is used to update comments
+-- when doing delta processing
+applyComment :: (Monad m, Monoid w) => Comment -> EP w m ()
+applyComment c = do
+ ccs <- gets epCommentsApplied
+ case ccs of
+ [] -> modify (\s -> s { epCommentsApplied = [[c]] } )
+ (h:t) -> modify (\s -> s { epCommentsApplied = (c:h):t } )
+
getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol
getLayoutOffsetP = gets pLHS
@@ -3868,59 +4923,31 @@ setLayoutOffsetP c = do
-- ---------------------------------------------------------------------
--------------------------------------------------------------------------
--- |First move to the given location, then call exactP
--- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a
--- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w)
--- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a
--- exactPC ast action =
--- do
--- return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))
--- ma <- getAndRemoveAnnotation ast
--- let an@Ann{ annEntryDelta=edp
--- , annPriorComments=comments
--- , annFollowingComments=fcomments
--- , annsDP=kds
--- } = fromMaybe annNone ma
--- PrintOptions{epAstPrint} <- ask
--- r <- withContext kds an
--- (mapM_ (uncurry printQueuedComment) comments
--- >> advance edp
--- >> censorM (epAstPrint ast) action
--- <* mapM_ (uncurry printQueuedComment) fcomments)
--- return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast))
-
--- censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a
--- censorM f m = passM (liftM (\x -> (x,f)) m)
-
--- passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a
--- passM m = RWST $ \r s -> do
--- ~((a, f),s', EPWriter w) <- runRWST m r s
--- w' <- f w
--- return (a, s', EPWriter w')
advance :: (Monad m, Monoid w) => DeltaPos -> EP w m ()
advance dp = do
p <- getPosP
colOffset <- getLayoutOffsetP
debugM $ "advance:(p,dp,colOffset,ws)=" ++ show (p,dp,colOffset,undelta p dp colOffset)
- printWhitespace (undelta p dp colOffset)
-
-{-
-Version from Print.advance
-advance :: (Monad m, Monoid w) => DeltaPos -> EP w m ()
-advance cl = do
- p <- getPos
- colOffset <- getLayoutOffset
- printWhitespace (undelta p cl colOffset)
--}
+ if isGoodDelta dp
+ then do
+ printWhitespace (undelta p dp colOffset)
+ -- Sync point. We only call advance as we start the sub-span
+ -- processing, so force the dPriorEndPosition to ???
+ p0 <- getPosP
+ d <- getPriorEndD
+ r <- getAnchorU
+ setPriorEndD (fst $ rs2range r)
+ debugM $ "advance:after: (posp, posd, posd')=" ++ show (p0,d,fst $ rs2range r)
+ else
+ return ()
-- ---------------------------------------------------------------------
-adjustDeltaForOffsetM :: DeltaPos -> EPP DeltaPos
+adjustDeltaForOffsetM :: (Monad m, Monoid w) => DeltaPos -> EP w m DeltaPos
adjustDeltaForOffsetM dp = do
- colOffset <- gets dLHS
- return (adjustDeltaForOffset 0 colOffset dp)
+ colOffset <- getLayoutOffsetD
+ return (adjustDeltaForOffset colOffset dp)
-- ---------------------------------------------------------------------
-- Printing functions
@@ -3928,7 +4955,7 @@ adjustDeltaForOffsetM dp = do
printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()
printString layout str = do
EPState{epPos = (_,c), pMarkLayout} <- get
- PrintOptions{epTokenPrint, epWhitespacePrint} <- ask
+ EPOptions{epTokenPrint, epWhitespacePrint} <- ask
when (pMarkLayout && layout) $ do
debugM $ "printString: setting pLHS to " ++ show c
modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } )
@@ -3937,11 +4964,17 @@ printString layout str = do
let strDP = dpFromString str
cr = getDeltaLine strDP
p <- getPosP
- colOffset <- getLayoutOffsetP
+ d <- getPriorEndD
+ colOffsetP <- getLayoutOffsetP
+ colOffsetD <- getLayoutOffsetD
-- debugM $ "printString:(p,colOffset,strDP,cr)=" ++ show (p,colOffset,strDP,cr)
if cr == 0
- then setPosP (undelta p strDP colOffset)
- else setPosP (undelta p strDP 1)
+ then do
+ setPosP (undelta p strDP colOffsetP)
+ setPriorEndD (undelta d strDP colOffsetD)
+ else do
+ setPosP (undelta p strDP 1)
+ setPriorEndD (undelta d strDP 1)
-- Debug stuff
-- pp <- getPosP
@@ -3953,46 +4986,23 @@ printString layout str = do
then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s}
else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s}
-
-{-
-
--- Print.printString
-printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()
-printString layout str = do
- EPState{epPos = (_,c), epMarkLayout} <- get
- PrintOptions{epTokenPrint, epWhitespacePrint} <- ask
- when (epMarkLayout && layout) $
- modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } )
-
- -- Advance position, taking care of any newlines in the string
- let strDP@(DP (cr,_cc)) = dpFromString str
- p <- getPos
- colOffset <- getLayoutOffset
- if cr == 0
- then setPos (undelta p strDP colOffset)
- else setPos (undelta p strDP 1)
-
- --
- if not layout && c == 0
- then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s}
- else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s}
-
--}
-
--------------------------------------------------------
-printStringAdvance :: String -> EPP ()
+printStringAdvance :: (Monad m, Monoid w) => String -> EP w m ()
printStringAdvance str = do
ss <- getAnchorU
- printStringAtKw' ss str
+ _ <- printStringAtRs ss str
+ return ()
--------------------------------------------------------
newLine :: (Monad m, Monoid w) => EP w m ()
newLine = do
(l,_) <- getPosP
+ (ld,_) <- getPriorEndD
printString False "\n"
setPosP (l+1,1)
+ setPriorEndNoLayoutD (ld+1,1)
padUntil :: (Monad m, Monoid w) => Pos -> EP w m ()
padUntil (l,c) = do
diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs
index 467f76c686..d3a7df6c2a 100644
--- a/utils/check-exact/Lookup.hs
+++ b/utils/check-exact/Lookup.hs
@@ -1,7 +1,7 @@
module Lookup
(
keywordToString
- , KeywordId(..)
+ , AnnKeywordId(..)
, Comment(..)
) where
@@ -12,117 +12,114 @@ import Types
-- There is no specific mapping for the following constructors.
-- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`,
-- `AnnInfix`
-keywordToString :: KeywordId -> String
+keywordToString :: AnnKeywordId -> String
keywordToString kw =
let mkErr x = error $ "keywordToString: missing case for:" ++ show x
in
case kw of
-- Specifically handle all cases so that there are pattern match
-- warnings if new constructors are added.
- AnnComment _ -> mkErr kw
- AnnString _ -> mkErr kw
- AnnSemiSep -> ";"
- (G AnnAnyclass) -> "anyclass"
- (G AnnOpen ) -> mkErr kw
- (G AnnClose ) -> mkErr kw
- (G AnnVal ) -> mkErr kw
- (G AnnPackageName) -> mkErr kw
- (G AnnHeader ) -> mkErr kw
- (G AnnFunId ) -> mkErr kw
- (G AnnInfix ) -> mkErr kw
- (G AnnValStr ) -> mkErr kw
- (G AnnName ) -> mkErr kw
- (G AnnAs ) -> "as"
- (G AnnBang ) -> "!"
- (G AnnBackquote ) -> "`"
- (G AnnBy ) -> "by"
- (G AnnCase ) -> "case"
- (G AnnCases ) -> "cases"
- (G AnnClass ) -> "class"
- (G AnnCloseB ) -> "|)"
- (G AnnCloseBU ) -> "⦈"
- (G AnnCloseC ) -> "}"
- (G AnnCloseP ) -> ")"
- (G AnnClosePH ) -> "#)"
- (G AnnCloseQ ) -> "|]"
- (G AnnCloseQU ) -> "⟧"
- (G AnnCloseS ) -> "]"
- (G AnnColon ) -> ":"
- (G AnnComma ) -> ","
- (G AnnCommaTuple ) -> ","
- (G AnnDarrow ) -> "=>"
- (G AnnData ) -> "data"
- (G AnnDcolon ) -> "::"
- (G AnnDefault ) -> "default"
- (G AnnDeriving ) -> "deriving"
- (G AnnDo ) -> "do"
- (G AnnDot ) -> "."
- (G AnnDotdot ) -> ".."
- (G AnnElse ) -> "else"
- (G AnnEqual ) -> "="
- (G AnnExport ) -> "export"
- (G AnnFamily ) -> "family"
- (G AnnForall ) -> "forall"
- (G AnnForeign ) -> "foreign"
- (G AnnGroup ) -> "group"
- (G AnnHiding ) -> "hiding"
- (G AnnIf ) -> "if"
- (G AnnImport ) -> "import"
- (G AnnIn ) -> "in"
- (G AnnInstance ) -> "instance"
- (G AnnLam ) -> "\\"
- (G AnnLarrow ) -> "<-"
- (G AnnLet ) -> "let"
- (G AnnLollyU ) -> "⊸"
- (G AnnMdo ) -> "mdo"
- (G AnnMinus ) -> "-"
- (G AnnModule ) -> "module"
- (G AnnNewtype ) -> "newtype"
- (G AnnOf ) -> "of"
- (G AnnOpenB ) -> "(|"
- (G AnnOpenBU ) -> "⦇"
- (G AnnOpenC ) -> "{"
- (G AnnOpenE ) -> "[e|"
- (G AnnOpenEQ ) -> "[|"
- (G AnnOpenEQU ) -> "⟦"
- (G AnnOpenP ) -> "("
- (G AnnOpenPH ) -> "(#"
- (G AnnOpenS ) -> "["
- (G AnnPattern ) -> "pattern"
- (G AnnPercent ) -> "%"
- (G AnnPercentOne) -> "%1"
- (G AnnProc ) -> "proc"
- (G AnnQualified ) -> "qualified"
- (G AnnRarrow ) -> "->"
- (G AnnRec ) -> "rec"
- (G AnnRole ) -> "role"
- (G AnnSafe ) -> "safe"
- (G AnnSemi ) -> ";"
- (G AnnSignature) -> "signature"
- (G AnnStock ) -> "stock"
- (G AnnStatic ) -> "static"
- (G AnnThen ) -> "then"
- (G AnnTilde ) -> "~"
- (G AnnType ) -> "type"
- (G AnnUnit ) -> "()"
- (G AnnUsing ) -> "using"
- (G AnnVbar ) -> "|"
- (G AnnWhere ) -> "where"
- (G Annlarrowtail ) -> "-<"
- (G Annrarrowtail ) -> ">-"
- (G AnnLarrowtail ) -> "-<<"
- (G AnnRarrowtail ) -> ">>-"
- (G AnnSimpleQuote ) -> "'"
- (G AnnThTyQuote ) -> "''"
- (G AnnDollar ) -> "$"
- (G AnnDollarDollar ) -> "$$"
- (G AnnDarrowU) -> "⇒"
- (G AnnDcolonU) -> "∷"
- (G AnnForallU) -> "∀"
- (G AnnLarrowU) -> "←"
- (G AnnLarrowtailU) -> "⤛"
- (G AnnRarrowU) -> "→"
- (G AnnRarrowtailU) -> "⤜"
- (G AnnlarrowtailU) -> "⤙"
- (G AnnrarrowtailU) -> "⤚"
- (G AnnVia) -> "via"
+ AnnAnyclass -> "anyclass"
+ AnnOpen -> mkErr kw
+ AnnClose -> mkErr kw
+ AnnVal -> mkErr kw
+ AnnPackageName -> mkErr kw
+ AnnHeader -> mkErr kw
+ AnnFunId -> mkErr kw
+ AnnInfix -> mkErr kw
+ AnnValStr -> mkErr kw
+ AnnName -> mkErr kw
+ AnnAs -> "as"
+ AnnBang -> "!"
+ AnnBackquote -> "`"
+ AnnBy -> "by"
+ AnnCase -> "case"
+ AnnCases -> "cases"
+ AnnClass -> "class"
+ AnnCloseB -> "|)"
+ AnnCloseBU -> "⦈"
+ AnnCloseC -> "}"
+ AnnCloseP -> ")"
+ AnnClosePH -> "#)"
+ AnnCloseQ -> "|]"
+ AnnCloseQU -> "⟧"
+ AnnCloseS -> "]"
+ AnnColon -> ":"
+ AnnComma -> ","
+ AnnCommaTuple -> ","
+ AnnDarrow -> "=>"
+ AnnData -> "data"
+ AnnDcolon -> "::"
+ AnnDefault -> "default"
+ AnnDeriving -> "deriving"
+ AnnDo -> "do"
+ AnnDot -> "."
+ AnnDotdot -> ".."
+ AnnElse -> "else"
+ AnnEqual -> "="
+ AnnExport -> "export"
+ AnnFamily -> "family"
+ AnnForall -> "forall"
+ AnnForeign -> "foreign"
+ AnnGroup -> "group"
+ AnnHiding -> "hiding"
+ AnnIf -> "if"
+ AnnImport -> "import"
+ AnnIn -> "in"
+ AnnInstance -> "instance"
+ AnnLam -> "\\"
+ AnnLarrow -> "<-"
+ AnnLet -> "let"
+ AnnLollyU -> "⊸"
+ AnnMdo -> "mdo"
+ AnnMinus -> "-"
+ AnnModule -> "module"
+ AnnNewtype -> "newtype"
+ AnnOf -> "of"
+ AnnOpenB -> "(|"
+ AnnOpenBU -> "⦇"
+ AnnOpenC -> "{"
+ AnnOpenE -> "[e|"
+ AnnOpenEQ -> "[|"
+ AnnOpenEQU -> "⟦"
+ AnnOpenP -> "("
+ AnnOpenPH -> "(#"
+ AnnOpenS -> "["
+ AnnPattern -> "pattern"
+ AnnPercent -> "%"
+ AnnPercentOne -> "%1"
+ AnnProc -> "proc"
+ AnnQualified -> "qualified"
+ AnnRarrow -> "->"
+ AnnRec -> "rec"
+ AnnRole -> "role"
+ AnnSafe -> "safe"
+ AnnSemi -> ";"
+ AnnSignature -> "signature"
+ AnnStock -> "stock"
+ AnnStatic -> "static"
+ AnnThen -> "then"
+ AnnTilde -> "~"
+ AnnType -> "type"
+ AnnUnit -> "()"
+ AnnUsing -> "using"
+ AnnVbar -> "|"
+ AnnWhere -> "where"
+ Annlarrowtail -> "-<"
+ Annrarrowtail -> ">-"
+ AnnLarrowtail -> "-<<"
+ AnnRarrowtail -> ">>-"
+ AnnSimpleQuote -> "'"
+ AnnThTyQuote -> "''"
+ AnnDollar -> "$"
+ AnnDollarDollar -> "$$"
+ AnnDarrowU -> "⇒"
+ AnnDcolonU -> "∷"
+ AnnForallU -> "∀"
+ AnnLarrowU -> "←"
+ AnnLarrowtailU -> "⤛"
+ AnnRarrowU -> "→"
+ AnnRarrowtailU -> "⤜"
+ AnnlarrowtailU -> "⤙"
+ AnnrarrowtailU -> "⤚"
+ AnnVia -> "via"
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 4272a8004c..8023549c22 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -36,9 +36,8 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
@@ -79,7 +78,6 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" (Just rmTypeSig2)
-- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" (Just addHiding1)
-- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" (Just addHiding2)
-
-- "../../testsuite/tests/printer/Ppr001.hs" Nothing
-- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing
-- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" Nothing
@@ -163,6 +161,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/T15761.hs" Nothing
-- "../../testsuite/tests/printer/T18052a.hs" Nothing
-- "../../testsuite/tests/printer/T18247a.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10268.hs" Nothing
-- "../../testsuite/tests/printer/Test10276.hs" Nothing
-- "../../testsuite/tests/printer/Test10278.hs" Nothing
-- "../../testsuite/tests/printer/Test10312.hs" Nothing
@@ -195,12 +194,14 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Test19834.hs" Nothing
-- "../../testsuite/tests/printer/Test19840.hs" Nothing
-- "../../testsuite/tests/printer/Test19850.hs" Nothing
+ "../../testsuite/tests/printer/Test20258.hs" Nothing
-- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing
-- "../../testsuite/tests/printer/PprSemis.hs" Nothing
-- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
-- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
-- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
- "../../testsuite/tests/printer/Test21805.hs" Nothing
+ -- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
+ -- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- cloneT does not need a test, function can be retired
@@ -265,6 +266,7 @@ main :: IO()
main = do
args <- getArgs
case args of
+ [] -> _tt
[libdir,fileName] -> testOneFile changers libdir fileName Nothing
[libdir,fileName,changerStr] -> do
case lookup changerStr changers of
@@ -373,6 +375,9 @@ type Changer = FilePath -> (ParsedSource -> IO ParsedSource)
noChange :: Changer
noChange _libdir parsed = return parsed
+-- changeDeltaAst :: Changer
+-- changeDeltaAst _libdir parsed = return (makeDeltaAst parsed)
+
changeRenameCase1 :: Changer
changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed)
@@ -401,9 +406,9 @@ changeRename1 _libdir parsed = return (rename "bar2" [((3,1),(3,4))] parsed)
changeRename2 :: Changer
changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed)
-rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a
+rename :: (Data a, ExactPrint a) => String -> [(Pos, Pos)] -> a -> a
rename newNameStr spans' a
- = everywhere (mkT replaceRdr) a
+ = everywhere (mkT replaceRdr) (makeDeltaAst a)
where
newName = mkRdrUnqual (mkVarOcc newNameStr)
@@ -419,7 +424,7 @@ rename newNameStr spans' a
changeWhereIn4 :: Changer
changeWhereIn4 _libdir parsed
- = return (everywhere (mkT replace) parsed)
+ = return (everywhere (mkT replace) (makeDeltaAst parsed))
where
replace :: LocatedN RdrName -> LocatedN RdrName
replace (L ln _n)
@@ -453,9 +458,9 @@ changeLetIn1 _libdir parsed
changeAddDecl1 :: Changer
changeAddDecl1 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
- let decl' = setEntryDP' decl (DifferentLine 2 0)
+ let decl' = setEntryDP decl (DifferentLine 2 0)
- let (p',(_,_),_) = runTransform mempty doAddDecl
+ let (p',_,_) = runTransform doAddDecl
doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAtStart m decl'
@@ -466,11 +471,10 @@ changeAddDecl1 libdir top = do
changeAddDecl2 :: Changer
changeAddDecl2 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
- let decl' = setEntryDP' decl (DifferentLine 2 0)
- let top' = anchorEof top
+ let decl' = setEntryDP (makeDeltaAst decl) (DifferentLine 2 0)
- let (p',(_,_),_) = runTransform mempty doAddDecl
- doAddDecl = everywhereM (mkM replaceTopLevelDecls) top'
+ let (p',_,_) = runTransform doAddDecl
+ doAddDecl = everywhereM (mkM replaceTopLevelDecls) (makeDeltaAst top)
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAtEnd m decl'
return p'
@@ -480,13 +484,13 @@ changeAddDecl2 libdir top = do
changeAddDecl3 :: Changer
changeAddDecl3 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
- let decl' = setEntryDP' decl (DifferentLine 2 0)
+ let decl' = setEntryDP decl (DifferentLine 2 0)
- let (p',(_,_),_) = runTransform mempty doAddDecl
+ let (p',_,_) = runTransform doAddDecl
doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
f d (l1:l2:ls) = (l1:d:l2':ls)
where
- l2' = setEntryDP' l2 (DifferentLine 2 0)
+ l2' = setEntryDP l2 (DifferentLine 2 0)
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAt f m decl'
@@ -499,9 +503,9 @@ changeLocalDecls :: Changer
changeLocalDecls libdir (L l p) = do
Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0)
- let sig' = setEntryDP' (L ls sig) (SameLine 0)
- let (p',(_,_),_w) = runTransform mempty doAddLocal
+ let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)
+ let sig' = setEntryDP (L ls sig) (SameLine 0)
+ let (p',_,_w) = runTransform doAddLocal
doAddLocal = everywhereM (mkM replaceLocalBinds) p
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
@@ -511,10 +515,10 @@ changeLocalDecls libdir (L l p) = do
let oldDecls' = captureLineSpacing oldDecls
let oldBinds = concatMap decl2Bind oldDecls'
(os:oldSigs) = concatMap decl2Sig oldDecls'
- os' = setEntryDP' os (DifferentLine 2 0)
+ os' = setEntryDP os (DifferentLine 2 0)
let sortKey = captureOrder decls
let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van
- let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs)
+ let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs)
let binds' = (HsValBinds van'
(ValBinds sortKey (listToBag $ decl':oldBinds)
(sig':os':oldSigs)))
@@ -530,19 +534,19 @@ changeLocalDecls2 :: Changer
changeLocalDecls2 libdir (L l p) = do
Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
- let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0)
- let sig' = setEntryDP' (L ls sig) (SameLine 2)
- let (p',(_,_),_w) = runTransform mempty doAddLocal
+ let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)
+ let sig' = setEntryDP (L ls sig) (SameLine 2)
+ let (p',_,_w) = runTransform doAddLocal
doAddLocal = everywhereM (mkM replaceLocalBinds) p
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
newSpan <- uniqueSrcSpanT
- let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3)))
- let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5)))
+ let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)))
+ let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)))
let an = EpAnn anc
(AnnList (Just anc2) Nothing Nothing
- [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] [])
+ [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])
emptyComments
let decls = [s,d]
let sortKey = captureOrder decls
@@ -558,10 +562,8 @@ changeLocalDecls2 libdir (L l p) = do
changeWhereIn3a :: Changer
changeWhereIn3a _libdir (L l p) = do
let decls0 = hsmodDecls p
- (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
- -- (_de0:_:de1:_d2:_) = decls
+ (decls,_,w) = runTransform (balanceCommentsList decls0)
debugM $ unlines w
- -- debugM $ "changeWhereIn3a:de1:" ++ showAst de1
let p2 = p { hsmodDecls = decls}
return (L l p2)
@@ -570,11 +572,11 @@ changeWhereIn3a _libdir (L l p) = do
changeWhereIn3b :: Changer
changeWhereIn3b _libdir (L l p) = do
let decls0 = hsmodDecls p
- (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
+ (decls,_,w) = runTransform (balanceCommentsList decls0)
(de0:_:de1:d2:_) = decls
- de0' = setEntryDP' de0 (DifferentLine 2 0)
- de1' = setEntryDP' de1 (DifferentLine 2 0)
- d2' = setEntryDP' d2 (DifferentLine 2 0)
+ de0' = setEntryDP de0 (DifferentLine 2 0)
+ de1' = setEntryDP de1 (DifferentLine 2 0)
+ d2' = setEntryDP d2 (DifferentLine 2 0)
decls' = d2':de1':de0':(tail decls)
debugM $ unlines w
debugM $ "changeWhereIn3b:de1':" ++ showAst de1'
@@ -584,17 +586,18 @@ changeWhereIn3b _libdir (L l p) = do
-- ---------------------------------------------------------------------
addLocaLDecl1 :: Changer
-addLocaLDecl1 libdir lp = do
+addLocaLDecl1 libdir top = do
Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP' (L ld decl) (DifferentLine 1 5)
+ let decl' = setEntryDP (L ld decl) (DifferentLine 1 5)
doAddLocal = do
+ let lp = makeDeltaAst top
(de1:d2:d3:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
(de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do
return ((wrapDecl decl' : d),Nothing)
replaceDecls lp [de1', d2', d3]
- (lp',(_,_),w) <- runTransformT mempty doAddLocal
+ (lp',_,w) <- runTransformT doAddLocal
debugM $ "addLocaLDecl1:" ++ intercalate "\n" w
return lp'
@@ -610,32 +613,33 @@ addLocaLDecl2 libdir lp = do
(parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
newDecl' <- transferEntryDP' d newDecl
- let d' = setEntryDP' d (DifferentLine 1 0)
+ let d' = setEntryDP d (DifferentLine 1 0)
return ((newDecl':d':ds),Nothing)
replaceDecls lp [parent',d2']
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
addLocaLDecl3 :: Changer
-addLocaLDecl3 libdir lp = do
+addLocaLDecl3 libdir top = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let
doAddLocal = do
+ let lp = makeDeltaAst top
(de1:d2:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
(parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
- let newDecl' = setEntryDP' newDecl (DifferentLine 1 0)
+ let newDecl' = setEntryDP newDecl (DifferentLine 1 0)
return (((d:ds) ++ [newDecl']),Nothing)
replaceDecls (anchorEof lp) [parent',d2']
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -649,15 +653,15 @@ addLocaLDecl4 libdir lp = do
doAddLocal = do
(parent:ds) <- hsDecls lp
- let newDecl' = setEntryDP' newDecl (DifferentLine 1 0)
- let newSig' = setEntryDP' newSig (DifferentLine 1 4)
+ let newDecl' = setEntryDP newDecl (DifferentLine 1 0)
+ let newSig' = setEntryDP newSig (DifferentLine 1 4)
(parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do
return ((decls++[newSig',newDecl']),Nothing)
replaceDecls (anchorEof lp) (parent':ds)
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -671,14 +675,14 @@ addLocaLDecl5 _libdir lp = do
decls <- hsDecls lp
[s1,de1,d2,d3] <- balanceCommentsList decls
- let d3' = setEntryDP' d3 (DifferentLine 2 0)
+ let d3' = setEntryDP d3 (DifferentLine 2 0)
(de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do
- let d2' = setEntryDP' d2 (DifferentLine 1 0)
+ let d2' = setEntryDP d2 (DifferentLine 1 0)
return ([d2'],Nothing)
replaceDecls lp [s1,de1',d3']
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -688,7 +692,7 @@ addLocaLDecl6 :: Changer
addLocaLDecl6 libdir lp = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3")
let
- newDecl' = setEntryDP' newDecl (DifferentLine 1 4)
+ newDecl' = setEntryDP newDecl (DifferentLine 1 4)
doAddLocal = do
decls0 <- hsDecls lp
[de1'',d2] <- balanceCommentsList decls0
@@ -701,23 +705,24 @@ addLocaLDecl6 libdir lp = do
return ((newDecl' : decls),Nothing)
replaceDecls lp [de1', d2]
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
rmDecl1 :: Changer
-rmDecl1 _libdir lp = do
+rmDecl1 _libdir top = do
let doRmDecl = do
+ let lp = makeDeltaAst top
tlDecs0 <- hsDecls lp
tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0
let (de1:_s1:_d2:d3:ds) = tlDecs
- let d3' = setEntryDP' d3 (DifferentLine 2 0)
+ let d3' = setEntryDP d3 (DifferentLine 2 0)
replaceDecls lp (de1:d3':ds)
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -738,7 +743,7 @@ rmDecl2 _libdir lp = do
everywhereM (mkM go) lp
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -751,12 +756,12 @@ rmDecl3 _libdir lp = do
[de1,d2] <- hsDecls lp
(de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do
- let sd1' = setEntryDP' sd1 (DifferentLine 2 0)
+ let sd1' = setEntryDP sd1 (DifferentLine 2 0)
return ([],Just sd1')
replaceDecls lp [de1',sd1,d2]
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -771,12 +776,12 @@ rmDecl4 _libdir lp = do
(de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do
sd2' <- transferEntryDP' sd1 sd2
- let sd1' = setEntryDP' sd1 (DifferentLine 2 0)
+ let sd1' = setEntryDP sd1 (DifferentLine 2 0)
return ([sd2'],Just sd1')
replaceDecls (anchorEof lp) [de1',sd1]
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -791,14 +796,14 @@ rmDecl5 _libdir lp = do
go (HsLet a tkLet lb tkIn expr) = do
decs <- hsDeclsValBinds lb
let dec = last decs
- _ <- transferEntryDPT (head decs) dec
+ _ <- transferEntryDP (head decs) dec
lb' <- replaceDeclsValbinds WithoutWhere lb [dec]
return (HsLet a tkLet lb' tkIn expr)
go x = return x
everywhereM (mkM go) lp
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -818,16 +823,17 @@ rmDecl6 _libdir lp = do
replaceDecls lp [de1']
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
rmDecl7 :: Changer
-rmDecl7 _libdir lp = do
+rmDecl7 _libdir top = do
let
doRmDecl = do
+ let lp = makeDeltaAst top
tlDecs <- hsDecls lp
[s1,de1,d2,d3] <- balanceCommentsList tlDecs
@@ -835,7 +841,7 @@ rmDecl7 _libdir lp = do
replaceDecls lp [s1,de1,d3']
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -852,7 +858,7 @@ rmTypeSig1 _libdir lp = do
let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ)))
replaceDecls lp (s1':de1:d2)
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -865,11 +871,11 @@ rmTypeSig2 _libdir lp = do
let [de1] = tlDecs
(de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do
- d' <- transferEntryDPT s d
+ d' <- transferEntryDP s d
return ([d'],Nothing)
replaceDecls lp [de1']
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -898,15 +904,16 @@ addHiding1 _libdir (L l p) = do
p' = p { hsmodImports = [L li imp1',imp2]}
return (L l p')
- let (lp',(_ans',_),_w) = runTransform mempty doTransform
+ let (lp',_,_w) = runTransform doTransform
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
addHiding2 :: Changer
-addHiding2 _libdir (L l p) = do
+addHiding2 _libdir top = do
let doTransform = do
+ let (L l p) = makeDeltaAst top
l1 <- uniqueSrcSpanT
l2 <- uniqueSrcSpanT
let
@@ -929,7 +936,7 @@ addHiding2 _libdir (L l p) = do
p' = p { hsmodImports = [L li imp1']}
return (L l p')
- let (lp',(_ans',_),_w) = runTransform mempty doTransform
+ let (lp',_,_w) = runTransform doTransform
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
diff --git a/utils/check-exact/Orphans.hs b/utils/check-exact/Orphans.hs
new file mode 100644
index 0000000000..1403324861
--- /dev/null
+++ b/utils/check-exact/Orphans.hs
@@ -0,0 +1,92 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Orphans where
+
+-- import Data.Default
+import GHC hiding (EpaComment)
+
+-- ---------------------------------------------------------------------
+
+class Default a where
+ def :: a
+
+-- ---------------------------------------------------------------------
+-- Orphan Default instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372
+
+instance Default [a] where
+ def = []
+
+instance Default NameAnn where
+ def = mempty
+
+instance Default AnnList where
+ def = mempty
+
+instance Default AnnListItem where
+ def = mempty
+
+instance Default AnnPragma where
+ def = AnnPragma def def def
+
+instance Semigroup EpAnnImportDecl where
+ (<>) = error "unimplemented"
+instance Default EpAnnImportDecl where
+ def = EpAnnImportDecl def Nothing Nothing Nothing Nothing Nothing
+
+instance Default HsRuleAnn where
+ def = HsRuleAnn Nothing Nothing def
+
+instance Default AnnSig where
+ def = AnnSig def def
+
+instance Default GrhsAnn where
+ def = GrhsAnn Nothing def
+
+instance Default EpAnnUnboundVar where
+ def = EpAnnUnboundVar def def
+
+instance (Default a, Default b) => Default (a, b) where
+ def = (def, def)
+
+instance Default NoEpAnns where
+ def = NoEpAnns
+
+instance Default AnnParen where
+ def = AnnParen AnnParens def def
+
+instance Default AnnExplicitSum where
+ def = AnnExplicitSum def def def def
+
+instance Default EpAnnHsCase where
+ def = EpAnnHsCase def def def
+
+instance Default AnnsIf where
+ def = AnnsIf def def def def def
+
+instance Default (Maybe a) where
+ def = Nothing
+
+instance Default AnnProjection where
+ def = AnnProjection def def
+
+instance Default AnnFieldLabel where
+ def = AnnFieldLabel Nothing
+
+instance Default EpaLocation where
+ def = EpaDelta (SameLine 0) []
+
+instance Default AddEpAnn where
+ def = AddEpAnn def def
+
+instance Default AnnKeywordId where
+ def = Annlarrowtail {- gotta pick one -}
+
+instance Default AnnContext where
+ def = AnnContext Nothing [] []
+
+instance Default EpAnnSumPat where
+ def = EpAnnSumPat def def def
+
+instance Default AnnsModule where
+ def = AnnsModule [] mempty
diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs
index e631d43314..9b9cdd1dd7 100644
--- a/utils/check-exact/Parsers.hs
+++ b/utils/check-exact/Parsers.hs
@@ -111,7 +111,7 @@ runParser parser flags filename str = GHC.unP parser parseState
-- @
-- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr)
-- @
-withDynFlags :: FilePath -> (GHC.DynFlags -> a) -> IO a
+withDynFlags :: LibDir -> (GHC.DynFlags -> a) -> IO a
withDynFlags libdir action = ghcWrapper libdir $ do
dflags <- GHC.getSessionDynFlags
void $ GHC.setSessionDynFlags dflags
@@ -171,7 +171,7 @@ parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file
-- string; the `FilePath` parameter solely exists to provide a name
-- in source location annotations.
parseModuleFromString
- :: FilePath -- GHC libdir
+ :: LibDir -- GHC libdir
-> FilePath
-> String
-> IO (ParseResult GHC.ParsedSource)
@@ -190,7 +190,7 @@ parseModuleFromStringInternal dflags fileName str =
-> Right (lp, dflags, pmod)
in postParseTransform res
-parseModuleWithOptions :: FilePath -- ^ GHC libdir
+parseModuleWithOptions :: LibDir -- ^ GHC libdir
-> FilePath
-> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions libdir fp =
@@ -199,7 +199,7 @@ parseModuleWithOptions libdir fp =
-- | Parse a module with specific instructions for the C pre-processor.
parseModuleWithCpp
- :: FilePath -- ^ GHC libdir
+ :: LibDir -- ^ GHC libdir
-> CppOptions
-> FilePath -- ^ File to be parsed
-> IO (ParseResult GHC.ParsedSource)
@@ -213,7 +213,7 @@ parseModuleWithCpp libdir cpp fp = do
-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of
-- this function.
parseModuleEpAnnsWithCpp
- :: FilePath -- ^ GHC libdir
+ :: LibDir -- ^ GHC libdir
-> CppOptions
-> FilePath -- ^ File to be parsed
-> IO
@@ -226,7 +226,7 @@ parseModuleEpAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do
parseModuleEpAnnsWithCppInternal cppOptions dflags file
-- | Internal function. Default runner of GHC.Ghc action in IO.
-ghcWrapper :: FilePath -> GHC.Ghc a -> IO a
+ghcWrapper :: LibDir -> GHC.Ghc a -> IO a
ghcWrapper libdir a =
GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
$ GHC.runGhc (Just libdir) a
@@ -303,6 +303,7 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p'
-- See ghc tickets #15513, #15541.
initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags
initDynFlags file = do
+ -- Based on GHC backpack driver doBackPack
dflags0 <- GHC.getSessionDynFlags
let parser_opts0 = GHC.initParserOpts dflags0
(_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file
@@ -327,6 +328,7 @@ initDynFlags file = do
-- See ghc tickets #15513, #15541.
initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags
initDynFlagsPure fp s = do
+ -- AZ Note: "I" below appears to be Lennart Spitzner
-- I was told we could get away with using the unsafeGlobalDynFlags.
-- as long as `parseDynamicFilePragma` is impure there seems to be
-- no reason to use it.
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
index f95668141c..b238b2baa7 100644
--- a/utils/check-exact/Preprocess.hs
+++ b/utils/check-exact/Preprocess.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module provides support for CPP, interpreter directives and line
-- pragmas.
module Preprocess
@@ -16,6 +17,7 @@ module Preprocess
import qualified GHC as GHC hiding (parseModule)
import qualified Control.Monad.IO.Class as GHC
+import qualified GHC.Data.Bag as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.Config.Parser as GHC
@@ -26,17 +28,16 @@ import qualified GHC.Driver.Pipeline as GHC
import qualified GHC.Fingerprint.Type as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Settings as GHC
-import qualified GHC.Types.Error as GHC (getMessages)
+import qualified GHC.Types.Error as GHC (getErrorMessages, DiagnosticMessage(..))
import qualified GHC.Types.SourceError as GHC
import qualified GHC.Types.SourceFile as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Error as GHC
import qualified GHC.Utils.Fingerprint as GHC
-import qualified GHC.Utils.Outputable as GHC
import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)
import GHC.Data.FastString (mkFastString)
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, intercalate)
import Data.Maybe
import Types
import Utils
@@ -74,14 +75,14 @@ checkLine line s
size = length pragma
mSrcLoc = mkSrcLoc (mkFastString "LINE")
ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))
- in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss))
+ in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))
-- Deal with shebang/cpp directives too
-- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)
| "#!" `isPrefixOf` s =
let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG")
ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))
in
- ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss))
+ ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))
| otherwise = (s, Nothing)
getPragma :: String -> (String, String)
@@ -124,8 +125,8 @@ goodComment :: GHC.LEpaComment -> Bool
goodComment c = isGoodComment (tokComment c)
where
isGoodComment :: Comment -> Bool
- isGoodComment (Comment "" _ _) = False
- isGoodComment _ = True
+ isGoodComment (Comment "" _ _ _) = False
+ isGoodComment _ = True
toRealLocated :: GHC.Located a -> GHC.RealLocated a
@@ -167,7 +168,7 @@ getCppTokens directiveToks origSrcToks postCppToks = toks
missingAsComments = map mkCommentTok missingToks
where
mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)
- mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s placeholderBufSpan),s)
+ mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s (makeBufSpan l)),s)
toks = mergeBy locFn directiveToks missingAsComments
@@ -213,23 +214,29 @@ getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)
-> m (String, GHC.StringBuffer, GHC.DynFlags)
getPreprocessedSrcDirectPrim cppOptions src_fn = do
hsc_env <- GHC.getSession
- let dflags = GHC.hsc_dflags hsc_env
- new_env = GHC.hscSetFlags (injectCppOptions cppOptions dflags) hsc_env
+ let dfs = GHC.hsc_dflags hsc_env
+ new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }
r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile))
case r of
- Left err -> error $ showErrorMessages err
+ Left err -> error $ showErrorMessages $ fmap GHC.GhcDriverMessage err
Right (dflags', hspp_fn) -> do
buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn
txt <- GHC.liftIO $ readFileGhc hspp_fn
return (txt, buf, dflags')
-showErrorMessages :: GHC.Messages GHC.DriverMessage -> String
-showErrorMessages msgs =
- GHC.renderWithContext GHC.defaultSDocContext
- $ GHC.vcat
- $ GHC.pprMsgEnvelopeBagWithLoc
- $ GHC.getMessages
- $ msgs
+showErrorMessages :: GHC.ErrorMessages -> String
+showErrorMessages msgs = intercalate "\n"
+ $ map (show @(GHC.MsgEnvelope GHC.DiagnosticMessage) . fmap toDiagnosticMessage)
+ $ GHC.bagToList
+ $ GHC.getErrorMessages msgs
+
+-- | Show Error Messages relies on show instance for MsgEnvelope DiagnosticMessage
+-- We convert a known Diagnostic into this generic version
+toDiagnosticMessage :: GHC.Diagnostic e => e -> GHC.DiagnosticMessage
+toDiagnosticMessage msg = GHC.DiagnosticMessage { diagMessage = GHC.diagnosticMessage msg
+ , diagReason = GHC.diagnosticReason msg
+ , diagHints = GHC.diagnosticHints msg
+ }
injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
injectCppOptions CppOptions{..} dflags =
@@ -261,7 +268,7 @@ getPreprocessorAsComments srcFile = do
let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')
$ zip [1..] (lines fcontents)
- let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line placeholderBufSpan),line)
+ let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line (makeBufSpan l)),line)
where
start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1
end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line)
@@ -270,11 +277,11 @@ getPreprocessorAsComments srcFile = do
let toks = map mkTok directives
return toks
-placeholderBufSpan :: GHC.PsSpan
-placeholderBufSpan = pspan
+makeBufSpan :: GHC.SrcSpan -> GHC.PsSpan
+makeBufSpan ss = pspan
where
bl = GHC.BufPos 0
- pspan = GHC.PsSpan GHC.placeholderRealSpan (GHC.BufSpan bl bl)
+ pspan = GHC.PsSpan (GHC.realSrcSpan ss) (GHC.BufSpan bl bl)
-- ---------------------------------------------------------------------
@@ -283,7 +290,8 @@ parseError pst = do
let
-- (warns,errs) = GHC.getMessages pst dflags
-- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
- GHC.throwErrors $ (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)
+ -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst))
+ GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst))
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index 3009160c89..495b299a47 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -31,26 +32,11 @@ module Transform
-- * Transform monad operations
, logTr
, logDataWithAnnsTr
- , getAnnsT, putAnnsT, modifyAnnsT
, uniqueSrcSpanT
- , cloneT
- , graftT
-
- , getEntryDPT
- , setEntryDPT
- , transferEntryDPT
- , setPrecedingLinesDeclT
- , setPrecedingLinesT
- , addSimpleAnnT
- , addTrailingCommaT
- , removeTrailingCommaT
-
-- ** Managing declarations, in Transform monad
, HasTransform (..)
, HasDecls (..)
- , hasDeclsSybTransform
- , hsDeclsGeneric
, hsDeclsPatBind, hsDeclsPatBindD
, replaceDeclsPatBind, replaceDeclsPatBindD
, modifyDeclsT
@@ -79,8 +65,6 @@ module Transform
, balanceComments
, balanceCommentsList
, balanceCommentsList'
- , balanceTrailingComments
- , moveTrailingComments
, anchorEof
-- ** Managing lists, pure functions
@@ -93,23 +77,17 @@ module Transform
, isUniqueSrcSpan
-- * Pure functions
- , mergeAnns
- , mergeAnnList
- , setPrecedingLinesDecl
- , setPrecedingLines
- , getEntryDP
, setEntryDP
- , setEntryDP'
+ , getEntryDP
, transferEntryDP
, transferEntryDP'
- , addTrailingComma
, wrapSig, wrapDecl
, decl2Sig, decl2Bind
- , deltaAnchor
) where
import Types
import Utils
+import Orphans (Default(..))
import Control.Monad.RWS
import qualified Control.Monad.Fail as Fail
@@ -119,15 +97,11 @@ import GHC.Data.Bag
import GHC.Data.FastString
import Data.Data
-import Data.List (sortBy, sortOn, find)
+import Data.List ( sortBy )
import Data.Maybe
-import qualified Data.Map as Map
-
import Data.Functor.Identity
import Control.Monad.State
-import Control.Monad.Writer
-
------------------------------------------------------------------------------
-- Transformation of source elements
@@ -137,11 +111,11 @@ import Control.Monad.Writer
type Transform = TransformT Identity
-- |Monad transformer version of 'Transform' monad
-newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a }
+newtype TransformT m a = TransformT { unTransformT :: RWST () [String] Int m a }
deriving (Monad,Applicative,Functor
,MonadReader ()
,MonadWriter [String]
- ,MonadState (Anns,Int)
+ ,MonadState Int
,MonadTrans
)
@@ -150,21 +124,21 @@ instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where
-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr'
-runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])
-runTransform ans f = runTransformFrom 0 ans f
+runTransform :: Transform a -> (a,Int,[String])
+runTransform f = runTransformFrom 0 f
-runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String])
-runTransformT ans f = runTransformFromT 0 ans f
+runTransformT :: TransformT m a -> m (a,Int,[String])
+runTransformT f = runTransformFromT 0 f
-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr', allocating any new
-- SrcSpans from the provided initial value.
-runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String])
-runTransformFrom seed ans f = runRWS (unTransformT f) () (ans,seed)
+runTransformFrom :: Int -> Transform a -> (a,Int,[String])
+runTransformFrom seed f = runRWS (unTransformT f) () seed
-- |Run a monad transformer stack for the 'TransformT' monad transformer
-runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])
-runTransformFromT seed ans f = runRWST (unTransformT f) () (ans,seed)
+runTransformFromT :: Int -> TransformT m a -> m (a,Int,[String])
+runTransformFromT seed f = runRWST (unTransformT f) () seed
-- | Change inner monad of 'TransformT'.
hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a
@@ -180,31 +154,14 @@ logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m ()
logDataWithAnnsTr str ast = do
logTr $ str ++ showAst ast
--- |Access the 'Anns' being modified in this transformation
-getAnnsT :: (Monad m) => TransformT m Anns
-getAnnsT = gets fst
-
--- |Replace the 'Anns' after any changes
-putAnnsT :: (Monad m) => Anns -> TransformT m ()
-putAnnsT ans = do
- (_,col) <- get
- put (ans,col)
-
--- |Change the stored 'Anns'
-modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m ()
-modifyAnnsT f = do
- ans <- getAnnsT
- putAnnsT (f ans)
-
-- ---------------------------------------------------------------------
--- |Once we have 'Anns', a 'SrcSpan' is used purely as part of an 'AnnKey'
--- to index into the 'Anns'. If we need to add new elements to the AST, they
--- need their own 'SrcSpan' for this.
+-- |If we need to add new elements to the AST, they need their own
+-- 'SrcSpan' for this.
uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan
uniqueSrcSpanT = do
- (an,col) <- get
- put (an,col + 1 )
+ col <- get
+ put (col + 1 )
let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col
return $ mkSrcSpan pos pos
@@ -217,43 +174,6 @@ srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s
srcSpanStartLine' _ = 0
-- ---------------------------------------------------------------------
--- |Make a copy of an AST element, replacing the existing SrcSpans with new
--- ones, and duplicating the matching annotations.
-cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(SrcSpan, SrcSpan)])
-cloneT ast = do
- runWriterT $ everywhereM (return `ext2M` replaceLocated) ast
- where
- replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m)
- => (GenLocated loc a) -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
- replaceLocated (L l t) = do
- case cast l :: Maybe SrcSpan of
- Just ss -> do
- newSpan <- lift uniqueSrcSpanT
- lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) anns of
- Nothing -> anns
- Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns)
- tell [(ss, newSpan)]
- return $ fromJust . cast $ L newSpan t
- Nothing -> return (L l t)
-
--- ---------------------------------------------------------------------
--- |Slightly more general form of cloneT
-graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a
-graftT origAnns = everywhereM (return `ext2M` replaceLocated)
- where
- replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m)
- => GenLocated loc a -> TransformT m (GenLocated loc a)
- replaceLocated (L l t) = do
- case cast l :: Maybe SrcSpan of
- Just ss -> do
- newSpan <- uniqueSrcSpanT
- modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) origAnns of
- Nothing -> anns
- Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns)
- return $ fromJust $ cast $ L newSpan t
- Nothing -> return (L l t)
-
--- ---------------------------------------------------------------------
-- |If a list has been re-ordered or had items added, capture the new order in
-- the appropriate 'AnnSortKey' attached to the 'Annotation' for the list.
@@ -270,7 +190,7 @@ captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )))))
ms' = captureLineSpacing ms
captureMatchLineSpacing d = d
-captureLineSpacing :: Monoid t
+captureLineSpacing :: Default t
=> [LocatedAn t e] -> [LocatedAn t e]
captureLineSpacing [] = []
captureLineSpacing [d] = [d]
@@ -278,7 +198,7 @@ captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds)
where
(l1,_) = ss2pos $ rs $ getLocA de1
(l2,_) = ss2pos $ rs $ getLocA d2
- d2' = setEntryDP' d2 (deltaPos (l2-l1) 0)
+ d2' = setEntryDP d2 (deltaPos (l2-l1) 0)
-- ---------------------------------------------------------------------
@@ -292,7 +212,6 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
rd = case last ns of
L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll
L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
- -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r
dc' = case dca of
EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
EpaDelta _ _ -> AddEpAnn kw dca
@@ -348,131 +267,51 @@ wrapDecl (L l s) = L l (ValD NoExtField s)
-- ---------------------------------------------------------------------
--- |Create a simple 'Annotation' without comments, and attach it to the first
--- parameter.
-addSimpleAnnT :: (Data a,Monad m)
- => Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
-addSimpleAnnT ast dp kds = do
- let ann = annNone { annEntryDelta = dp
- , annsDP = kds
- }
- modifyAnnsT (Map.insert (mkAnnKey ast) ann)
-
--- ---------------------------------------------------------------------
-
--- |Add a trailing comma annotation, unless there is already one
-addTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m ()
-addTrailingCommaT ast = do
- modifyAnnsT (addTrailingComma ast (SameLine 0))
-
--- ---------------------------------------------------------------------
-
--- |Remove a trailing comma annotation, if there is one one
-removeTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m ()
-removeTrailingCommaT ast = do
- modifyAnnsT (removeTrailingComma ast)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'getEntryDP'
-getEntryDPT :: (Data a,Monad m) => Located a -> TransformT m DeltaPos
-getEntryDPT ast = do
- anns <- getAnnsT
- return (getEntryDP anns ast)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'getEntryDP'
-setEntryDPT :: (Monad m) => LocatedA a -> DeltaPos -> TransformT m ()
-setEntryDPT ast dp = do
- modifyAnnsT (setEntryDP ast dp)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'transferEntryDP'
-transferEntryDPT :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
-transferEntryDPT _a b = do
- return b
- -- modifyAnnsT (transferEntryDP a b)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'setPrecedingLinesDecl'
-setPrecedingLinesDeclT :: (Monad m) => LHsDecl GhcPs -> Int -> Int -> TransformT m ()
-setPrecedingLinesDeclT ld n c =
- modifyAnnsT (setPrecedingLinesDecl ld n c)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'setPrecedingLines'
-setPrecedingLinesT :: (Monad m) => LocatedA a -> Int -> Int -> TransformT m ()
-setPrecedingLinesT ld n c =
- modifyAnnsT (setPrecedingLines ld n c)
-
--- ---------------------------------------------------------------------
-
--- | Left bias pair union
-mergeAnns :: Anns -> Anns -> Anns
-mergeAnns
- = Map.union
-
--- |Combine a list of annotations
-mergeAnnList :: [Anns] -> Anns
-mergeAnnList [] = error "mergeAnnList must have at lease one entry"
-mergeAnnList (x:xs) = foldr mergeAnns x xs
-
--- ---------------------------------------------------------------------
-
--- |Unwrap a HsDecl and call setPrecedingLines on it
--- ++AZ++ TODO: get rid of this, it is a synonym only
-setPrecedingLinesDecl :: LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
-setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans
-
--- ---------------------------------------------------------------------
-
--- | Adjust the entry annotations to provide an `n` line preceding gap
-setPrecedingLines :: LocatedA a -> Int -> Int -> Anns -> Anns
-setPrecedingLines ast n c anne = setEntryDP ast (deltaPos n c) anne
-
--- ---------------------------------------------------------------------
-
--- |Return the true entry 'DeltaPos' from the annotation for a given AST
--- element. This is the 'DeltaPos' ignoring any comments.
-getEntryDP :: (Data a) => Anns -> Located a -> DeltaPos
-getEntryDP anns ast =
- case Map.lookup (mkAnnKey ast) anns of
- Nothing -> SameLine 0
- Just ann -> annTrueEntryDelta ann
-
--- ---------------------------------------------------------------------
-
setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs
setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp
= L l' (ValD x (FunBind a b (MG c (L d ms'))))
where
- L l' _ = setEntryDP' decl dp
+ L l' _ = setEntryDP decl dp
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
ms' = case ms of
[] -> []
- (m0':ms0) -> setEntryDP' m0' dp : ms0
-setEntryDPDecl d dp = setEntryDP' d dp
+ (m0':ms0) -> setEntryDP m0' dp : ms0
+setEntryDPDecl d dp = setEntryDP d dp
-- ---------------------------------------------------------------------
-- |Set the true entry 'DeltaPos' from the annotation for a given AST
-- element. This is the 'DeltaPos' ignoring any comments.
--- setEntryDP' :: (Data a) => LocatedA a -> DeltaPos -> LocatedA a
-setEntryDP' :: (Monoid t) => LocatedAn t a -> DeltaPos -> LocatedAn t a
-setEntryDP' (L (SrcSpanAnn EpAnnNotUsed l) a) dp
+setEntryDP :: Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
+setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp
= L (SrcSpanAnn
- (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments)
+ (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) def emptyComments)
l) a
-setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp
= L (SrcSpanAnn
(EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments []))
l) a
-setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
- = case sortAnchorLocated (priorComments cs) of
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp
+ = L (SrcSpanAnn
+ (EpAnn (Anchor r (MovedAnchor d')) an cs')
+ l) a
+ where
+ (d',cs') = case cs of
+ EpaComments (h:t) ->
+ let
+ (dp0,c') = go h
+ in
+ (dp0, EpaComments (c':t))
+ EpaCommentsBalanced (h:t) ts ->
+ let
+ (dp0,c') = go h
+ in
+ (dp0, EpaCommentsBalanced (c':t) ts)
+ _ -> (dp, cs)
+ go (L (Anchor rr (MovedAnchor ma)) c) = (d, L (Anchor rr (MovedAnchor ma)) c)
+ go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp)) c)
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
+ = case sortEpaComments (priorComments cs) of
[] ->
L (SrcSpanAnn
(EpAnn (Anchor r (MovedAnchor dp)) an cs)
@@ -484,57 +323,59 @@ setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
where
cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs')
lc = head $ reverse $ (L ca c:cs')
- delta = ss2delta (ss2pos $ anchor $ getLoc lc) r
+ delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
line = getDeltaLine delta
col = deltaColumn delta
- -- TODO: this adjustment by 1 happens all over the place. Generalise it
edp' = if line == 0 then SameLine col
else DifferentLine line col
- edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
+ edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
--- |Set the true entry 'DeltaPos' from the annotation for a given AST
--- element. This is the 'DeltaPos' ignoring any comments.
-setEntryDP :: LocatedA a -> DeltaPos -> Anns -> Anns
-setEntryDP _ast _dp anns = anns
+
+-- ---------------------------------------------------------------------
+
+getEntryDP :: LocatedAn t a -> DeltaPos
+getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp)) _ _) _) _) = dp
+getEntryDP _ = SameLine 1
-- ---------------------------------------------------------------------
addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs
addEpaLocationDelta off anc (EpaSpan r)
- = EpaDelta (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) []
+ = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
-- Set the entry DP for an element coming after an existing keyword annotation
setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a
-setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP' ll dp'
+setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp'
where
r = case la of
(SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l
(SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r'
- dp' = adjustDeltaForOffset 0 off (ss2deltaEnd anc r)
+ dp' = adjustDeltaForOffset off (ss2deltaEnd anc r)
-- ---------------------------------------------------------------------
-- |Take the annEntryDelta associated with the first item and associate it with the second.
-- Also transfer any comments occuring before it.
-transferEntryDP :: (Monad m, Monoid t) => LocatedAn t a -> LocatedAn t b -> TransformT m (LocatedAn t b)
+transferEntryDP :: (Monad m, Monoid t2, Typeable t1, Typeable t2)
+ => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do
logTr $ "transferEntryDP': EpAnnNotUsed,EpAnnNotUsed"
return (L (SrcSpanAnn EpAnnNotUsed l1) b)
transferEntryDP (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do
logTr $ "transferEntryDP': EpAnn,EpAnnNotUsed"
return (L (SrcSpanAnn (EpAnn anc mempty cs) l2) b)
-transferEntryDP (L (SrcSpanAnn (EpAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do
+transferEntryDP (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do
logTr $ "transferEntryDP': EpAnn,EpAnn"
-- Problem: if the original had preceding comments, blindly
-- transferring the location is not correct
case priorComments cs1 of
- [] -> return (L (SrcSpanAnn (EpAnn anc1 an2 cs2) l2) b)
+ [] -> return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) cs2) l2) b)
-- TODO: what happens if the receiving side already has comments?
(L anc _:_) -> do
logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc
- return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b)
+ return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) l2) b)
transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do
logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn"
return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b)
@@ -542,6 +383,11 @@ transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 a
anc2' = case anc2 of
Anchor _a op -> Anchor (realSrcSpan l2) op
+
+-- |If a and b are the same type return first arg, else return second
+combine :: (Typeable a, Typeable b) => a -> b -> b
+combine x y = fromMaybe y (cast x)
+
-- |Take the annEntryDelta associated with the first item and associate it with the second.
-- Also transfer any comments occuring before it.
-- TODO: call transferEntryDP, and use pushDeclDP
@@ -555,49 +401,24 @@ pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs
pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp
= ValD x (FunBind a b (MG c (L d' ms')))
where
- L d' _ = setEntryDP' (L d ms) dp
+ L d' _ = setEntryDP (L d ms) dp
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
ms' = case ms of
[] -> []
- (m0':ms0) -> setEntryDP' m0' dp : ms0
+ (m0':ms0) -> setEntryDP m0' dp : ms0
pushDeclDP d _dp = d
-- ---------------------------------------------------------------------
-addTrailingComma :: (Data a) => Located a -> DeltaPos -> Anns -> Anns
-addTrailingComma a dp anns =
- case Map.lookup (mkAnnKey a) anns of
- Nothing -> anns
- Just an ->
- case find isAnnComma (annsDP an) of
- Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G AnnComma,dp)]}) anns
- Just _ -> anns
- where
- isAnnComma (G AnnComma,_) = True
- isAnnComma _ = False
-
--- ---------------------------------------------------------------------
-
-removeTrailingComma :: (Data a) => Located a -> Anns -> Anns
-removeTrailingComma a anns =
- case Map.lookup (mkAnnKey a) anns of
- Nothing -> anns
- Just an ->
- case find isAnnComma (annsDP an) of
- Nothing -> anns
- Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns
- where
- isAnnComma (G AnnComma,_) = True
- isAnnComma _ = False
-
--- ---------------------------------------------------------------------
-
balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
-balanceCommentsList [] = return []
-balanceCommentsList [x] = return [x]
-balanceCommentsList (a:b:ls) = do
+balanceCommentsList ds = balanceCommentsList'' ds
+
+balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
+balanceCommentsList'' [] = return []
+balanceCommentsList'' [x] = return [x]
+balanceCommentsList'' (a:b:ls) = do
(a',b') <- balanceComments a b
- r <- balanceCommentsList (b':ls)
+ r <- balanceCommentsList'' (b':ls)
return (a':r)
-- |The GHC parser puts all comments appearing between the end of one AST
@@ -610,8 +431,6 @@ balanceComments :: (Monad m)
=> LHsDecl GhcPs -> LHsDecl GhcPs
-> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs)
balanceComments first second = do
- -- logTr $ "balanceComments entered"
- -- logDataWithAnnsTr "first" first
case first of
(L l (ValD x fb@(FunBind{}))) -> do
(L l' fb',second') <- balanceCommentsFB (L l fb) second
@@ -631,11 +450,11 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
-- + move the trailing ones to the last match.
let
split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf)
- split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortAnchorLocated $ priorComments split))
+ split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split))
- before = sortAnchorLocated $ priorComments split2
- middle = sortAnchorLocated $ getFollowingComments split2
- after = sortAnchorLocated $ getFollowingComments split
+ before = sortEpaComments $ priorComments split2
+ middle = sortEpaComments $ getFollowingComments split2
+ after = sortEpaComments $ getFollowingComments split
lf' = setCommentsSrcAnn lf (EpaComments before)
logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after)
@@ -654,7 +473,6 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
[] -> moveLeadingComments m'' lf'
_ -> (m'',lf')
logTr $ "balanceCommentsMatch done"
- -- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second')
balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second'
balanceCommentsFB f s = balanceComments' f s
@@ -663,13 +481,7 @@ balanceCommentsFB f s = balanceComments' f s
balanceCommentsMatch :: (Monad m)
=> LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
- logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l))
- -- logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay')
logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo)
- -- logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l))
- logTr $ "balanceCommentsMatch: (anc1,cs1f)=" ++ showAst (anc1,cs1f)
- logTr $ "balanceCommentsMatch: (move,stay)=" ++ showAst (move,stay)
- logTr $ "balanceCommentsMatch: (l'', grhss')=" ++ showAst (l'', grhss')
return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds')))
where
simpleBreak (r,_) = r /= 0
@@ -681,8 +493,9 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
stay = map snd stay'
(l'', grhss', binds', logInfo)
= case reverse grhss of
- [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
- (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
+ [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
+ (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs)
+ -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
(L lg (GRHS ag grs rhs):gs) ->
let
anc1' = setFollowingComments anc1 stay
@@ -707,11 +520,11 @@ pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:H
pushTrailingComments w cs lb@(HsValBinds an _)
= (True, HsValBinds an' vb)
where
- (decls, _, _ws1) = runTransform mempty (hsDeclsValBinds lb)
+ (decls, _, _ws1) = runTransform (hsDeclsValBinds lb)
(an', decls') = case reverse decls of
[] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls)
(L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds)
- (vb,_ws2) = case runTransform mempty (replaceDeclsValbinds w lb (reverse decls')) of
+ (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb (reverse decls')) of
((HsValBinds _ vb'), _, ws2') -> (vb', ws2')
_ -> (ValBinds NoAnnSortKey emptyBag [], [])
@@ -736,7 +549,6 @@ balanceComments' la1 la2 = do
logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2)
logTr $ "balanceComments': (anc1)=" ++ showAst (anc1)
logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s)
- logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sortOn fst cs1f)
logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move)
logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2')
return (la1', la2')
@@ -762,8 +574,8 @@ balanceComments' la1 la2 = do
-- Need to also check for comments more closely attached to la1,
-- ie trailing on the same line
(move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay''))
- move = sortAnchorLocated $ map snd (cs1move ++ move'' ++ move')
- stay = sortAnchorLocated $ map snd (cs1stay ++ stay')
+ move = sortEpaComments $ map snd (cs1move ++ move'' ++ move')
+ stay = sortEpaComments $ map snd (cs1stay ++ stay')
an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move)
an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f))
@@ -785,7 +597,7 @@ trailingCommentsDeltas anc (la@(L l _):las)
-- AZ:TODO: this is identical to commentsDeltas
priorCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
-priorCommentsDeltas anc cs = go anc (reverse $ sortAnchorLocated cs)
+priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs)
where
go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]
go _ [] = []
@@ -798,6 +610,8 @@ priorCommentsDeltas anc cs = go anc (reverse $ sortAnchorLocated cs)
(ll,_) = ss2pos (anchor loc)
+-- ---------------------------------------------------------------------
+
-- | Split comments into ones occuring before the end of the reference
-- span, and those after it.
splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
@@ -839,8 +653,8 @@ moveLeadingComments (L la a) lb = (L la' a, lb')
`debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb'))
where
split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la)
- before = sortAnchorLocated $ priorComments split
- after = sortAnchorLocated $ getFollowingComments split
+ before = sortEpaComments $ priorComments split
+ after = sortEpaComments $ getFollowingComments split
-- TODO: need to set an entry delta on lb' to zero, and move the
-- original spacing to the first comment.
@@ -880,17 +694,30 @@ anchorFromLocatedA (L (SrcSpanAnn an loc) _)
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp))
= (L (GHC.Anchor la op) (GHC.EpaComment t pp))
+ `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op))
where
(r,c) = ss2posEnd pp
+
op' = if r == 0
then MovedAnchor (ss2delta (r,c+1) la)
- else MovedAnchor (ss2delta (r,c) la)
+ -- then MovedAnchor (ss2delta (r,c+0) la)
+ -- else MovedAnchor (ss2delta (r,c) la)
+ else MovedAnchor (tweakDelta $ ss2delta (r,c) la)
op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0)
then MovedAnchor (DifferentLine 1 0)
else op'
-- ---------------------------------------------------------------------
+
+-- | For comment-related deltas starting on a new line we have an
+-- off-by-one problem. Adjust
+tweakDelta :: DeltaPos -> DeltaPos
+tweakDelta (SameLine d) = SameLine d
+tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
+
+-- ---------------------------------------------------------------------
+
balanceSameLineComments :: (Monad m)
=> LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
@@ -917,7 +744,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
gac = addCommentOrigDeltas $ epAnnComments ga
gfc = getFollowingComments gac
- gac' = setFollowingComments gac (sortAnchorLocated $ gfc ++ move)
+ gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move)
ga' = (EpAnn anc an gac')
an1' = setCommentsSrcAnn la cs1
@@ -925,59 +752,6 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
-- ---------------------------------------------------------------------
-
--- |After moving an AST element, make sure any comments that may belong
--- with the following element in fact do. Of necessity this is a heuristic
--- process, to be tuned later. Possibly a variant should be provided with a
--- passed-in decision function.
-balanceTrailingComments :: (Monad m) => (Data a,Data b) => Located a -> Located b
- -> TransformT m [(Comment, DeltaPos)]
-balanceTrailingComments first second = do
- let
- k1 = mkAnnKey first
- k2 = mkAnnKey second
- moveComments p ans = (ans',move)
- where
- an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans
- an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans
- cs1f = annFollowingComments an1
- (move,stay) = break p cs1f
- an1' = an1 { annFollowingComments = stay }
- ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans
-
- simpleBreak (_,SameLine _) = False
- simpleBreak (_,DifferentLine _ _) = True
-
- ans <- getAnnsT
- let (ans',mov) = moveComments simpleBreak ans
- putAnnsT ans'
- return mov
-
--- ---------------------------------------------------------------------
-
--- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for
--- |Move any 'annFollowingComments' values from the 'Annotation' associated to
--- the first parameter to that of the second.
-moveTrailingComments :: (Data a,Data b)
- => Located a -> Located b -> Transform ()
-moveTrailingComments first second = do
- let
- k1 = mkAnnKey first
- k2 = mkAnnKey second
- moveComments ans = ans'
- where
- an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans
- an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans
- cs1f = annFollowingComments an1
- cs2f = annFollowingComments an2
- an1' = an1 { annFollowingComments = [] }
- an2' = an2 { annFollowingComments = cs1f ++ cs2f }
- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
-
- modifyAnnsT moveComments
-
--- ---------------------------------------------------------------------
-
anchorEof :: ParsedSource -> ParsedSource
anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
where
@@ -992,15 +766,6 @@ commentsOrigDeltasDecl (L (SrcSpanAnn an l) d) = L (SrcSpanAnn an' l) d
-- ---------------------------------------------------------------------
--- | Take an anchor and a preceding location, and generate an
--- equivalent one with a 'MovedAnchor' delta.
-deltaAnchor :: Anchor -> RealSrcSpan -> Anchor
-deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp)
- where
- dp = ss2delta (ss2pos anc) ss
-
--- ---------------------------------------------------------------------
-
-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the
-- given @DeltaPos@.
noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann)
@@ -1026,13 +791,13 @@ dn :: Int -> EpaLocation
dn n = EpaDelta (SameLine n) []
m0 :: AnchorOperation
-m0 = MovedAnchor (SameLine 0)
+m0 = MovedAnchor $ SameLine 0
m1 :: AnchorOperation
-m1 = MovedAnchor (SameLine 1)
+m1 = MovedAnchor $ SameLine 1
mn :: Int -> AnchorOperation
-mn n = MovedAnchor (SameLine n)
+mn n = MovedAnchor $ SameLine n
addComma :: SrcSpanAnnA -> SrcSpanAnnA
addComma (SrcSpanAnn EpAnnNotUsed l)
@@ -1154,12 +919,7 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
(l', rhs') <- case binds of
EmptyLocalBinds{} -> do
logTr $ "replaceDecls LMatch empty binds"
- modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4)
- -- only move the comment if the original where clause was empty.
- -- toMove <- balanceTrailingComments m m
- -- insertCommentBefore (mkAnnKey m) toMove (matchEpAnn AnnWhere)
- -- TODO: move trailing comments on the same line to before the binds
logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m
L l' m' <- balanceSameLineComments m
logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m')
@@ -1180,8 +940,8 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
logTr "replaceDecls HsLet"
let lastAnc = realSrcSpan $ spanHsLocaLBinds binds
-- TODO: may be an intervening comment, take account for lastAnc
- let (newDecls', tkIn', ex') = case (tkLet, tkIn) of
- (L (TokenLoc l) _, L (TokenLoc i) _) ->
+ let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of
+ (L (TokenLoc l) ls, L (TokenLoc i) is) ->
let
off = case l of
(EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r
@@ -1191,12 +951,14 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
newDecls'' = case newDecls of
[] -> newDecls
(d:ds) -> setEntryDPDecl d (SameLine 0) : ds
- in ( newDecls''
- , L (TokenLoc (addEpaLocationDelta off lastAnc i)) HsTok
- , ex'' )
- _ -> (newDecls, tkIn, ex)
+ -- in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs
+ in ( L (TokenLoc l) ls
+ , L (TokenLoc (addEpaLocationDelta off lastAnc i)) is
+ , ex''
+ , newDecls'')
+ (_,_) -> (tkLet, tkIn, ex, newDecls)
binds' <- replaceDeclsValbinds WithoutWhere binds newDecls'
- return (L ll (HsLet x tkLet binds' tkIn' ex'))
+ return (L ll (HsLet x tkLet' binds' tkIn' ex'))
-- TODO: does this make sense? Especially as no hsDecls for HsPar
replaceDecls (L l (HsPar x lpar e rpar)) newDecls
@@ -1246,21 +1008,7 @@ replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs]
replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls
= do
logTr "replaceDecls PatBind"
- -- Need to throw in a fresh where clause if the binds were empty,
- -- in the annotations.
- case binds of
- EmptyLocalBinds{} -> do
- let
- addWhere _mkds =
- error "TBD"
- modifyAnnsT addWhere
- modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4)
-
- _ -> return ()
-
- -- modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)
binds'' <- replaceDeclsValbinds WithWhere binds newDecls
- -- let binds' = L (getLoc binds) binds''
return (L l (PatBind x a (GRHSs xr rhss binds'')))
replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
@@ -1275,9 +1023,7 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
replaceDecls (L l (LetStmt x lb)) newDecls
= do
- -- modifyAnnsT (captureOrder s newDecls)
lb'' <- replaceDeclsValbinds WithWhere lb newDecls
- -- let lb' = L (getLoc lb) lb''
return (L l (LetStmt x lb''))
replaceDecls (L l (LastStmt x e d se)) newDecls
= do
@@ -1300,102 +1046,6 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
-- ---------------------------------------------------------------------
--- |Do a transformation on an AST fragment by providing a function to process
--- the general case and one specific for a 'LHsBind'. This is required
--- because a 'FunBind' may have multiple 'Match' items, so we cannot
--- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.
-hasDeclsSybTransform :: (Data t2,Monad m)
- => (forall t. HasDecls t => t -> m t)
- -- ^Worker function for the general case
- -> (LHsBind GhcPs -> m (LHsBind GhcPs))
- -- ^Worker function for FunBind/PatBind
- -> t2 -- ^Item to be updated
- -> m t2
-hasDeclsSybTransform workerHasDecls workerBind t = trf t
- where
- trf = mkM parsedSource
- `extM` lmatch
- `extM` lexpr
- `extM` lstmt
- `extM` lhsbind
- `extM` lvald
-
- parsedSource (p::ParsedSource) = workerHasDecls p
-
- lmatch (lm::LMatch GhcPs (LHsExpr GhcPs))
- = workerHasDecls lm
-
- lexpr (le::LHsExpr GhcPs)
- = workerHasDecls le
-
- lstmt (d::LStmt GhcPs (LHsExpr GhcPs))
- = workerHasDecls d
-
- lhsbind (b@(L _ FunBind{}):: LHsBind GhcPs)
- = workerBind b
- lhsbind b@(L _ PatBind{})
- = workerBind b
- lhsbind x = return x
-
- lvald (L l (ValD x d)) = do
- (L _ d') <- lhsbind (L l d)
- return (L l (ValD x d'))
- lvald x = return x
-
--- ---------------------------------------------------------------------
-
--- |A 'FunBind' wraps up one or more 'Match' items. 'hsDecls' cannot
--- return anything for these as there is not meaningful 'replaceDecls' for it.
--- This function provides a version of 'hsDecls' that returns the 'FunBind'
--- decls too, where they are needed for analysis only.
-hsDeclsGeneric :: (Data t,Monad m) => t -> TransformT m [LHsDecl GhcPs]
-hsDeclsGeneric t = q t
- where
- q = return []
- `mkQ` parsedSource
- `extQ` lmatch
- `extQ` lexpr
- `extQ` lstmt
- `extQ` lhsbind
- `extQ` lhsbindd
- `extQ` llocalbinds
- `extQ` localbinds
-
- parsedSource (p::ParsedSource) = hsDecls p
-
- lmatch (lm::LMatch GhcPs (LHsExpr GhcPs)) = hsDecls lm
-
- lexpr (le::LHsExpr GhcPs) = hsDecls le
-
- lstmt (d::LStmt GhcPs (LHsExpr GhcPs)) = hsDecls d
-
- -- ---------------------------------
-
- lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
- lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)))) = do
- dss <- mapM hsDecls matches
- return (concat dss)
- lhsbind p@(L _ (PatBind{})) = do
- hsDeclsPatBind p
- lhsbind _ = return []
-
- -- ---------------------------------
-
- lhsbindd (L l (ValD _ d)) = lhsbind (L l d)
- lhsbindd _ = return []
-
- -- ---------------------------------
-
- llocalbinds :: (Monad m) => Located (HsLocalBinds GhcPs) -> TransformT m [LHsDecl GhcPs]
- llocalbinds (L _ ds) = localbinds ds
-
- -- ---------------------------------
-
- localbinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
- localbinds d = hsDeclsValBinds d
-
--- ---------------------------------------------------------------------
-
-- |Look up the annotated order and sort the decls accordingly
-- TODO:AZ: this should be pure
orderedDecls :: (Monad m)
@@ -1492,8 +1142,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do
newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList)
newWhereAnnotation ww = do
newSpan <- uniqueSrcSpanT
- let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3))
- let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5))
+ let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))
+ let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))
let w = case ww of
WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])]
WithoutWhere -> []
@@ -1558,5 +1208,3 @@ modifyDeclsT action t = do
decls <- liftT $ hsDecls t
decls' <- action decls
liftT $ replaceDecls t decls'
-
--- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs
index b9c6981671..381d157e8b 100644
--- a/utils/check-exact/Types.hs
+++ b/utils/check-exact/Types.hs
@@ -13,120 +13,17 @@ module Types
import GHC hiding (EpaComment)
import GHC.Utils.Outputable hiding ( (<>) )
-import Data.Data (Data, toConstr,cast)
-
-import qualified Data.Map as Map
+import Data.Data (Data)
-- ---------------------------------------------------------------------
--- | This structure holds a complete set of annotations for an AST
-type Anns = Map.Map AnnKey Annotation
-
-emptyAnns :: Anns
-emptyAnns = Map.empty
-
--- | For every @Located a@, use the @SrcSpan@ and constructor name of
--- a as the key, to store the standard annotation.
--- These are used to maintain context in the AP and EP monads
-data AnnKey = AnnKey RealSrcSpan AnnConName
- deriving (Eq, Data, Ord)
-
--- More compact Show instance
-instance Show AnnKey where
- show (AnnKey ss cn) = "AnnKey " ++ showPprUnsafe ss ++ " " ++ show cn
-
-mkAnnKeyPrim :: (Data a) => Located a -> AnnKey
-mkAnnKeyPrim (L l a) = AnnKey (realSrcSpan l) (annGetConstr a)
-
-mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey
-mkAnnKeyPrimA (L l a) = AnnKey (realSrcSpan $ locA l) (annGetConstr a)
-
--- Holds the name of a constructor
-data AnnConName = CN { unConName :: String }
- deriving (Eq, Ord, Data)
-
--- More compact show instance
-instance Show AnnConName where
- show (CN s) = "CN " ++ show s
-
-annGetConstr :: (Data a) => a -> AnnConName
-annGetConstr a = CN (show $ toConstr a)
-
--- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.
-mkAnnKey :: (Data a) => Located a -> AnnKey
-mkAnnKey ld =
- case cast ld :: Maybe (LHsDecl GhcPs) of
- Just d -> declFun mkAnnKeyPrimA d
- Nothing -> mkAnnKeyPrim ld
-
type Pos = (Int,Int)
-- ---------------------------------------------------------------------
-annNone :: Annotation
-annNone = Ann (SameLine 0) [] [] [] Nothing Nothing
-
-data Annotation = Ann
- {
- -- The first three fields relate to interfacing up into the AST
- annEntryDelta :: !DeltaPos
- -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior
- -- output was, including all annPriorComments (field below).
- , annPriorComments :: ![(Comment, DeltaPos)]
- -- ^ Comments coming after the last non-comment output of the preceding
- -- element but before the SrcSpan being annotated by this Annotation. If
- -- these are changed then annEntryDelta (field above) must also change to
- -- match.
- , annFollowingComments :: ![(Comment, DeltaPos)]
- -- ^ Comments coming after the last output for the element subject to this
- -- Annotation. These will only be added by AST transformations, and care
- -- must be taken not to disturb layout of following elements.
-
- -- The next three fields relate to interacing down into the AST
- , annsDP :: ![(KeywordId, DeltaPos)]
- -- ^ Annotations associated with this element.
- , annSortKey :: !(Maybe [RealSrcSpan])
- -- ^ Captures the sort order of sub elements. This is needed when the
- -- sub-elements have been split (as in a HsLocalBind which holds separate
- -- binds and sigs) or for infix patterns where the order has been
- -- re-arranged. It is captured explicitly so that after the Delta phase a
- -- SrcSpan is used purely as an index into the annotations, allowing
- -- transformations of the AST including the introduction of new Located
- -- items or re-arranging existing ones.
- , annCapturedSpan :: !(Maybe AnnKey)
- -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of
- -- elements which we must remember for the Print phase. e.g. the statements
- -- in a HsLet or HsDo. These must be managed as a group because they all
- -- need eo be vertically aligned for the Haskell layout rules, and this
- -- guarantees this property in the presence of AST edits.
-
- } deriving (Eq)
-
--- ---------------------------------------------------------------------
-
-declFun :: (forall a . Data a => LocatedA a -> b) -> LHsDecl GhcPs -> b
-declFun f (L l de) =
- case de of
- TyClD _ d -> f (L l d)
- InstD _ d -> f (L l d)
- DerivD _ d -> f (L l d)
- ValD _ d -> f (L l d)
- SigD _ d -> f (L l d)
- KindSigD _ d -> f (L l d)
- DefD _ d -> f (L l d)
- ForD _ d -> f (L l d)
- WarningD _ d -> f (L l d)
- AnnD _ d -> f (L l d)
- RuleD _ d -> f (L l d)
- SpliceD _ d -> f (L l d)
- DocD _ d -> f (L l d)
- RoleAnnotD _ d -> f (L l d)
-
--- ---------------------------------------------------------------------
-
data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
-
+-- ---------------------------------------------------------------------
-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted
-- from an @AnnKeywordId@ because the annotation must be interleaved into the
@@ -134,47 +31,34 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
data Comment = Comment
{
commentContents :: !String -- ^ The contents of the comment including separators
-
- -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is
- -- the thing we use to decide where in the output stream the comment should
- -- go.
, commentAnchor :: !Anchor
+ , commentPriorTok :: !RealSrcSpan
, commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
}
- deriving (Eq)
+ deriving (Data, Eq)
instance Show Comment where
- show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show o ++ ")"
+ show (Comment cs ss r o)
+ = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show r ++ " " ++ show o ++ ")"
instance Ord Comment where
- compare (Comment _ ss1 _) (Comment _ ss2 _) = compare (anchor ss1) (anchor ss2)
+ -- When we have CPP injected comments with a fake filename, or LINE
+ -- pragma, the file name changes, so we need to compare the
+ -- locations only, with out the filename.
+ compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2)
+ where
+ ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
instance Outputable Comment where
ppr x = text (show x)
--- | The different syntactic elements which are not represented in the
--- AST.
-data KeywordId = G AnnKeywordId -- ^ A normal keyword
- | AnnSemiSep -- ^ A separating comma
- | AnnComment Comment
- | AnnString String -- ^ Used to pass information from
- -- Delta to Print when we have to work
- -- out details from the original
- -- SrcSpan.
- deriving (Eq)
-
-instance Show KeywordId where
- show (G gc) = "(G " ++ show gc ++ ")"
- show AnnSemiSep = "AnnSemiSep"
- show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"
- show (AnnString s) = "(AnnString " ++ s ++ ")"
-
-- | Marks the start column of a layout block.
newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }
deriving (Eq, Num)
instance Show LayoutStartCol where
show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"
+
-- ---------------------------------------------------------------------
-- Duplicated here so it can be used in show instances
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index 7b31ffd630..abfe598f26 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -20,10 +20,13 @@ module Utils
where
import Control.Monad.State
import Data.Function
+import Data.Maybe (isJust)
import Data.Ord (comparing)
import GHC.Hs.Dump
import Lookup
+import Orphans (Default())
+import qualified Orphans as Orphans
import GHC hiding (EpaComment)
import qualified GHC
@@ -32,12 +35,8 @@ import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Driver.Ppr
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
-import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceBrief)
-
-import Control.Arrow
-
-import qualified Data.Map as Map
import Data.Data hiding ( Fixity )
import Data.List (sortBy, elemIndex)
@@ -51,29 +50,15 @@ debugEnabledFlag :: Bool
-- debugEnabledFlag = True
debugEnabledFlag = False
--- |Global switch to enable debug tracing in ghc-exactprint Pretty
-debugPEnabledFlag :: Bool
--- debugPEnabledFlag = True
-debugPEnabledFlag = False
-
-- |Provide a version of trace that comes at the end of the line, so it can
-- easily be commented out when debugging different things.
debug :: c -> String -> c
debug c s = if debugEnabledFlag
then trace s c
else c
-
--- |Provide a version of trace for the Pretty module, which can be enabled
--- separately from 'debug' and 'debugM'
-debugP :: String -> c -> c
-debugP s c = if debugPEnabledFlag
- then trace s c
- else c
-
debugM :: Monad m => String -> m ()
debugM s = when debugEnabledFlag $ traceM s
-
-- ---------------------------------------------------------------------
warn :: c -> String -> c
@@ -83,12 +68,12 @@ warn c _ = c
-- | A good delta has no negative values.
isGoodDelta :: DeltaPos -> Bool
isGoodDelta (SameLine co) = co >= 0
-isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0
+isGoodDelta (DifferentLine ro _co) = ro > 0
-- Note: DifferentLine invariant is ro is nonzero and positive
-- | Create a delta from the current position to the start of the given
--- @SrcSpan@.
+-- @RealSrcSpan@.
ss2delta :: Pos -> RealSrcSpan -> DeltaPos
ss2delta ref ss = pos2delta ref (ss2pos ss)
@@ -137,25 +122,15 @@ undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp)
where
(l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0)
- len = length (keywordToString (G kw))
+ len = length (keywordToString kw)
sp = range2rs ((l,c),(l,c+len))
--- | Add together two @DeltaPos@ taking into account newlines
---
--- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3)
--- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5)
--- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3)
-addDP :: DeltaPos -> DeltaPos -> DeltaPos
-addDP dp (DifferentLine c d) = DifferentLine (getDeltaLine dp+c) d
-addDP (DifferentLine a b) (SameLine d) = DifferentLine a (b+d)
-addDP (SameLine b) (SameLine d) = SameLine (b+d)
-
-- ---------------------------------------------------------------------
-adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos
-adjustDeltaForOffset _ _colOffset dp@(SameLine _) = dp
-adjustDeltaForOffset d (LayoutStartCol colOffset) (DifferentLine l c)
- = DifferentLine l (c - colOffset - d)
+adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
+adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
+adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
+ = DifferentLine l (c - colOffset)
-- ---------------------------------------------------------------------
@@ -213,27 +188,23 @@ isListComp = isDoComprehensionContext
-- ---------------------------------------------------------------------
-isGadt :: Foldable f => f (LConDecl (GhcPass p)) -> Bool
-isGadt = any $ \ case
- L _ ConDeclGADT {} -> True
- _ -> False
-
--- ---------------------------------------------------------------------
-
--- Is a RdrName of type Exact? SYB query, so can be extended to other types too
-isExactName :: (Data name) => name -> Bool
-isExactName = False `mkQ` isExact
+needsWhere :: DataDefnCons (LConDecl (GhcPass p)) -> Bool
+needsWhere (NewTypeCon _) = True
+needsWhere (DataTypeCons _ []) = True
+needsWhere (DataTypeCons _ ((L _ (ConDeclGADT{})):_)) = True
+needsWhere _ = False
-- ---------------------------------------------------------------------
insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments (L l p) cs = L l p'
where
- ncs = EpaComments cs
an' = case GHC.hsmodAnn $ GHC.hsmodExt p of
- (EpAnn a an ocs) -> EpAnn a an (ocs <> ncs)
+ (EpAnn a an ocs) -> EpAnn a an (EpaComments cs')
+ where
+ cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs
unused -> unused
- p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } } 
+ p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }
-- ---------------------------------------------------------------------
@@ -245,14 +216,23 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
tokComment :: LEpaComment -> Comment
-tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt
+tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)
+
+mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
+mkEpaComments priorCs []
+ = EpaComments (map comment2LEpaComment priorCs)
+mkEpaComments priorCs postCs
+ = EpaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs)
+
+comment2LEpaComment :: Comment -> LEpaComment
+comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
-mkLEpaComment :: String -> Anchor -> LEpaComment
--- Note: fudging the ac_prior_tok value, hope it does not cause a problem
-mkLEpaComment s anc = (L anc (GHC.EpaComment (EpaLineComment s) (anchor anc)))
+mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
+mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r))
+mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
-mkComment :: String -> Anchor -> Comment
-mkComment c anc = Comment c anc Nothing
+mkComment :: String -> Anchor -> RealSrcSpan -> Comment
+mkComment c anc r = Comment c anc r Nothing
-- Windows comments include \r in them from the lexer.
normaliseCommentText :: String -> String
@@ -260,38 +240,37 @@ normaliseCommentText [] = []
normaliseCommentText ('\r':xs) = normaliseCommentText xs
normaliseCommentText (x:xs) = x:normaliseCommentText xs
+-- |Must compare without span filenames, for CPP injected comments with fake filename
+cmpComments :: Comment -> Comment -> Ordering
+cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+
+-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
+sortComments :: [Comment] -> [Comment]
+sortComments cs = sortBy cmpComments cs
+
+-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
+sortEpaComments :: [LEpaComment] -> [LEpaComment]
+sortEpaComments cs = sortBy cmp cs
+ where
+ cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+
-- | Makes a comment which originates from a specific keyword.
-mkKWComment :: AnnKeywordId -> EpaLocation -> [Comment]
+mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
mkKWComment kw (EpaSpan ss)
- = [Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw)]
-mkKWComment kw (EpaDelta dp cs)
- = (map tokComment cs) ++ [Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw)]
+ = Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw)
+mkKWComment kw (EpaDelta dp _)
+ = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw)
-comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos)
-comment2dp = first AnnComment
+-- | Detects a comment which originates from a specific keyword.
+isKWComment :: Comment -> Bool
+isKWComment c = isJust (commentOrigin c)
+
+noKWComments :: [Comment] -> [Comment]
+noKWComments = filter (\c -> not (isKWComment c))
sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a]
sortAnchorLocated = sortBy (compare `on` (anchor . getLoc))
-getAnnotationEP :: (Data a) => Located a -> Anns -> Maybe Annotation
-getAnnotationEP la as =
- Map.lookup (mkAnnKey la) as
-
--- | The "true entry" is the distance from the last concrete element to the
--- start of the current element.
-annTrueEntryDelta :: Annotation -> DeltaPos
-annTrueEntryDelta Ann{annEntryDelta, annPriorComments} =
- foldr addDP (SameLine 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
- `addDP` annEntryDelta
-
--- | Return the DP of the first item that generates output, either a comment or the entry DP
-annLeadingCommentEntryDelta :: Annotation -> DeltaPos
-annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp
- where
- dp = case annPriorComments of
- [] -> annEntryDelta
- ((_,ed):_) -> ed
-
-- | Calculates the distance from the start of a string to the end of
-- a string.
dpFromString :: String -> DeltaPos
@@ -326,18 +305,18 @@ name2String = showPprUnsafe
-- ---------------------------------------------------------------------
-occAttributes :: OccName.OccName -> String
-occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
- where
- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
- vo = if isVarOcc o then "Var " else ""
- tv = if isTvOcc o then "Tv " else ""
- tc = if isTcOcc o then "Tc " else ""
- d = if isDataOcc o then "Data " else ""
- ds = if isDataSymOcc o then "DataSym " else ""
- s = if isSymOcc o then "Sym " else ""
- v = if isValOcc o then "Val " else ""
+-- occAttributes :: OccName.OccName -> String
+-- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
+-- where
+-- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
+-- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
+-- vo = if isVarOcc o then "Var " else ""
+-- tv = if isTvOcc o then "Tv " else ""
+-- tc = if isTcOcc o then "Tc " else ""
+-- d = if isDataOcc o then "Data " else ""
+-- ds = if isDataSymOcc o then "DataSym " else ""
+-- s = if isSymOcc o then "Sym " else ""
+-- v = if isValOcc o then "Val " else ""
-- ---------------------------------------------------------------------
@@ -345,6 +324,101 @@ locatedAnAnchor :: LocatedAn a t -> RealSrcSpan
locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l
locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a
+-- ---------------------------------------------------------------------
+
+setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
+setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc cs
+ = (L (SrcSpanAnn (EpAnn anc Orphans.def cs) l) a)
+ -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
+setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs
+ = (L (SrcSpanAnn (EpAnn anc an cs) l) a)
+ -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
+
+setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
+setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc Orphans.def cs
+setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs
+
+setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList
+setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc mempty cs
+setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs
+
+setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
+setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }
+ where
+ anc' = anc { anchor_op = UnchangedAnchor }
+ an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' cs
+
+-- |Version of l2l that preserves the anchor, immportant if it has an
+-- updated AnchorOperation
+moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b
+moveAnchor (SrcSpanAnn EpAnnNotUsed l) = noAnnSrcSpan l
+moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l
+
+-- ---------------------------------------------------------------------
+
+trailingAnnLoc :: TrailingAnn -> EpaLocation
+trailingAnnLoc (AddSemiAnn ss) = ss
+trailingAnnLoc (AddCommaAnn ss) = ss
+trailingAnnLoc (AddVbarAnn ss) = ss
+
+setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn
+setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss)
+setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss)
+setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss)
+
+addEpAnnLoc :: AddEpAnn -> EpaLocation
+addEpAnnLoc (AddEpAnn _ l) = l
+
+-- ---------------------------------------------------------------------
+
+-- TODO: move this to GHC
+anchorToEpaLocation :: Anchor -> EpaLocation
+anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r
+anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp []
+
+-- ---------------------------------------------------------------------
+-- Horrible hack for dealing with some things still having a SrcSpan,
+-- not an Anchor.
+
+{-
+A SrcSpan is defined as
+
+data SrcSpan =
+ RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos]
+ | UnhelpfulSpan !UnhelpfulSpanReason
+
+data BufSpan =
+ BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }
+ deriving (Eq, Ord, Show)
+
+newtype BufPos = BufPos { bufPos :: Int }
+
+
+We use the BufPos to encode a delta, using bufSpanStart for the line,
+and bufSpanEnd for the col.
+
+To be absolutely sure, we make the delta versions use -ve values.
+
+-}
+
+hackSrcSpanToAnchor :: SrcSpan -> Anchor
+hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s
+hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = Anchor r UnchangedAnchor
+hackSrcSpanToAnchor (RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e))))
+ = if s <= 0 && e <= 0
+ then Anchor r (MovedAnchor (deltaPos (-s) (-e)))
+ `debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) )
+ else Anchor r UnchangedAnchor
+
+hackAnchorToSrcSpan :: Anchor -> SrcSpan
+hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Strict.Nothing
+hackAnchorToSrcSpan (Anchor r (MovedAnchor dp))
+ = RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e)))
+ `debug` ("hackAnchorToSrcSpan: (r,dp,s,e)=" ++ showAst (r,dp,s,e) )
+ where
+ s = - (getDeltaLine dp)
+ e = - (deltaColumn dp)
+
-- ---------------------------------------------------------------------
showAst :: (Data a) => a -> String
diff --git a/utils/check-exact/check-exact.cabal b/utils/check-exact/check-exact.cabal
index 834a2bc35e..5d7e6c37fc 100644
--- a/utils/check-exact/check-exact.cabal
+++ b/utils/check-exact/check-exact.cabal
@@ -22,6 +22,7 @@ Executable check-exact
Ghc-Options: -Wall
other-modules: ExactPrint
Lookup
+ Orphans
Parsers
Preprocess
Transform
View Lorry Controller Status