GHC Exactprint main commit

Metric Increase:
       T10370
       parsing001

Updates haddock submodule

97 files changed, 9398 insertions, 285 deletions

diff --git a/utils/check-api-annotations/Main.hs b/utils/check-api-annotations/Main.hs
deleted file mode 100644
index 7fd6180182..0000000000
--- a/utils/check-api-annotations/Main.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-
-import Data.Data
-import Data.List
-import GHC
-import GHC.Driver.Ppr
-import GHC.Utils.Outputable
-import GHC.Types.SrcLoc
-import System.Environment( getArgs )
-import System.Exit
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Maybe( isJust )
-
-main::IO()
-main = do
-  args <- getArgs
-  case args of
-   [libdir,fileName] -> testOneFile libdir fileName
-   _ -> putStrLn "invoke with the libdir and a file to parse."
-
-testOneFile :: FilePath -> String -> IO ()
-testOneFile libdir fileName = do
-       let modByFile m =
-             case ml_hs_file $ ms_location m of
-               Nothing -> False
-               Just fn -> fn == fileName
-       (anns,p) <- runGhc (Just libdir) $ do
-                        dflags <- getSessionDynFlags
-                        _ <- setSessionDynFlags dflags
-                        addTarget Target { targetId = TargetFile fileName Nothing
-                                         , targetAllowObjCode = True
-                                         , targetContents = Nothing }
-                        _ <- load LoadAllTargets
-                        graph <- getModuleGraph
-                        let modSum =
-                              case filter modByFile (mgModSummaries graph) of
-                                [x] -> x
-                                xs -> error $ "Can't find module, got:"
-                                  ++ show (map (ml_hs_file . ms_location) xs)
-                        p <- parseModule modSum
-                        return (pm_annotations p,p)
-
-       let sspans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
-
-           ann_items = apiAnnItems anns
-
-           exploded = [((kw,ss),[anchor])
-                      | ((anchor,kw),sss) <- Map.toList ann_items,ss <- sss]
-
-           exploded' = Map.toList $ Map.fromListWith (++) exploded
-
-           problems' = filter (\(_,anchors)
-                               -> not (any (\a -> Set.member a sspans) anchors))
-                              exploded'
-
-           -- Check that every annotation location in 'vs' appears after
-           -- the start of the enclosing span 's'
-           comesBefore ((s,_),vs) = not $ all ok vs
-             where ok v = realSrcSpanStart s <= realSrcSpanStart v
-
-           precedingProblems = filter comesBefore $ Map.toList ann_items
-
-       putStrLn "---Unattached Annotation Problems (should be empty list)---"
-       putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems'])
-       putStrLn "---Ann before enclosing span problem (should be empty list)---"
-       putStrLn (showAnnsList precedingProblems)
-       putStrLn "---Annotations-----------------------"
-       putStrLn "-- SrcSpan the annotation is attached to, AnnKeywordId,"
-       putStrLn "--    list of locations the keyword item appears in"
-       -- putStrLn (intercalate "\n" [showAnns ann_items])
-       putStrLn (showAnns ann_items)
-       putStrLn "---Eof Position (should be Just)-----"
-       putStrLn (show (apiAnnEofPos anns))
-       if null problems' && null precedingProblems && isJust (apiAnnEofPos anns)
-          then exitSuccess
-          else exitFailure
-
-    where
-      getAllSrcSpans :: (Data t) => t -> [RealSrcSpan]
-      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
-        where
-          getSrcSpan :: SrcSpan -> [RealSrcSpan]
-          getSrcSpan (RealSrcSpan ss _) = [ss]
-          getSrcSpan (UnhelpfulSpan _) = []
-
-
-showAnns :: Map.Map ApiAnnKey [RealSrcSpan] -> String
-showAnns anns = showAnnsList $ Map.toList anns
-
-showAnnsList :: [(ApiAnnKey, [RealSrcSpan])] -> String
-showAnnsList annsList = "[\n" ++ (intercalate ",\n"
-   $ map (\((s,k),v)
-              -> ("((" ++ pp s ++ "," ++ show k ++"), " ++ pp v ++ ")"))
-   annsList)
-    ++ "\n]\n"
-
-pp :: (Outputable a) => a -> String
-pp a = showPprUnsafe a
-
-
--- ---------------------------------------------------------------------
-
--- Copied from syb for the test
-
-
--- | Generic queries of type \"r\",
---   i.e., take any \"a\" and return an \"r\"
---
-type GenericQ r = forall a. Data a => a -> r
-
-
--- | Make a generic query;
---   start from a type-specific case;
---   return a constant otherwise
---
-mkQ :: ( Typeable a
-       , Typeable b
-       )
-    => r
-    -> (b -> r)
-    -> a
-    -> r
-(r `mkQ` br) a = case cast a of
-                        Just b  -> br b
-                        Nothing -> r
-
-
-
--- | Summarise all nodes in top-down, left-to-right order
-everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
-
--- Apply f to x to summarise top-level node;
--- use gmapQ to recurse into immediate subterms;
--- use ordinary foldl to reduce list of intermediate results
-
-everything k f x = foldl k (f x) (gmapQ (everything k f) x)
diff --git a/utils/check-api-annotations/README b/utils/check-api-annotations/README
deleted file mode 100644
index 5d852a30bf..0000000000
--- a/utils/check-api-annotations/README
+++ /dev/null
@@ -1,103 +0,0 @@
-This programme is intended to be used by any GHC developers working on GHC.Parser
-or GHC.Parser.PostProcess, and who want to check that their changes do not break the API
-Annotations.
-
-It does a basic test that all annotations do make it to the final AST, and dumps
-a list of the annotations generated for a given file, so that they can be
-checked against the source being parsed for sanity.
-
-This utility is also intended to be used in tests, so that when new features are
-added the expected annotations are also captured.
-
-Usage
-
-In a test Makefile
-
-  $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs
-
-See examples in (REPO_HOME)/testsuite/tests/ghc-api/annotations/Makefile
-
-
-Description of operation
-------------------------
-
-The programme is called with the name of a haskell source file.
-
-It uses the GHC API to load and parse this, and extracts the API annotations.
-
-These are of the form
-
-    Map.Map ApiAnnKey [SrcSpan]
-
-where
-
-    type ApiAnnKey = (SrcSpan,AnnKeywordId)
-
-So an annotation is a key comprising the parent SrcSpan in the ParsedSource
-together with an AnnKeywordId, and this maps to a list of locations where the
-specific keyword item occurs in the original source.
-
-The utility extracts all SrcSpans in the ParsedSource, and makes sure that for
-every ApiAnnKey the SrcSpan is actually present in the final ParsedSource. This
-is to ensure that when a given parser production is postprocessed anywhere along
-the line the relevant SrcSpan is not discarded, thus detaching the annotation
-from the final output.
-
-It also provides a list of each ApiAnnKey and the corresponding source
-locations, so these can be checked against the original source for correctness.
-
-Example
--------
-
-Test10255.hs in the ghc-api/annotations tests has the following source
-
-------------------------------
-1:{-# LANGUAGE ScopedTypeVariables #-}
-2:module Test10255 where
-3:
-4:import Data.Maybe
-5:
-6:fob (f :: (Maybe t -> Int)) =
-7:  undefined
-------------------------------
-
-The output of this utility is
-
-------------------------------------------------------------------------
----Problems (should be empty list)---
-[]
----Annotations-----------------------
--- SrcSpan the annotation is attached to, AnnKeywordId,
---    list of locations the keyword item appears in
-[
-((Test10255.hs:1:1,AnnModule), [Test10255.hs:2:1-6]),
-((Test10255.hs:1:1,AnnWhere), [Test10255.hs:2:18-22]),
-((Test10255.hs:4:1-17,AnnImport), [Test10255.hs:4:1-6]),
-((Test10255.hs:4:1-17,AnnSemi), [Test10255.hs:6:1]),
-((Test10255.hs:(6,1)-(7,11),AnnEqual), [Test10255.hs:6:29]),
-((Test10255.hs:(6,1)-(7,11),AnnFunId), [Test10255.hs:6:1-3]),
-((Test10255.hs:(6,1)-(7,11),AnnSemi), [Test10255.hs:8:1]),
-((Test10255.hs:6:5-27,AnnCloseP), [Test10255.hs:6:27]),
-((Test10255.hs:6:5-27,AnnOpenP), [Test10255.hs:6:5]),
-((Test10255.hs:6:6-26,AnnDcolon), [Test10255.hs:6:8-9]),
-((Test10255.hs:6:11-26,AnnCloseP), [Test10255.hs:6:26]),
-((Test10255.hs:6:11-26,AnnOpenP), [Test10255.hs:6:11]),
-((Test10255.hs:6:12-18,AnnRarrow), [Test10255.hs:6:20-21]),
-((Test10255.hs:6:12-25,AnnRarrow), [Test10255.hs:6:20-21]),
-((<no location info>,AnnEofPos), [Test10255.hs:8:1])
-]
-------------------------------------------------------------------------
-
-To interpret this, firstly the problems list is empty, so there are not
-annotations that do not appear in the final AST.
-
-Secondly, the list of annotations and locations can be checked against the test
-source code to ensure that every AnnKeywordId does in fact appear.
-
-It will return a zero exit code if the list of problems is empty, non-zero
-otherwise.
-
-Note: In some cases, such as T10269 in the ghc-api/annotations tests the list is
-non-empty, due to postprocessing of the parsed result. In general this should
-only happen for an `AnnVal` and if it does the actual annotations provided need
-to be inspected to check that an equivalent annotation is provided.
diff --git a/utils/check-api-annotations/check-api-annotations.cabal b/utils/check-api-annotations/check-api-annotations.cabal
deleted file mode 100644
index dbaa25fd48..0000000000
--- a/utils/check-api-annotations/check-api-annotations.cabal
+++ /dev/null
@@ -1,29 +0,0 @@
-Name: check-api-annotations
-Version: 0.1
-Copyright: XXX
-License: BSD3
--- XXX License-File: LICENSE
-Author: XXX
-Maintainer: XXX
-Synopsis: A utilities for checking the consistency of GHC's API annotations.
-Description:
-    This utility is used to check the consistency between GHC's syntax tree
-    and API annotations used to track token-level details of the original
-    source file. See @utils/check-api-annotations/README@ in GHC's source
-    distribution for details.
-Category: Development
-build-type: Simple
-cabal-version: >=1.10
-
-Executable check-api-annotations
-    Default-Language: Haskell2010
-
-    Main-Is: Main.hs
-
-    Ghc-Options: -Wall
-
-    Build-Depends: base       >= 4   && < 5,
-                   containers,
-                   Cabal      >= 3.2 && < 3.6,
-                   directory,
-                   ghc
diff --git a/utils/check-exact/.ghci b/utils/check-exact/.ghci
new file mode 100644
index 0000000000..43ff67a50e
--- /dev/null
+++ b/utils/check-exact/.ghci
@@ -0,0 +1,3 @@
+:set -package ghc
+:set -i./src
+:set -Wall
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
new file mode 100644
index 0000000000..8f4f89e265
--- /dev/null
+++ b/utils/check-exact/ExactPrint.hs
@@ -0,0 +1,4165 @@
+{-# LANGUAGE DeriveDataTypeable   #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiWayIf           #-}
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns         #-}
+
+module ExactPrint
+  (
+    ExactPrint(..)
+  , exactPrint
+  -- , exactPrintWithOptions
+  ) where
+
+import GHC
+import GHC.Core.Coercion.Axiom (Role(..))
+import GHC.Data.Bag
+import qualified GHC.Data.BooleanFormula as BF
+import GHC.Data.FastString
+import GHC.Types.Basic hiding (EP)
+import GHC.Types.Fixity
+import GHC.Types.ForeignCall
+import GHC.Types.SourceText
+import GHC.Utils.Outputable hiding ( (<>) )
+import GHC.Driver.Ppr
+import GHC.Unit.Module.Warnings
+import GHC.Utils.Misc
+import GHC.Utils.Panic
+
+import Control.Monad.Identity
+import Control.Monad.RWS
+import Data.Data ( Data )
+import Data.Foldable
+import Data.Typeable
+import Data.List ( partition, sort, sortBy)
+import Data.Maybe ( isJust )
+
+import Data.Void
+
+import Lookup
+import Utils
+import Types
+
+-- import Debug.Trace
+
+-- ---------------------------------------------------------------------
+
+exactPrint :: ExactPrint ast => Located ast -> ApiAnns -> String
+exactPrint ast anns = runIdentity (runEP anns stringOptions (markAnnotated ast))
+
+type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a
+type EPP a = EP String Identity a
+
+runEP :: ApiAnns -> PrintOptions Identity String
+      -> Annotated () -> Identity String
+runEP anns epReader action =
+  fmap (output . snd) .
+    (\next -> execRWST next epReader (defaultEPState anns))
+    . xx $ action
+
+xx :: Annotated () -> EP String Identity ()
+-- xx :: Annotated() -> RWST (PrintOptions m w) (EPWriter w) EPState m ()
+xx = id
+
+-- ---------------------------------------------------------------------
+
+defaultEPState :: ApiAnns -> EPState
+defaultEPState as = EPState
+             { epPos       = (1,1)
+             , epApiAnns   = as
+             , dLHS       = 1
+             , pMarkLayout = False
+             , pLHS = 1
+             , dMarkLayout = False
+             , dPriorEndPosition = (1,1)
+             , uAnchorSpan = badRealSrcSpan
+             , uExtraDP = Nothing
+             , epComments = rogueComments as
+             }
+
+
+-- ---------------------------------------------------------------------
+-- The EP monad and basic combinators
+
+-- | 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
+            {
+              epAnn :: !Annotation
+            , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a
+            , epTokenPrint :: String -> m a
+            , epWhitespacePrint :: String -> m a
+            , epRigidity :: Rigidity
+            , epContext :: !AstContextSet
+            }
+
+-- | Helper to create a 'PrintOptions'
+printOptions ::
+      (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
+             {
+               epAnn = annNone
+             , epAstPrint = astPrint
+             , epWhitespacePrint = wsPrint
+             , epTokenPrint = tokenPrint
+             , epRigidity = rigidity
+             , epContext = defaultACS
+             }
+
+-- | Options which can be used to print as a normal String.
+stringOptions :: PrintOptions Identity String
+stringOptions = printOptions (\_ b -> return b) return return NormalLayout
+
+data EPWriter a = EPWriter
+              { output :: !a }
+
+instance Monoid w => Semigroup (EPWriter w) where
+  (EPWriter a) <> (EPWriter b) = EPWriter (a <> b)
+
+instance Monoid w => Monoid (EPWriter w) where
+  mempty = EPWriter mempty
+
+data EPState = EPState
+             { epApiAnns    :: !ApiAnns
+
+             , uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST
+                                          -- reference frame, from
+                                          -- Annotation
+             , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a
+                                             -- list
+
+             -- Print phase
+             , epPos        :: !Pos -- ^ Current output position
+             , pMarkLayout  :: !Bool
+             , pLHS   :: !LayoutStartCol
+
+             -- Delta phase
+             , dPriorEndPosition :: !Pos -- ^ End of Position reached
+                                         -- when processing the
+                                         -- preceding element
+             , dMarkLayout :: !Bool
+             , dLHS        :: !LayoutStartCol
+
+             -- Shared
+             , epComments :: ![Comment]
+             }
+
+-- ---------------------------------------------------------------------
+
+-- AZ:TODO: this can just be a function :: (ApiAnn' a) -> Entry
+class HasEntry ast where
+  fromAnn :: ast -> Entry
+
+-- ---------------------------------------------------------------------
+
+-- 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 a = enterAnn (getAnnotationEntry a) a
+
+data Entry = Entry Anchor ApiAnnComments
+           | NoEntryVal
+
+instance (HasEntry (ApiAnn' an)) =>  HasEntry (SrcSpanAnn' (ApiAnn' an)) where
+  fromAnn (SrcSpanAnn ApiAnnNotUsed ss) = Entry (spanAsAnchor ss) noCom
+  fromAnn (SrcSpanAnn an _) = fromAnn an
+
+instance HasEntry (ApiAnn' a) where
+  fromAnn (ApiAnn anchor _ cs) = Entry anchor cs
+  fromAnn ApiAnnNotUsed = NoEntryVal
+
+-- ---------------------------------------------------------------------
+
+astId :: (Typeable a) => a -> String
+astId a = show (typeOf a)
+
+-- | "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 NoEntryVal a = do
+  p <- getPosP
+  debugM $ "enterAnn:NO ANN:(p,a) =" ++ show (p, astId a) ++ " starting"
+  -- curAnchor <- getAnchorU
+  -- printComments curAnchor
+  exact a
+  debugM $ "enterAnn:NO ANN:p =" ++ show (p, astId a) ++ " done"
+enterAnn (Entry anchor' cs) a = do
+  p <- getPosP
+  debugM $ "enterAnn:(p,a) =" ++ show (p, astId a) ++ " starting"
+  let curAnchor = anchor anchor' -- As a base for the current AST element
+  debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)
+  addCommentsA (priorComments cs)
+  printComments curAnchor
+  -- -------------------------
+  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
+  -- -------------------------------------------------------------------
+  -- The first part corresponds to the delta phase, so should only use
+  -- delta phase variables
+  -- -----------------------------------
+  -- Calculate offset required to get to the start of the SrcSPan
+  off <- gets dLHS
+  let spanStart = ss2pos curAnchor
+  priorEndAfterComments <- getPriorEndD
+  let edp' = adjustDeltaForOffset 0
+               -- Use the propagated offset if one is set
+               -- Note that we need to use the new offset if it has
+               -- changed.
+               off (ss2delta priorEndAfterComments curAnchor)
+  debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor)
+  let edp'' = case anchor_op anchor' of
+        MovedAnchor dp -> dp
+        _ -> edp'
+  -- ---------------------------------------------
+  -- let edp = edp''
+  med <- getExtraDP
+  setExtraDP Nothing
+  let edp = case med of
+        Nothing -> edp''
+        -- Just dp -> addDP dp edp''
+        Just (Anchor _ (MovedAnchor dp)) -> dp
+                   -- Replace original with desired one. Allows all
+                   -- list entry values to be DP (1,0)
+        Just (Anchor r _) -> dp
+          where
+            dp = adjustDeltaForOffset 0
+                   off (ss2delta priorEndAfterComments r)
+  when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp)
+  -- ---------------------------------------------
+  -- Preparation complete, perform the action
+  when (priorEndAfterComments < spanStart) (do
+    debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart
+    modify (\s -> s { dPriorEndPosition    = spanStart } ))
+
+  debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor)
+  debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)
+
+  -- end of delta phase processing
+  -- -------------------------------------------------------------------
+  -- start of print phase processing
+
+  let
+    st = annNone { annEntryDelta = edp }
+  withOffset st (advance edp >> exact a)
+
+  when ((getFollowingComments cs) /= []) $ do
+    debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
+    mapM_ printOneComment (map tokComment $ getFollowingComments cs)
+    debugM $ "ending trailing comments"
+
+-- ---------------------------------------------------------------------
+
+addCommentsA :: [LAnnotationComment] -> EPP ()
+addCommentsA csNew = addComments (map tokComment csNew)
+  -- cs <- getUnallocatedComments
+  -- -- AZ:TODO: sortedlist?
+  -- putUnallocatedComments (sort $ (map tokComment csNew) ++ cs)
+
+addComments :: [Comment] -> EPP ()
+addComments csNew = do
+  debugM $ "addComments:" ++ show csNew
+  cs <- getUnallocatedComments
+  let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (anchor l1) (anchor l2)
+  -- AZ:TODO: sortedlist?
+  putUnallocatedComments (sortBy cmp $ csNew ++ cs)
+
+-- ---------------------------------------------------------------------
+
+-- |In order to interleave annotations into the stream, we turn them into
+-- comments.
+annotationsToComments :: [AddApiAnn] -> [AnnKeywordId] -> EPP ()
+annotationsToComments ans kws = do
+  let
+    getSpans _ [] = []
+    getSpans k1 (AddApiAnn 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 $ map (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)
+
+
+-- ---------------------------------------------------------------------
+
+-- Temporary function to simply reproduce the "normal" pretty printer output
+withPpr :: (Outputable a) => a -> Annotated ()
+withPpr a = do
+  ss <- getAnchorU
+  debugM $ "withPpr: ss=" ++ show ss
+  printStringAtKw' ss (showPprUnsafe 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
+-- to be able to use the rest of the exactprint machinery to print the
+-- element.  In the analogy to Outputable, 'exact' plays the role of
+-- 'ppr'.
+class (Typeable a) => ExactPrint a where
+  getAnnotationEntry :: a -> Entry
+  exact :: a -> Annotated ()
+
+-- ---------------------------------------------------------------------
+
+-- | Bare Located elements are simply stripped off without further
+-- processing.
+instance (ExactPrint a) => ExactPrint (Located a) where
+  getAnnotationEntry (L l _) = Entry (spanAsAnchor l) noCom
+  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)
+
+instance (ExactPrint a) => ExactPrint [a] where
+  getAnnotationEntry = const NoEntryVal
+  exact ls = mapM_ markAnnotated ls
+
+instance (ExactPrint a) => ExactPrint (Maybe a) where
+  getAnnotationEntry = const NoEntryVal
+  exact Nothing = return ()
+  exact (Just a) = markAnnotated a
+
+-- ---------------------------------------------------------------------
+
+-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'
+instance ExactPrint HsModule where
+  getAnnotationEntry hsmod = fromAnn (hsmodAnn hsmod)
+
+  exact hsmod@(HsModule ApiAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod
+  exact (HsModule an _lo mmn mexports imports decls mdeprec mbDoc) = do
+
+    markAnnotated mbDoc
+
+    case mmn of
+      Nothing -> return ()
+      Just (L ln mn) -> do
+        markApiAnn' an am_main AnnModule
+        -- debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln))
+        -- printStringAtSs ln (moduleNameString mn)
+        markAnnotated (L ln mn)
+
+        -- forM_ mdeprec markLocated
+        setLayoutTopLevelP $ markAnnotated mdeprec
+
+        setLayoutTopLevelP $ markAnnotated mexports
+
+        debugM $ "HsModule.AnnWhere coming"
+        setLayoutTopLevelP $ markApiAnn' an am_main AnnWhere
+
+    setLayoutTopLevelP $ mapM_ markAddApiAnn (al_open $ am_decls $ anns an)
+
+    -- markOptional GHC.AnnOpenC -- Possible '{'
+    -- markManyOptional GHC.AnnSemi -- possible leading semis
+    -- setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imports
+    -- markListWithLayout imports
+    markTopLevelList imports
+
+    -- setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decls
+    -- markListWithLayout decls
+    -- setLayoutTopLevelP $ markAnnotated decls
+    markTopLevelList decls
+
+    setLayoutTopLevelP $ mapM_ markAddApiAnn (al_close $ am_decls $ anns an)
+    -- markOptional GHC.AnnCloseC -- Possible '}'
+
+    -- markEOF
+    -- eof <- getEofPos
+    -- debugM $ "eof pos:" ++ show (rs2range eof)
+    -- setLayoutTopLevelP $ printStringAtKw' eof ""
+
+-- ---------------------------------------------------------------------
+
+-- 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)
+
+instance (ExactPrint a) => ExactPrint (AnnotatedList a) where
+  getAnnotationEntry (AnnotatedList (Just anc) _) = Entry anc (AnnComments [])
+  getAnnotationEntry (AnnotatedList Nothing    _) = NoEntryVal
+
+  exact (AnnotatedList an ls) = do
+    debugM $ "AnnotatedList:an=" ++ show an
+    markAnnotatedWithLayout ls
+
+
+-- ---------------------------------------------------------------------
+-- Start of utility functions
+-- ---------------------------------------------------------------------
+
+printSourceText :: SourceText -> String -> EPP ()
+printSourceText NoSourceText txt   =  printStringAdvance txt
+printSourceText (SourceText txt) _ =  printStringAdvance txt
+
+-- ---------------------------------------------------------------------
+
+printStringAtRs :: RealSrcSpan -> String -> EPP ()
+printStringAtRs ss str = printStringAtKw' ss str
+
+printStringAtSs :: SrcSpan -> String -> EPP ()
+printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str
+
+-- ---------------------------------------------------------------------
+
+-- AZ:TODO get rid of this
+printStringAtMkw :: Maybe AnnAnchor -> String -> EPP ()
+printStringAtMkw (Just aa) s = printStringAtAA aa s
+printStringAtMkw Nothing s = printStringAtLsDelta (DP 0 1) s
+
+
+printStringAtAA :: AnnAnchor -> String -> EPP ()
+printStringAtAA (AR r) s = printStringAtKw' r s
+printStringAtAA (AD d) s = do
+  pe <- getPriorEndD
+  p1 <- getPosP
+  printStringAtLsDelta d s
+  p2 <- getPosP
+  debugM $ "printStringAtAA:(pe,p1,p2)=" ++ show (pe,p1,p2)
+  setPriorEndASTPD True (p1,p2)
+
+-- 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
+
+-- ---------------------------------------------------------------------
+
+markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP ()
+markExternalSourceText l NoSourceText txt   = printStringAtKw' (realSrcSpan l) txt
+markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) txt
+
+-- ---------------------------------------------------------------------
+
+markAddApiAnn :: AddApiAnn -> EPP ()
+markAddApiAnn a@(AddApiAnn kw _) = mark [a] kw
+
+markLocatedMAA :: ApiAnn' a -> (a -> Maybe AddApiAnn) -> EPP ()
+markLocatedMAA ApiAnnNotUsed  _  = return ()
+markLocatedMAA (ApiAnn _ a _) f =
+  case f a of
+    Nothing -> return ()
+    Just aa -> markAddApiAnn aa
+
+markLocatedAA :: ApiAnn' a -> (a -> AddApiAnn) -> EPP ()
+markLocatedAA ApiAnnNotUsed  _  = return ()
+markLocatedAA (ApiAnn _ a _) f = markKw (f a)
+
+markLocatedAAL :: ApiAnn' a -> (a -> [AddApiAnn]) -> AnnKeywordId -> EPP ()
+markLocatedAAL ApiAnnNotUsed  _ _ = return ()
+markLocatedAAL (ApiAnn _ a _) f kw = go (f a)
+  where
+    go [] = return ()
+    go (aa@(AddApiAnn kw' _):as)
+      | kw' == kw = mark [aa] kw
+      | otherwise = go as
+
+markLocatedAALS :: ApiAnn' a -> (a -> [AddApiAnn]) -> AnnKeywordId -> Maybe String -> EPP ()
+markLocatedAALS an f kw Nothing = markLocatedAAL an f kw
+markLocatedAALS ApiAnnNotUsed  _ _ _ = return ()
+markLocatedAALS (ApiAnn _ a _) f kw (Just str) = go (f a)
+  where
+    go [] = return ()
+    go (AddApiAnn kw' r:as)
+      | kw' == kw = printStringAtAA r str
+      | otherwise = go as
+
+-- ---------------------------------------------------------------------
+
+markArrow :: ApiAnn' TrailingAnn -> HsArrow GhcPs -> EPP ()
+markArrow ApiAnnNotUsed _ = pure ()
+markArrow an _mult = markKwT (anns an)
+
+-- ---------------------------------------------------------------------
+
+markAnnCloseP :: ApiAnn' AnnPragma -> EPP ()
+markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}")
+
+markAnnOpenP :: ApiAnn' 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)
+
+markAnnOpen :: ApiAnn -> SourceText -> String -> EPP ()
+markAnnOpen an NoSourceText txt   = markLocatedAALS an id AnnOpen (Just txt)
+markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt)
+
+markAnnOpen' :: Maybe AnnAnchor -> SourceText -> String -> EPP ()
+markAnnOpen' ms NoSourceText txt   = printStringAtMkw ms txt
+markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt
+
+-- ---------------------------------------------------------------------
+
+markOpeningParen, markClosingParen :: ApiAnn' AnnParen -> EPP ()
+markOpeningParen an = markParen an fst
+markClosingParen an = markParen an snd
+
+markParen :: ApiAnn' AnnParen -> (forall a. (a,a) -> a) -> EPP ()
+markParen ApiAnnNotUsed _ = return ()
+markParen (ApiAnn _ (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)
+
+
+markAnnKw :: ApiAnn' a -> (a -> AnnAnchor) -> AnnKeywordId -> EPP ()
+markAnnKw ApiAnnNotUsed  _ _  = return ()
+markAnnKw (ApiAnn _ a _) f kw = markKwA kw (f a)
+
+markAnnKwAll :: ApiAnn' a -> (a -> [AnnAnchor]) -> AnnKeywordId -> EPP ()
+markAnnKwAll ApiAnnNotUsed  _ _  = return ()
+markAnnKwAll (ApiAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a))
+
+markAnnKwM :: ApiAnn' a -> (a -> Maybe AnnAnchor) -> AnnKeywordId -> EPP ()
+markAnnKwM ApiAnnNotUsed  _ _ = return ()
+markAnnKwM (ApiAnn _ a _) f kw = go (f a)
+  where
+    go Nothing = return ()
+    go (Just s) = markKwA kw s
+
+markALocatedA :: ApiAnn' AnnListItem -> EPP ()
+markALocatedA ApiAnnNotUsed  = return ()
+markALocatedA (ApiAnn _ a _) = markTrailing (lann_trailing a)
+
+markApiAnn :: ApiAnn -> AnnKeywordId -> EPP ()
+markApiAnn ApiAnnNotUsed _ = return ()
+markApiAnn (ApiAnn _ a _) kw = mark a kw
+
+markApiAnn' :: ApiAnn' ann -> (ann -> [AddApiAnn]) -> AnnKeywordId -> EPP ()
+markApiAnn' ApiAnnNotUsed _ _ = return ()
+markApiAnn' (ApiAnn _ a _) f kw = mark (f a) kw
+
+markApiAnnAll :: ApiAnn' ann -> (ann -> [AddApiAnn]) -> AnnKeywordId -> EPP ()
+markApiAnnAll ApiAnnNotUsed _ _ = return ()
+markApiAnnAll (ApiAnn _ a _) f kw = mapM_ markKw (sort anns)
+  where
+    anns = filter (\(AddApiAnn ka _) -> ka == kw) (f a)
+
+mark :: [AddApiAnn] -> AnnKeywordId -> EPP ()
+mark anns kw = do
+  case find (\(AddApiAnn k _) -> k == kw) anns of
+    Just aa -> markKw aa
+    Nothing -> case find (\(AddApiAnn k _) -> k == (unicodeAnn kw)) anns of
+      Just aau -> markKw aau
+      Nothing -> return ()
+
+markKwT :: TrailingAnn -> EPP ()
+markKwT (AddSemiAnn ss)    = markKwA AnnSemi ss
+markKwT (AddCommaAnn ss)   = markKwA AnnComma ss
+markKwT (AddVbarAnn ss)    = markKwA AnnVbar ss
+markKwT (AddRarrowAnn ss)  = markKwA AnnRarrow ss
+markKwT (AddRarrowAnnU ss) = markKwA AnnRarrowU ss
+-- markKwT (AddLollyAnn ss)   = markKwA AnnLolly ss
+-- markKwT (AddLollyAnnU ss)  = markKwA AnnLollyU ss
+
+markKw :: AddApiAnn -> EPP ()
+markKw (AddApiAnn kw ss) = markKwA kw ss
+
+-- | This should be the main driver of the process, managing comments
+markKwA :: AnnKeywordId -> AnnAnchor -> EPP ()
+markKwA kw aa = printStringAtAA aa (keywordToString (G kw))
+
+-- ---------------------------------------------------------------------
+
+markAnnList :: ApiAnn' AnnList -> EPP () -> EPP ()
+markAnnList ApiAnnNotUsed action = action
+markAnnList an@(ApiAnn _ ann _) action = do
+  p <- getPosP
+  debugM $ "markAnnList : " ++ showPprUnsafe (p, an)
+  markLocatedMAA an al_open
+  action
+  markLocatedMAA an al_close
+  debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann)
+  markTrailing (al_trailing ann)
+
+-- ---------------------------------------------------------------------
+
+-- printTrailingComments :: EPP ()
+-- printTrailingComments = do
+--   cs <- getUnallocatedComments
+--   mapM_ printOneComment cs
+
+-- ---------------------------------------------------------------------
+
+printComments :: RealSrcSpan -> EPP ()
+printComments ss = do
+  cs <- commentAllocation 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
+  debugM $ "printOneComment:c=" ++ showGhc c
+  dp <-case anchor_op loc of
+    MovedAnchor dp -> return dp
+    _ -> 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
+  mep <- getExtraDP
+  dp' <- case mep of
+    Nothing -> return dp''
+    Just (Anchor _ (MovedAnchor edp)) -> do
+      -- setExtraDP Nothing
+      debugM $ "printOneComment:edp=" ++ show edp
+      return edp
+    Just (Anchor r _) -> do
+        pe <- getPriorEndD
+        let dp' = ss2delta pe r
+        debugM $ "printOneComment:extraDP(dp,pe,anchor loc)=" ++ showGhc (dp',pe,ss2pos r)
+        return dp
+  LayoutStartCol dOff <- gets dLHS
+  debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff)
+  setPriorEndD (ss2posEnd (anchor loc))
+  printQueuedComment (anchor loc) c dp'
+
+-- ---------------------------------------------------------------------
+
+commentAllocation :: RealSrcSpan -> EPP [Comment]
+commentAllocation ss = do
+  cs <- getUnallocatedComments
+  let (earlier,later) = partition (\(Comment _str loc _mo) -> anchor loc <= ss) cs
+  putUnallocatedComments later
+  -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
+  return earlier
+
+-- ---------------------------------------------------------------------
+
+
+markAnnotatedWithLayout :: ExactPrint ast => ast -> EPP ()
+markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a
+
+-- ---------------------------------------------------------------------
+
+markTopLevelList :: ExactPrint ast => [ast] -> EPP ()
+markTopLevelList ls = mapM_ (\a -> setLayoutTopLevelP $ markAnnotated a) ls
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint ModuleName where
+  getAnnotationEntry _ = NoEntryVal
+  exact n = do
+    debugM $ "ModuleName: " ++ showPprUnsafe n
+    withPpr n
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (LocatedP WarningTxt) 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
+
+  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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (ImportDecl GhcPs) where
+  getAnnotationEntry idecl = fromAnn (ideclExt idecl)
+  exact x@(ImportDecl ApiAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x
+  exact (ImportDecl ann@(ApiAnn _ an _) msrc (L lm modname) mpkg _src safeflag qualFlag _impl mAs hiding) = do
+
+    markAnnKw ann importDeclAnnImport AnnImport
+
+    -- "{-# 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
+     Just (StringLiteral src v _) ->
+       printStringAtMkw (importDeclAnnPackage an) (sourceTextToString src (show v))
+     _ -> return ()
+
+    printStringAtKw' (realSrcSpan lm) (moduleNameString modname)
+
+    case qualFlag of
+      QualifiedPost  -- 'qualified' appears in postpositive position.
+        -> printStringAtMkw (importDeclAnnQualified an) "qualified"
+      _ -> return ()
+
+    case mAs of
+      Nothing -> return ()
+      Just (L l mn) -> do
+        printStringAtMkw (importDeclAnnAs an) "as"
+        printStringAtKw' (realSrcSpan l) (moduleNameString mn)
+
+    case hiding of
+      Nothing -> return ()
+      Just (_isHiding,lie) -> exact lie
+ --   markTrailingSemi
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint HsDocString where
+  getAnnotationEntry _ = NoEntryVal
+  exact = withPpr -- TODO:AZ use annotations
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsDecl GhcPs) where
+  getAnnotationEntry (TyClD      _ _) = NoEntryVal
+  getAnnotationEntry (InstD      _ _) = NoEntryVal
+  getAnnotationEntry (DerivD     _ _) = NoEntryVal
+  getAnnotationEntry (ValD       _ _) = NoEntryVal
+  getAnnotationEntry (SigD       _ _) = NoEntryVal
+  getAnnotationEntry (KindSigD   _ _) = NoEntryVal
+  getAnnotationEntry (DefD       _ _) = NoEntryVal
+  getAnnotationEntry (ForD       _ _) = NoEntryVal
+  getAnnotationEntry (WarningD   _ _) = NoEntryVal
+  getAnnotationEntry (AnnD       _ _) = NoEntryVal
+  getAnnotationEntry (RuleD      _ _) = NoEntryVal
+  getAnnotationEntry (SpliceD    _ _) = NoEntryVal
+  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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (InstDecl GhcPs) where
+  getAnnotationEntry (ClsInstD     _  _) = NoEntryVal
+  getAnnotationEntry (DataFamInstD an _) = fromAnn an
+  getAnnotationEntry (TyFamInstD   _  _) = NoEntryVal
+
+-- instance Annotate (GHC.InstDecl GHC.GhcPs) where
+
+--   markAST l (GHC.ClsInstD     _  cid) = markAST l  cid
+--   markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid
+--   markAST l (GHC.TyFamInstD   _ tfid) = markAST l tfid
+--   markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showPprUnsafe x
+
+  exact (ClsInstD     _  cid) = markAnnotated cid
+  exact (DataFamInstD an decl) = do
+    exactDataFamInstDecl an TopLevel decl
+  exact (TyFamInstD _ eqn) = do
+    -- exactTyFamInstDecl an TopLevel eqn
+    markAnnotated eqn
+
+-- ---------------------------------------------------------------------
+
+exactDataFamInstDecl :: ApiAnn -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP ()
+exactDataFamInstDecl an top_lvl
+  (DataFamInstDecl ( FamEqn { feqn_tycon  = tycon
+                            , feqn_bndrs  = bndrs
+                            , feqn_pats   = pats
+                            , feqn_fixity = fixity
+                            , feqn_rhs    = defn }))
+  = exactDataDefn an pp_hdr defn
+  where
+    pp_hdr mctxt = do
+      case top_lvl of
+        TopLevel -> markApiAnn an AnnInstance -- TODO: maybe in toplevel
+        NotTopLevel -> return ()
+      exactHsFamInstLHS an tycon bndrs pats fixity mctxt
+
+-- ---------------------------------------------------------------------
+
+exactTyFamInstDecl :: TopLevelFlag -> (TyFamInstDecl GhcPs) -> EPP ()
+exactTyFamInstDecl top_lvl (TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do
+  markApiAnn an AnnType
+  case top_lvl of
+    TopLevel -> markApiAnn an AnnInstance
+    NotTopLevel -> return ()
+  markAnnotated eqn
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (DerivDecl GhcPs) where
+  getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an
+  exact (DerivDecl an typ ms mov) = do
+    markApiAnn an AnnDeriving
+    mapM_ markAnnotated ms
+    markApiAnn 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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (ForeignDecl GhcPs) where
+  getAnnotationEntry (ForeignImport an _ _  _) = fromAnn an
+  getAnnotationEntry (ForeignExport an _ _  _) = fromAnn an
+
+  exact (ForeignImport an n ty fimport) = do
+    markApiAnn an AnnForeign
+    markApiAnn an AnnImport
+
+    markAnnotated fimport
+
+    markAnnotated n
+    markApiAnn an AnnDcolon
+    markAnnotated ty
+  exact x = error $ "ForDecl: exact for " ++ showAst x
+{-
+  markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ)
+               (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do
+    mark GHC.AnnForeign
+    mark GHC.AnnImport
+
+    markLocated cconv
+    unless (ll == GHC.noSrcSpan) $ markLocated safety
+    markExternalSourceText ls src ""
+
+    markLocated ln
+    mark GHC.AnnDcolon
+    markLocated typ
+    markTrailingSemi
+
+-}
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint ForeignImport where
+  getAnnotationEntry = const NoEntryVal
+  exact (CImport cconv safety@(L ll _) _mh _imp (L ls src)) = do
+    markAnnotated cconv
+    unless (ll == noSrcSpan) $ markAnnotated safety
+    unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint Safety where
+  getAnnotationEntry = const NoEntryVal
+  exact = withPpr
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint CCallConv where
+  getAnnotationEntry = const NoEntryVal
+  exact = withPpr
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (WarnDecls GhcPs) where
+  getAnnotationEntry (Warnings an _ _) = fromAnn an
+  exact (Warnings an src warns) = do
+    markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
+    markAnnotated warns
+    markLocatedAALS an id AnnClose (Just "#-}")
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (WarnDecl GhcPs) where
+  getAnnotationEntry (Warning an _ _) = fromAnn an
+
+  exact (Warning an lns txt) = do
+    markAnnotated lns
+    markApiAnn an AnnOpenS -- "["
+    case txt of
+      WarningTxt    _src ls -> markAnnotated ls
+      DeprecatedTxt _src ls -> markAnnotated ls
+    markApiAnn an AnnCloseS -- "]"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint StringLiteral where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (StringLiteral src fs mcomma) = do
+    printSourceText src (show (unpackFS fs))
+    mapM_ (\r -> printStringAtKw' r ",") mcomma
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint FastString where
+  getAnnotationEntry = const NoEntryVal
+
+  -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
+  -- exact fs = printStringAdvance (show (unpackFS fs))
+  exact fs = printStringAdvance (unpackFS fs)
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RuleDecls GhcPs) where
+  getAnnotationEntry (HsRules an _ _) = fromAnn an
+  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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RuleDecl GhcPs) where
+  getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an
+  exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do
+    debugM "HsRule entered"
+    markAnnotated ln
+    debugM "HsRule after ln"
+    markActivation an ra_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
+    markApiAnn' 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 :: ApiAnn' a -> (a -> [AddApiAnn]) -> Activation -> Annotated ()
+markActivation an fn act = do
+  case act of
+    ActiveBefore src phase -> do
+      markApiAnn' an fn AnnOpenS --  '['
+      markApiAnn' an fn AnnTilde -- ~
+      markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
+      markApiAnn' an fn AnnCloseS -- ']'
+    ActiveAfter src phase -> do
+      markApiAnn' an fn AnnOpenS --  '['
+      markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) ""))
+      markApiAnn' an fn AnnCloseS -- ']'
+    NeverActive -> do
+      markApiAnn' an fn AnnOpenS --  '['
+      markApiAnn' an fn AnnTilde -- ~
+      markApiAnn' an fn AnnCloseS -- ']'
+    _ -> return ()
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (SpliceDecl GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (SpliceDecl _ splice _flag) = do
+    markAnnotated splice
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint DocDecl where
+  getAnnotationEntry = const NoEntryVal
+
+  exact v =
+    let str =
+          case v of
+            (DocCommentNext ds)     -> unpackHDS ds
+            (DocCommentPrev ds)     -> unpackHDS ds
+            (DocCommentNamed _s ds) -> unpackHDS ds
+            (DocGroup _i ds)        -> unpackHDS ds
+    in
+      printStringAdvance str
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RoleAnnotDecl GhcPs) where
+  getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an
+  exact (RoleAnnotDecl an ltycon roles) = do
+    markApiAnn an AnnType
+    markApiAnn an AnnRole
+    markAnnotated ltycon
+    markAnnotated roles
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint Role where
+  getAnnotationEntry = const NoEntryVal
+  exact = withPpr
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RuleBndr GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+{-
+  = 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
+    markApiAnn an AnnOpenP -- "("
+    markAnnotated ln
+    markApiAnn an AnnDcolon
+    markAnnotated ty
+    markApiAnn 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
+--     markApiAnn an AnnEqual
+--     markAnnotated rhs
+
+instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where
+  getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an
+  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
+    markApiAnn an AnnEqual
+    markAnnotated rhs
+
+-- ---------------------------------------------------------------------
+
+exactHsFamInstLHS ::
+      ApiAnn
+   -> LocatedN RdrName
+   -- -> Maybe [LHsTyVarBndr () GhcPs]
+   -> HsOuterTyVarBndrs () GhcPs
+   -> HsTyPats GhcPs
+   -> LexicalFixity
+   -> Maybe (LHsContext GhcPs)
+   -> EPP ()
+exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do
+  markApiAnn an AnnForall
+  markAnnotated bndrs
+  markApiAnn an AnnDot
+  mapM_ markAnnotated mb_ctxt
+  exact_pats typats
+  where
+    exact_pats :: HsTyPats GhcPs -> EPP ()
+    exact_pats (patl:patr:pats)
+      | Infix <- fixity
+      = let exact_op_app = do
+              markAnnotated patl
+              markAnnotated thing
+              markAnnotated patr
+        in case pats of
+             [] -> exact_op_app
+             _  -> do
+               markApiAnn an AnnOpenP
+               exact_op_app
+               markApiAnn an AnnCloseP
+               mapM_ markAnnotated pats
+
+    exact_pats pats = do
+      markAnnotated thing
+      markAnnotated pats
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (LHsTypeArg GhcPs) where
+instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)
+     =>  ExactPrint (HsArg tm ty) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (HsValArg tm)    = markAnnotated tm
+  exact (HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty
+  exact x@(HsArgPar _sp)   = withPpr x -- Does not appear in original source
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint [LHsTyVarBndr () GhcPs] where
+--   getAnnotationEntry = const NoEntryVal
+--   exact bs = mapM_ markAnnotated bs
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (ClsInstDecl GhcPs) where
+  getAnnotationEntry cid = fromAnn (fst $ 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
+          markApiAnn an AnnWhere
+          markApiAnn an AnnOpenC
+      -- = vcat [ top_matter <+> text "where"
+      --        , nest 2 $ pprDeclList $
+      --          map (pprTyFamInstDecl NotTopLevel . unLoc)   ats ++
+      --          map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
+      --          pprLHsBindsForUser binds sigs ]
+          withSortKey sortKey
+                               (prepareListAnnotationA ats
+                             ++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts
+                             ++ prepareListAnnotationA (bagToList binds)
+                             ++ prepareListAnnotationA sigs
+                               )
+          markApiAnn an AnnCloseC -- '}'
+
+      where
+        top_matter = do
+          markApiAnn an AnnInstance
+          mapM_ markAnnotated mbOverlap
+          markAnnotated inst_ty
+          markApiAnn an AnnWhere -- Optional
+          -- text "instance" <+> ppOverlapPragma mbOverlap
+          --                                    <+> ppr inst_ty
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (TyFamInstDecl GhcPs) where
+  getAnnotationEntry (TyFamInstDecl an _) = fromAnn an
+  exact d@(TyFamInstDecl _an _eqn) =
+    exactTyFamInstDecl TopLevel d
+
+-- ---------------------------------------------------------------------
+
+-- instance (ExactPrint body) => ExactPrint (HsImplicitBndrs GhcPs body) where
+--   getAnnotationEntry (HsIB an _) = fromAnn an
+--   exact (HsIB an t) = markAnnotated t
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (LocatedP OverlapMode) where
+  getAnnotationEntry = entryFromLocatedA
+
+  -- 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 _) (Overlappable src)) = do
+    markAnnOpenP an src "{-# OVERLAPPABLE"
+    markAnnCloseP an
+
+  exact (L (SrcSpanAnn an _) (Overlapping src)) = do
+    markAnnOpenP an src "{-# OVERLAPPING"
+    markAnnCloseP an
+
+  exact (L (SrcSpanAnn an _) (Overlaps src)) = do
+    markAnnOpenP an src "{-# OVERLAPS"
+    markAnnCloseP an
+
+  exact (L (SrcSpanAnn an _) (Incoherent src)) = do
+    markAnnOpenP an src "{-# INCOHERENT"
+    markAnnCloseP an
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsBind GhcPs) where
+  getAnnotationEntry FunBind{} = NoEntryVal
+  getAnnotationEntry PatBind{} = NoEntryVal
+  getAnnotationEntry VarBind{} = NoEntryVal
+  getAnnotationEntry AbsBinds{} = NoEntryVal
+  getAnnotationEntry PatSynBind{} = NoEntryVal
+
+  exact (FunBind _ _ matches _) = do
+    markAnnotated matches
+  exact (PatBind _ pat grhss _) = do
+    markAnnotated pat
+    markAnnotated grhss
+  exact (PatSynBind _ bind) = markAnnotated bind
+
+  exact x = error $ "HsBind: exact for " ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (PatSynBind GhcPs GhcPs) where
+  getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an
+
+  exact (PSB{ psb_ext = an
+            , psb_id = psyn, psb_args = details
+            , psb_def = pat
+            , psb_dir = dir }) = do
+    markApiAnn 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
+        markApiAnn an AnnOpenC  -- '{'
+        markAnnotated vs
+        markApiAnn an AnnCloseC -- '}'
+
+    case dir of
+      Unidirectional           -> do
+        markApiAnn an AnnLarrow
+        markAnnotated pat
+      ImplicitBidirectional    -> do
+        markApiAnn an AnnEqual
+        markAnnotated pat
+      ExplicitBidirectional mg -> do
+        markApiAnn an AnnLarrow
+        markAnnotated pat
+        markApiAnn 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
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (RecordPatSynField GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (RecordPatSynField { recordPatSynField = v }) = markAnnotated v
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where
+  getAnnotationEntry (Match ann _ _ _) = fromAnn ann
+
+  exact match@(Match ApiAnnNotUsed _ _ _) = withPpr match
+  exact (Match an mctxt pats grhss) = do
+    exactMatch (Match an mctxt pats grhss)
+
+-- -------------------------------------
+
+instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where
+  getAnnotationEntry (Match ann _ _ _) = fromAnn ann
+
+  exact match@(Match ApiAnnNotUsed _ _ _) = withPpr match
+  exact (Match an mctxt pats grhss) = do
+    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 -> markApiAnn 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
+  --                   markApiAnn an AnnOpenP
+  --                   markAnnotated p1
+  --                   markAnnotated fun
+  --                   markAnnotated p2
+  --                   markApiAnn an AnnCloseP
+  --                   mapM_ markAnnotated rest
+  --     LambdaExpr -> do
+  --       markApiAnn an AnnLam
+  --       mapM_ markAnnotated pats
+  --     GHC.CaseAlt -> do
+  --       mapM_ markAnnotated pats
+  --     _ -> withPpr mctxt
+
+  --   markAnnotated grhss
+
+-- ---------------------------------------------------------------------
+
+exactMatch :: (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> Annotated ()
+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 -> markApiAnn an AnnBang
+        _ -> pure ()
+      case fixity of
+        Prefix -> do
+          markAnnotated fun
+          markAnnotated pats
+        Infix ->
+          case pats of
+            (p1:p2:rest)
+              | null rest -> do
+                  markAnnotated p1
+                  markAnnotated fun
+                  markAnnotated p2
+              | otherwise -> do
+                  markApiAnn an AnnOpenP
+                  markAnnotated p1
+                  markAnnotated fun
+                  markAnnotated p2
+                  markApiAnn an AnnCloseP
+                  mapM_ markAnnotated rest
+            _ -> panic "FunRhs"
+    LambdaExpr -> do
+      markApiAnn an AnnLam
+      markAnnotated pats
+    GHC.CaseAlt -> do
+      markAnnotated pats
+    _ -> withPpr mctxt
+
+  markAnnotated grhss
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
+  getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
+
+  exact (GRHSs _ grhss binds) = do
+    markAnnotated grhss
+    markAnnotated binds
+
+
+instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where
+  getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
+
+  exact (GRHSs _an grhss binds) = do
+    markAnnotated grhss
+    markAnnotated binds
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsLocalBinds GhcPs) where
+  getAnnotationEntry (HsValBinds an _) = fromAnn an
+  getAnnotationEntry (HsIPBinds{}) = NoEntryVal
+  getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal
+
+  exact (HsValBinds an valbinds) = do
+    markLocatedAAL an al_rest AnnWhere
+    let manc = case an of
+                 ApiAnnNotUsed -> Nothing
+                 _ -> al_anchor $ anns an
+
+    case manc of
+      Just anc -> do
+        when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc)
+      _ -> return ()
+
+    markAnnotatedWithLayout valbinds
+
+  exact (HsIPBinds an bs)
+    = markAnnList an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs)
+  exact (EmptyLocalBinds _) = return ()
+
+
+-- ---------------------------------------------------------------------
+instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
+  getAnnotationEntry _ = NoEntryVal
+
+  exact (ValBinds sortKey binds sigs) = do
+    setLayoutBoth $ withSortKey sortKey
+       (prepareListAnnotationA (bagToList binds)
+     ++ prepareListAnnotationA sigs
+       )
+  exact (XValBindsLR _) = panic "XValBindsLR"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsIPBinds GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (IPBinds _ binds) = setLayoutBoth $ markAnnotated binds
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (IPBind GhcPs) where
+  getAnnotationEntry (IPBind an _ _) = fromAnn an
+
+  exact (IPBind an (Left lr) rhs) = do
+    markAnnotated lr
+    markApiAnn an AnnEqual
+    markAnnotated rhs
+
+  exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint HsIPName where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs))
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
+--   getAnnotationEntry _ = NoEntryVal
+
+--   exact (ValBinds sortKey binds sigs) = do
+--     -- printStringAdvance "ValBinds"
+--     setLayoutBoth $ withSortKey sortKey
+--        (prepareListAnnotationA (bagToList binds)
+--      ++ prepareListAnnotationA sigs
+--        )
+
+-- ---------------------------------------------------------------------
+-- Managing lists which have been separated, e.g. Sigs and Binds
+
+
+-- AZ:TODO: generalise this, and the next one
+-- prepareListAnnotationFamilyD :: [LFamilyDecl GhcPs] -> [(RealSrcSpan,EPP ())]
+-- prepareListAnnotationFamilyD ls
+--   = map (\b -> (realSrcSpan $ getLocA b,exactFamilyDecl NotTopLevel (unLoc b))) ls
+
+prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())]
+prepareListAnnotationF f ls
+  = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls
+
+prepareListAnnotationA :: ExactPrint (LocatedAn an a)
+  => [LocatedAn an a] -> [(RealSrcSpan,EPP ())]
+prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls
+
+
+-- applyListAnnotations :: [(RealSrcSpan, EPP ())] -> EPP ()
+-- applyListAnnotations ls = withSortKey ls
+
+withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP ()
+withSortKey annSortKey xs = do
+  debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
+  let ordered = case annSortKey of
+                  NoAnnSortKey -> sortBy orderByFst xs
+                  -- Just keys -> error $ "withSortKey: keys" ++ show keys
+                  AnnSortKey keys -> orderByKey xs keys
+                                -- `debug` ("withSortKey:" ++
+                                --          showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),
+                                --                  map fst xs,
+                                --                  keys)
+                                --          )
+  mapM_ snd ordered
+
+orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering
+orderByFst (a,_) (b,_) = compare a b
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (Sig GhcPs) where
+  getAnnotationEntry (TypeSig a _ _)  = fromAnn a
+  getAnnotationEntry (PatSynSig a _ _) = fromAnn a
+  getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a
+  getAnnotationEntry (IdSig {}) = NoEntryVal
+  getAnnotationEntry (FixSig a _) = fromAnn a
+  getAnnotationEntry (InlineSig a _ _) = fromAnn a
+  getAnnotationEntry (SpecSig a _ _ _) = fromAnn a
+  getAnnotationEntry (SpecInstSig a _ _) = fromAnn a
+  getAnnotationEntry (MinimalSig a _ _) = fromAnn a
+  getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a
+  getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a
+
+-- instance Annotate (Sig GhcPs) where
+
+  exact (TypeSig an vars ty)  = exactVarSig an vars ty
+
+  exact (PatSynSig an lns typ) = do
+    markLocatedAAL an asRest AnnPattern
+    markAnnotated lns
+    markLocatedAA an asDcolon
+    markAnnotated typ
+
+  exact (ClassOpSig an is_deflt vars ty)
+    | is_deflt  = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty
+    | otherwise = exactVarSig an vars ty
+
+--   markAST _ (IdSig {}) =
+--     traceM "warning: Introduced after renaming"
+
+  exact (FixSig an (FixitySig _ 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
+
+
+  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 "#-}" -- '#-}'
+    debugM $ "InlineSig:an=" ++ showAst an
+    p <- getPosP
+    debugM $ "InlineSig: p=" ++ show p
+    markLocatedAALS an id AnnClose (Just "#-}")
+    debugM $ "InlineSig:done"
+
+  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
+    markApiAnn an AnnDcolon
+    markAnnotated typs
+    markLocatedAALS an id AnnClose (Just "#-}")
+
+  exact (SpecInstSig an src typ) = do
+    markAnnOpen an src "{-# SPECIALISE"
+    markApiAnn 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 "#-}")
+
+--   markAST _ (CompleteMatchSig _ src (L _ ns) mlns) = do
+--     markAnnOpen src "{-# COMPLETE"
+--     markListIntercalate ns
+--     case mlns of
+--       Nothing -> return ()
+--       Just _ -> do
+--         mark AnnDcolon
+--         markMaybe mlns
+--     markWithString AnnClose "#-}" -- '#-}'
+--     markTrailingSemi
+
+  exact x = error $ "exact Sig for:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+exactVarSig :: (ExactPrint a) => ApiAnn' AnnSig -> [LocatedN RdrName] -> a -> EPP ()
+exactVarSig an vars ty = do
+  mapM_ markAnnotated vars
+  markLocatedAA an asDcolon
+  markAnnotated 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
+
+  exact (StandaloneKindSig an vars sig) = do
+    markApiAnn an AnnType
+    markAnnotated vars
+    markApiAnn an AnnDcolon
+    markAnnotated sig
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (DefaultDecl GhcPs) where
+  getAnnotationEntry (DefaultDecl an _) = fromAnn an
+
+  exact (DefaultDecl an tys) = do
+    markApiAnn an AnnDefault
+    markApiAnn an AnnOpenP
+    markAnnotated tys
+    markApiAnn an AnnCloseP
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (AnnDecl GhcPs) where
+  getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an
+
+  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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (BF.Var x)  = do
+    markAnnotated x
+  exact (BF.Or ls)  = markAnnotated ls
+  exact (BF.And ls) = do
+    markAnnotated 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
+instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where
+  getAnnotationEntry = const NoEntryVal
+  exact (HsWC _ ty) = markAnnotated ty
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where
+  getAnnotationEntry (GRHS an _ _) = fromAnn an
+
+  exact (GRHS an guards expr) = do
+    debugM $ "GRHS comments:" ++ showGhc (comments an)
+    markAnnKwM an ga_vbar AnnVbar
+    markAnnotated guards
+    debugM $ "GRHS before matchSeparator"
+    markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs
+    debugM $ "GRHS after matchSeparator"
+    markAnnotated expr
+    -- markLocatedAA an ga_sep
+
+instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where
+  getAnnotationEntry (GRHS ann _ _) = fromAnn ann
+
+  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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsExpr GhcPs) where
+  getAnnotationEntry (HsVar{})                    = NoEntryVal
+  getAnnotationEntry (HsUnboundVar an _)          = fromAnn an
+  getAnnotationEntry (HsConLikeOut{})             = NoEntryVal
+  getAnnotationEntry (HsRecFld{})                 = NoEntryVal
+  getAnnotationEntry (HsOverLabel an _)           = fromAnn an
+  getAnnotationEntry (HsIPVar an _)               = fromAnn an
+  getAnnotationEntry (HsOverLit an _)             = fromAnn an
+  getAnnotationEntry (HsLit an _)                 = fromAnn an
+  getAnnotationEntry (HsLam _ _)                  = NoEntryVal
+  getAnnotationEntry (HsLamCase an _)             = fromAnn an
+  getAnnotationEntry (HsApp an _ _)               = fromAnn an
+  getAnnotationEntry (HsAppType _ _ _)            = NoEntryVal
+  getAnnotationEntry (OpApp an _ _ _)             = fromAnn an
+  getAnnotationEntry (NegApp an _ _)              = fromAnn an
+  getAnnotationEntry (HsPar an _)                 = fromAnn an
+  getAnnotationEntry (SectionL an _ _)            = fromAnn an
+  getAnnotationEntry (SectionR an _ _)            = fromAnn an
+  getAnnotationEntry (ExplicitTuple an _ _)       = fromAnn an
+  getAnnotationEntry (ExplicitSum an _ _ _)       = fromAnn an
+  getAnnotationEntry (HsCase an _ _)              = fromAnn an
+  getAnnotationEntry (HsIf an _ _ _)              = fromAnn an
+  getAnnotationEntry (HsMultiIf an _)             = fromAnn an
+  getAnnotationEntry (HsLet an _ _)               = fromAnn an
+  getAnnotationEntry (HsDo an _ _)                = fromAnn an
+  getAnnotationEntry (ExplicitList an _)          = fromAnn an
+  getAnnotationEntry (RecordCon an _ _)           = fromAnn an
+  getAnnotationEntry (RecordUpd an _ _)           = fromAnn an
+  getAnnotationEntry (HsGetField an _ _)          = fromAnn an
+  getAnnotationEntry (HsProjection an _)          = fromAnn an
+  getAnnotationEntry (ExprWithTySig an _ _)       = fromAnn an
+  getAnnotationEntry (ArithSeq an _ _)            = fromAnn an
+  getAnnotationEntry (HsBracket an _)             = fromAnn an
+  getAnnotationEntry (HsRnBracketOut{})           = NoEntryVal
+  getAnnotationEntry (HsTcBracketOut{})           = NoEntryVal
+  getAnnotationEntry (HsSpliceE an _)             = fromAnn an
+  getAnnotationEntry (HsProc an _ _)              = fromAnn an
+  getAnnotationEntry (HsStatic an _)              = fromAnn an
+  getAnnotationEntry (HsTick {})                  = NoEntryVal
+  getAnnotationEntry (HsBinTick {})               = NoEntryVal
+  getAnnotationEntry (HsPragE{})                  = NoEntryVal
+
+
+  exact (HsVar _ n) = markAnnotated n
+  exact x@(HsUnboundVar an _v) = do
+    case an of
+      ApiAnnNotUsed -> withPpr x
+      ApiAnn _ (ApiAnnUnboundVar (ob,cb) l) _ -> do
+        printStringAtAA ob "`"
+        printStringAtAA l  "_"
+        printStringAtAA cb "`"
+  -- exact x@(HsConLikeOut{})             = withPpr x
+  -- exact x@(HsRecFld{})                 = withPpr x
+  -- exact x@(HsOverLabel ann _ _)        = withPpr x
+  exact (HsIPVar _ (HsIPName n))
+    = printStringAdvance ("?" ++ unpackFS n)
+
+  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"
+
+  exact (HsLamCase an mg) = do
+    markApiAnn an AnnLam
+    markApiAnn an AnnCase
+    markAnnotated mg
+
+  exact (HsApp _an e1 e2) = do
+    p <- getPosP
+    debugM $ "HsApp entered. p=" ++ show p
+    markAnnotated e1
+    markAnnotated e2
+  exact (HsAppType ss fun arg) = do
+    markAnnotated fun
+    printStringAtSs ss "@"
+    markAnnotated arg
+  exact (OpApp _an e1 e2 e3) = do
+    exact e1
+    exact e2
+    exact e3
+
+  exact (NegApp an e _) = do
+    markApiAnn an AnnMinus
+    markAnnotated e
+
+  exact (HsPar an e) = do
+    markOpeningParen an
+    markAnnotated e
+    debugM $ "HsPar closing paren"
+    markClosingParen an
+    debugM $ "HsPar done"
+
+  -- exact (SectionL an expr op) = do
+  exact (SectionR _an op expr) = do
+    markAnnotated op
+    markAnnotated expr
+  exact (ExplicitTuple an args b) = do
+    if b == Boxed then markApiAnn an AnnOpenP
+                  else markApiAnn an AnnOpenPH
+
+    mapM_ markAnnotated args
+
+    if b == Boxed then markApiAnn an AnnCloseP
+                  else markApiAnn an AnnClosePH
+    debugM $ "ExplicitTuple done"
+
+  exact (ExplicitSum an _alt _arity expr) = do
+    -- markApiAnn an AnnOpenPH
+    markAnnKw an aesOpen AnnOpenPH
+    markAnnKwAll an aesBarsBefore AnnVbar
+    markAnnotated expr
+    markAnnKwAll an aesBarsAfter AnnVbar
+    markAnnKw an aesClose AnnClosePH
+
+  exact (HsCase an e alts) = do
+    markAnnKw an hsCaseAnnCase AnnCase
+    markAnnotated e
+    markAnnKw an hsCaseAnnOf AnnOf
+    markApiAnn' an hsCaseAnnsRest AnnOpenC
+    markApiAnnAll an hsCaseAnnsRest AnnSemi
+    setLayoutBoth $ markAnnotated alts
+    markApiAnn' an hsCaseAnnsRest AnnCloseC
+
+  -- exact x@(HsCase ApiAnnNotUsed   _ _) = withPpr x
+  exact (HsIf an e1 e2 e3) = do
+    markApiAnn an AnnIf
+    markAnnotated e1
+    markApiAnn an AnnThen
+    markAnnotated e2
+    markApiAnn an AnnElse
+    markAnnotated e3
+
+  exact (HsMultiIf an mg) = do
+    markApiAnn an AnnIf
+    markApiAnn an AnnOpenC -- optional
+    markAnnotated mg
+    markApiAnn an AnnCloseC -- optional
+
+  exact (HsLet an binds e) = do
+    setLayoutBoth $ do -- Make sure the 'in' gets indented too
+      markAnnKw an alLet AnnLet
+      debugM $ "HSlet:binds coming"
+      setLayoutBoth $ markAnnotated binds
+      debugM $ "HSlet:binds done"
+      markAnnKw an alIn AnnIn
+      debugM $ "HSlet:expr coming"
+      markAnnotated e
+
+  exact (HsDo an do_or_list_comp stmts) = do
+    debugM $ "HsDo"
+    markAnnList an $ exactDo an do_or_list_comp stmts
+
+  exact (ExplicitList an es) = do
+    debugM $ "ExplicitList start"
+    markLocatedMAA an al_open
+    markAnnotated es
+    markLocatedMAA an al_close
+    debugM $ "ExplicitList end"
+  exact (RecordCon an con_id binds) = do
+    markAnnotated con_id
+    markApiAnn an AnnOpenC
+    markAnnotated binds
+    markApiAnn an AnnCloseC
+  exact (RecordUpd an expr fields) = do
+    markAnnotated expr
+    markApiAnn an AnnOpenC
+    markAnnotated fields
+    markApiAnn an AnnCloseC
+  exact (HsGetField _an expr field) = do
+    markAnnotated expr
+    markAnnotated field
+  exact (HsProjection an flds) = do
+    markAnnKw an apOpen AnnOpenP
+    markAnnotated flds
+    markAnnKw an apClose AnnCloseP
+  exact (ExprWithTySig an expr sig) = do
+    markAnnotated expr
+    markApiAnn an AnnDcolon
+    markAnnotated sig
+  exact (ArithSeq an _ seqInfo) = do
+    markApiAnn an AnnOpenS -- '['
+    case seqInfo of
+        From e -> do
+          markAnnotated e
+          markApiAnn an AnnDotdot
+        FromTo e1 e2 -> do
+          markAnnotated e1
+          markApiAnn an AnnDotdot
+          markAnnotated e2
+        FromThen e1 e2 -> do
+          markAnnotated e1
+          markApiAnn an AnnComma
+          markAnnotated e2
+          markApiAnn an AnnDotdot
+        FromThenTo e1 e2 e3 -> do
+          markAnnotated e1
+          markApiAnn an AnnComma
+          markAnnotated e2
+          markApiAnn an AnnDotdot
+          markAnnotated e3
+    markApiAnn an AnnCloseS -- ']'
+
+
+  exact (HsBracket an (ExpBr _ e)) = do
+    markApiAnn an AnnOpenEQ -- "[|"
+    markApiAnn an AnnOpenE  -- "[e|" -- optional
+    markAnnotated e
+    markApiAnn an AnnCloseQ -- "|]"
+  exact (HsBracket an (PatBr _ e)) = do
+    markLocatedAALS an id AnnOpen (Just "[p|")
+    markAnnotated e
+    markApiAnn an AnnCloseQ -- "|]"
+  exact (HsBracket an (DecBrL _ e)) = do
+    markLocatedAALS an id AnnOpen (Just "[d|")
+    markAnnotated e
+    markApiAnn an AnnCloseQ -- "|]"
+  -- -- exact (HsBracket an (DecBrG _ _)) =
+  -- --   traceM "warning: DecBrG introduced after renamer"
+  exact (HsBracket an (TypBr _ e)) = do
+    markLocatedAALS an id AnnOpen (Just "[t|")
+    markAnnotated e
+    markApiAnn an AnnCloseQ -- "|]"
+  exact (HsBracket an (VarBr _ b e)) = do
+    if b
+      then do
+        markApiAnn an AnnSimpleQuote
+        markAnnotated e
+      else do
+        markApiAnn an AnnThTyQuote
+        markAnnotated e
+  exact (HsBracket an (TExpBr _ e)) = do
+    markLocatedAALS an id AnnOpen (Just "[||")
+    markLocatedAALS an id AnnOpenE (Just "[e||")
+    markAnnotated e
+    markLocatedAALS an id AnnClose (Just "||]")
+
+
+  -- exact x@(HsRnBracketOut{})           = withPpr x
+  -- exact x@(HsTcBracketOut{})           = withPpr x
+  exact (HsSpliceE _ sp) = markAnnotated sp
+
+  exact (HsProc an p c) = do
+    debugM $ "HsProc start"
+    markApiAnn an AnnProc
+    markAnnotated p
+    markApiAnn an AnnRarrow
+    debugM $ "HsProc after AnnRarrow"
+    markAnnotated c
+
+  exact (HsStatic an e) = do
+    markApiAnn an AnnStatic
+    markAnnotated e
+
+  -- exact x@(HsTick {})                  = withPpr x
+  -- exact x@(HsBinTick {})               = withPpr x
+  exact (HsPragE _ prag e) = do
+    markAnnotated prag
+    markAnnotated e
+  exact x = error $ "exact HsExpr for:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+exactDo :: (ExactPrint body)
+        => ApiAnn' AnnList -> (HsStmtContext any) -> 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 ArrowExpr     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 _  _             _     = panic "pprDo" -- PatGuard, ParStmtCxt
+
+exactMdo :: ApiAnn' 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)
+    where
+      n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw))
+
+
+-- ---------------------------------------------------------------------
+instance ExactPrint (HsPragE GhcPs) where
+  getAnnotationEntry HsPragSCC{}  = NoEntryVal
+
+  exact (HsPragSCC an st sl) = do
+    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
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsSplice GhcPs) where
+  getAnnotationEntry (HsTypedSplice an _ _ _)   = fromAnn an
+  getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an
+  getAnnotationEntry (HsQuasiQuote _ _ _ _ _)   = NoEntryVal
+  getAnnotationEntry (HsSpliced _ _ _)          = NoEntryVal
+
+  exact (HsTypedSplice an DollarSplice _n e) = do
+    markApiAnn an AnnDollarDollar
+    markAnnotated e
+
+  -- = ppr_splice (text "$$") n e empty
+  -- exact (HsTypedSplice _ BareSplice _ _ )
+  -- = panic "Bare typed splice"  -- impossible
+  exact (HsUntypedSplice an decoration _n b) = do
+    when (decoration == DollarSplice) $ markApiAnn an AnnDollar
+    markAnnotated b
+
+  -- exact (HsUntypedSplice _ DollarSplice n e)
+  -- = ppr_splice (text "$")  n e empty
+  -- exact (HsUntypedSplice _ BareSplice n e)
+  -- = ppr_splice empty  n e empty
+
+  exact (HsQuasiQuote _ _ q ss fs) = do
+    -- The quasiquote string does not honour layout offsets. Store
+    -- the colOffset for now.
+    -- TODO: use local?
+    oldOffset <- getLayoutOffsetP
+    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)
+
+  -- exact (HsSpliced _ _ thing)         = ppr thing
+  -- exact (XSplice x)                   = case ghcPass @p of
+  exact x = error $ "exact HsSplice for:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+-- TODO:AZ: combine these instances
+instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
+  getAnnotationEntry = const NoEntryVal
+  exact (MG _ matches _) = do
+    -- TODO:AZ use SortKey, in MG ann.
+    markAnnotated matches
+
+instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where
+  getAnnotationEntry = const NoEntryVal
+  exact (MG _ matches _) = do
+    -- TODO:AZ use SortKey, in MG ann.
+    markAnnotated matches
+
+-- ---------------------------------------------------------------------
+
+instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
+  getAnnotationEntry = const NoEntryVal
+  exact (HsRecFields fields mdot) = do
+    markAnnotated fields
+    case mdot of
+      Nothing -> return ()
+      Just (L ss _) ->
+        printStringAtSs ss ".."
+      -- Note: mdot contains the SrcSpan where the ".." appears, if present
+
+-- ---------------------------------------------------------------------
+
+-- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where
+instance (ExactPrint body)
+    => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where
+  getAnnotationEntry x = fromAnn (hsRecFieldAnn x)
+  exact (HsRecField an f arg isPun) = do
+    debugM $ "HsRecField"
+    markAnnotated f
+    if isPun then return ()
+             else do
+      markApiAnn an AnnEqual
+      markAnnotated arg
+
+-- ---------------------------------------------------------------------
+
+instance (ExactPrint body)
+    => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where
+  getAnnotationEntry x = fromAnn (hsRecFieldAnn x)
+  exact (HsRecField an f arg isPun) = do
+    debugM $ "HsRecField FieldLabelStrings"
+    markAnnotated f
+    if isPun then return ()
+             else do
+      markApiAnn an AnnEqual
+      markAnnotated arg
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (HsRecUpdField GhcPs ) where
+instance (ExactPrint body)
+    => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where
+-- instance (ExactPrint body)
+    -- => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where
+  getAnnotationEntry x = fromAnn (hsRecFieldAnn x)
+  exact (HsRecField an f arg isPun) = do
+    debugM $ "HsRecUpdField"
+    markAnnotated f
+    if isPun then return ()
+             else markApiAnn an AnnEqual
+    markAnnotated arg
+
+-- ---------------------------------------------------------------------
+-- instance (ExactPrint body)
+--     => ExactPrint (Either (HsRecField' (AmbiguousFieldOcc GhcPs) body)
+--                           (HsRecField' (FieldOcc GhcPs) body)) where
+--   getAnnotationEntry = const NoEntryVal
+--   exact (Left rbinds) = markAnnotated rbinds
+--   exact (Right pbinds) = markAnnotated pbinds
+
+-- ---------------------------------------------------------------------
+-- instance (ExactPrint body)
+--     => ExactPrint
+--          (Either [LocatedA (HsRecField' (AmbiguousFieldOcc GhcPs) body)]
+--                  [LocatedA (HsRecField' (FieldOcc GhcPs) body)]) where
+--   getAnnotationEntry = const NoEntryVal
+--   exact (Left rbinds) = markAnnotated rbinds
+--   exact (Right pbinds) = markAnnotated pbinds
+
+-- ---------------------------------------------------------------------
+instance -- (ExactPrint body)
+    (ExactPrint (HsRecField' (a GhcPs) body),
+     ExactPrint (HsRecField' (b GhcPs) body))
+    => ExactPrint
+         (Either [LocatedA (HsRecField' (a GhcPs) body)]
+                 [LocatedA (HsRecField' (b GhcPs) body)]) where
+  getAnnotationEntry = const NoEntryVal
+  exact (Left rbinds) = markAnnotated rbinds
+  exact (Right pbinds) = markAnnotated pbinds
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (FieldLabelStrings GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (FieldLabelStrings fs) = markAnnotated fs
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsFieldLabel GhcPs) where
+  getAnnotationEntry (HsFieldLabel an _) = fromAnn an
+
+  exact (HsFieldLabel an fs) = do
+    markAnnKwM an afDot  AnnDot
+    markAnnotated fs
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsTupArg GhcPs) where
+  getAnnotationEntry (Present an _) = fromAnn an
+  getAnnotationEntry (Missing an)   = fromAnn an
+
+  exact (Present _ e) = markAnnotated e
+
+  exact (Missing ApiAnnNotUsed) = return ()
+  exact (Missing _) = printStringAdvance ","
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsCmdTop GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (HsCmdTop _ cmd) = markAnnotated cmd
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsCmd GhcPs) where
+  getAnnotationEntry (HsCmdArrApp an _ _ _ _)   = fromAnn an
+  getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an
+  getAnnotationEntry (HsCmdApp an _ _ )         = fromAnn an
+  getAnnotationEntry (HsCmdLam {})              = NoEntryVal
+  getAnnotationEntry (HsCmdPar an _)            = fromAnn an
+  getAnnotationEntry (HsCmdCase an _ _)         = fromAnn an
+  getAnnotationEntry (HsCmdLamCase an _)        = fromAnn an
+  getAnnotationEntry (HsCmdIf an _ _ _ _)       = fromAnn an
+  getAnnotationEntry (HsCmdLet an _ _)          = fromAnn an
+  getAnnotationEntry (HsCmdDo an _)             = fromAnn an
+
+
+-- ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
+--   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
+-- ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
+--   = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
+-- ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
+--   = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
+-- ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
+--   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
+
+  exact (HsCmdArrApp an arr arg _o isRightToLeft) = do
+    if isRightToLeft
+      then do
+        markAnnotated arr
+        markKw (anns an)
+        markAnnotated arg
+      else do
+        markAnnotated arg
+        markKw (anns an)
+        markAnnotated arr
+--   markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do
+--         -- isRightToLeft True  => right-to-left (f -< arg)
+--         --               False => left-to-right (arg >- f)
+--     if isRightToLeft
+--       then do
+--         markLocated e1
+--         case o of
+--           GHC.HsFirstOrderApp  -> mark GHC.Annlarrowtail
+--           GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail
+--       else do
+--         markLocated e2
+--         case o of
+--           GHC.HsFirstOrderApp  -> mark GHC.Annrarrowtail
+--           GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail
+
+--     if isRightToLeft
+--       then markLocated e2
+--       else markLocated e1
+
+  exact (HsCmdArrForm an e fixity _mf [arg1,arg2]) = do
+    markLocatedMAA an al_open
+    case fixity of
+      Infix -> do
+        markAnnotated arg1
+        markAnnotated e
+        markAnnotated arg2
+      Prefix -> do
+        markAnnotated e
+        markAnnotated arg1
+        markAnnotated arg2
+    markLocatedMAA an al_close
+--   markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do
+--     -- The AnnOpen should be marked for a prefix usage, not for a postfix one,
+--     -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm
+
+--     let isPrefixOp = case fixity of
+--           GHC.Infix  -> False
+--           GHC.Prefix -> True
+--     when isPrefixOp $ mark GHC.AnnOpenB -- "(|"
+
+--     -- This may be an infix operation
+--     applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp)
+--                                      (Set.singleton InfixOp) (Set.singleton InfixOp))
+--                        (prepareListAnnotation [e]
+--                          ++ prepareListAnnotation cs)
+--     when isPrefixOp $ mark GHC.AnnCloseB -- "|)"
+
+--   markAST _ (GHC.HsCmdApp _ e1 e2) = do
+--     markLocated e1
+--     markLocated e2
+
+  exact (HsCmdLam _ match) = markAnnotated match
+--   markAST l (GHC.HsCmdLam _ match) = do
+--     setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match
+
+  exact (HsCmdPar an e) = do
+    markOpeningParen an
+    markAnnotated e
+    markClosingParen an
+
+  exact (HsCmdCase an e alts) = do
+    markAnnKw an hsCaseAnnCase AnnCase
+    markAnnotated e
+    markAnnKw an hsCaseAnnOf AnnOf
+    markApiAnn' an hsCaseAnnsRest AnnOpenC
+    markApiAnnAll an hsCaseAnnsRest AnnSemi
+    markAnnotated alts
+    markApiAnn' an hsCaseAnnsRest AnnCloseC
+    -- markApiAnn an AnnCase
+    -- markAnnotated e1
+    -- markApiAnn an AnnOf
+    -- markApiAnn an AnnOpenC
+    -- markAnnotated matches
+    -- markApiAnn an AnnCloseC
+
+--   markAST l (GHC.HsCmdCase _ e1 matches) = do
+--     mark GHC.AnnCase
+--     markLocated e1
+--     mark GHC.AnnOf
+--     markOptional GHC.AnnOpenC
+--     setContext (Set.singleton CaseAlt) $ do
+--       markMatchGroup l matches
+--     markOptional GHC.AnnCloseC
+
+--   markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do
+--     mark GHC.AnnIf
+--     markLocated e1
+--     markOffset GHC.AnnSemi 0
+--     mark GHC.AnnThen
+--     markLocated e2
+--     markOffset GHC.AnnSemi 1
+--     mark GHC.AnnElse
+--     markLocated 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
+
+  exact (HsCmdDo an es) = do
+    debugM $ "HsCmdDo"
+    markApiAnn' 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
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (StmtLR GhcPs GhcPs (LHsCmd GhcPs)) where
+instance (ExactPrint (LocatedA body))
+   => ExactPrint (StmtLR GhcPs GhcPs (LocatedA body)) where
+-- instance ExactPrint (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) where
+  getAnnotationEntry (LastStmt _ _ _ _)             = NoEntryVal
+  getAnnotationEntry (BindStmt an _ _)              = fromAnn an
+  getAnnotationEntry (ApplicativeStmt _ _ _)        = NoEntryVal
+  getAnnotationEntry (BodyStmt _ _ _ _)             = NoEntryVal
+  getAnnotationEntry (LetStmt an _)                 = fromAnn an
+  getAnnotationEntry (ParStmt _ _ _ _)              = NoEntryVal
+  getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an
+  getAnnotationEntry (RecStmt an _ _ _ _ _ _)       = fromAnn an
+
+  -----------------------------------------------------------------
+
+  exact (LastStmt _ body _ _) = do
+    debugM $ "LastStmt"
+    markAnnotated body
+
+  exact (BindStmt an pat body) = do
+    debugM $ "BindStmt"
+    markAnnotated pat
+    markApiAnn an AnnLarrow
+    markAnnotated body
+
+  exact (ApplicativeStmt _ _body _) = do
+    debugM $ "ApplicativeStmt"
+    -- TODO: ApplicativeStmt
+    -- markAnnotated body
+    error $ "need to complete ApplicativeStmt"
+
+  exact (BodyStmt _ body _ _) = do
+    debugM $ "BodyStmt"
+    markAnnotated body
+
+  exact (LetStmt an binds) = do
+    debugM $ "LetStmt"
+    markApiAnn an AnnLet
+    markAnnotated binds
+
+  exact (ParStmt _ pbs _ _) = 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 _ _stmts _ _ _ _ _) = do
+    -- TODO: implement RecStmt
+    debugM $ "RecStmt"
+    error $ "need to test RecStmt"
+
+  -- 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
+
+  -- exact x = error $ "exact CmdLStmt for:" ++ showAst x
+  -- exact x = error $ "exact CmdLStmt for:"
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (ParStmtBlock GhcPs GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts
+
+exactTransStmt :: ApiAnn -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP ()
+exactTransStmt an by using ThenForm = do
+  debugM $ "exactTransStmt:ThenForm"
+  markApiAnn an AnnThen
+  markAnnotated using
+  case by of
+    Nothing -> return ()
+    Just b -> do
+      markApiAnn an AnnBy
+      markAnnotated b
+exactTransStmt an by using GroupForm = do
+  debugM $ "exactTransStmt:GroupForm"
+  markApiAnn an AnnThen
+  markApiAnn an AnnGroup
+  case by of
+    Just b -> do
+      markApiAnn an AnnBy
+      markAnnotated b
+    Nothing -> return ()
+  markApiAnn an AnnUsing
+  markAnnotated using
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (TyClDecl GhcPs) where
+  getAnnotationEntry (FamDecl   { })                      = NoEntryVal
+  getAnnotationEntry (SynDecl   { tcdSExt = an })         = fromAnn an
+  getAnnotationEntry (DataDecl  { tcdDExt = an })         = fromAnn an
+  getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an
+
+  exact (FamDecl _ decl) = do
+    markAnnotated 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 [GHC.AnnOpenP,GHC.AnnCloseP]
+    markApiAnn an AnnType
+
+    -- markTyClass Nothing fixity ln tyvars
+    exactVanillaDeclHead an ltycon tyvars fixity Nothing
+    markApiAnn 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
+
+  exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars
+                  , tcdFixity = fixity, tcdDataDefn = defn }) =
+    exactDataDefn an (exactVanillaDeclHead an ltycon tyvars fixity) defn
+
+  -- -----------------------------------
+
+  exact (ClassDecl {tcdCExt = (an, sortKey, _),
+                    tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
+                    tcdFixity = fixity,
+                    tcdFDs  = fds,
+                    tcdSigs = sigs, tcdMeths = methods,
+                    tcdATs = ats, tcdATDefs = at_defs,
+                    tcdDocs = _docs})
+      -- TODO: add a test that demonstrates tcdDocs
+      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
+      = top_matter
+
+      | otherwise       -- Laid out
+      = do
+          top_matter
+          -- markApiAnn an AnnWhere
+          markApiAnn an AnnOpenC
+          withSortKey sortKey
+                               (prepareListAnnotationA sigs
+                             ++ prepareListAnnotationA (bagToList methods)
+                             ++ prepareListAnnotationA ats
+                             ++ prepareListAnnotationA at_defs
+                             -- ++ prepareListAnnotation docs
+                               )
+          markApiAnn an AnnCloseC
+      where
+        top_matter = do
+          annotationsToComments (apiAnnAnns an)  [AnnOpenP, AnnCloseP]
+          markApiAnn an AnnClass
+          exactVanillaDeclHead an lclas tyvars fixity context
+          unless (null fds) $ do
+            markApiAnn an AnnVbar
+            markAnnotated fds
+          markApiAnn an AnnWhere
+
+--   -- -----------------------------------
+
+--   markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds
+--                           sigs meths ats atdefs docs) = do
+--     mark GHC.AnnClass
+--     markLocated ctx
+
+--     markTyClass Nothing fixity ln tyVars
+
+--     unless (null fds) $ do
+--       mark GHC.AnnVbar
+--       markListIntercalateWithFunLevel markLocated 2 fds
+--     mark GHC.AnnWhere
+--     markOptional GHC.AnnOpenC -- '{'
+--     markInside GHC.AnnSemi
+--     -- AZ:TODO: we end up with both the tyVars and the following body of the
+--     -- class defn in annSortKey for the class. This could cause problems when
+--     -- changing things.
+--     setContext (Set.singleton InClassDecl) $
+--       applyListAnnotationsLayout
+--                            (prepareListAnnotation sigs
+--                          ++ prepareListAnnotation (GHC.bagToList meths)
+--                          ++ prepareListAnnotation ats
+--                          ++ prepareListAnnotation atdefs
+--                          ++ prepareListAnnotation docs
+--                            )
+--     markOptional GHC.AnnCloseC -- '}'
+--     markTrailingSemi
+-- {-
+--   | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs
+--                 tcdCtxt    :: LHsContext pass,         -- ^ Context...
+--                 tcdLName   :: Located (IdP pass),      -- ^ Name of the class
+--                 tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables
+--                 tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration
+--                 tcdFDs     :: [Located (FunDep (Located (IdP pass)))],
+--                                                         -- ^ Functional deps
+--                 tcdSigs    :: [LSig pass],              -- ^ Methods' signatures
+--                 tcdMeths   :: LHsBinds pass,            -- ^ Default methods
+--                 tcdATs     :: [LFamilyDecl pass],       -- ^ Associated types;
+--                 tcdATDefs  :: [LTyFamDefltEqn pass],
+--                                                    -- ^ Associated type defaults
+--                 tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
+--     }
+
+-- -}
+
+--   markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _)
+--     = error "extension hit for TyClDecl"
+--   markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _))
+--     = error "extension hit for TyClDecl"
+--   markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _)
+--     = error "extension hit for TyClDecl"
+--   markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _)
+--     = error "extension hit for TyClDecl"
+--   markAST _ (GHC.XTyClDecl _)
+--     = error "extension hit for TyClDecl"
+  -- exact x = error $ "exact TyClDecl for:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (FunDep GhcPs) where
+  getAnnotationEntry (FunDep an _ _) = fromAnn an
+
+  exact (FunDep an ls rs') = do
+    markAnnotated ls
+    markApiAnn an AnnRarrow
+    markAnnotated rs'
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (FamilyDecl GhcPs) where
+  getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an
+
+  exact (FamilyDecl { fdExt = an
+                    , fdInfo = info
+                    , fdTopLevel = top_level
+                    , fdLName = ltycon
+                    , fdTyVars = tyvars
+                    , fdFixity = fixity
+                    , fdResultSig = L _ 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
+    exactVanillaDeclHead an ltycon tyvars fixity Nothing
+    exact_kind
+    mapM_ markAnnotated mb_inj
+    case info of
+      ClosedTypeFamily mb_eqns -> do
+        markApiAnn an AnnWhere
+        markApiAnn an AnnOpenC
+        case mb_eqns of
+          Nothing -> printStringAdvance ".."
+          Just eqns -> markAnnotated eqns
+        markApiAnn an AnnCloseC
+      _ -> return ()
+    where
+      exact_top_level = case top_level of
+                          TopLevel    -> markApiAnn an AnnFamily
+                          NotTopLevel -> return ()
+
+      exact_kind = case result of
+                     NoSig    _         -> return ()
+                     KindSig  _ kind    -> markApiAnn an AnnDcolon >> markAnnotated kind
+                     TyVarSig _ tv_bndr -> markApiAnn 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 :: ApiAnn -> FamilyInfo GhcPs -> EPP ()
+exactFlavour an DataFamily            = markApiAnn an AnnData
+exactFlavour an OpenTypeFamily        = markApiAnn an AnnType
+exactFlavour an (ClosedTypeFamily {}) = markApiAnn an AnnType
+
+-- instance Outputable (FamilyInfo pass) where
+--   ppr info = pprFlavour info <+> text "family"
+
+-- ---------------------------------------------------------------------
+
+exactDataDefn :: ApiAnn
+              -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header
+              -> HsDataDefn GhcPs
+              -> EPP ()
+exactDataDefn an exactHdr
+                 (HsDataDefn { dd_ext = an2
+                             , dd_ND = new_or_data, dd_ctxt = context
+                             , dd_cType = mb_ct
+                             , dd_kindSig = mb_sig
+                             , dd_cons = condecls, dd_derivs = derivings }) = do
+  if new_or_data == DataType
+    then markApiAnn an2 AnnData
+    else markApiAnn an2 AnnNewtype
+  mapM_ markAnnotated mb_ct
+  exactHdr context
+  case mb_sig of
+    Nothing -> return ()
+    Just kind -> do
+      markApiAnn an AnnDcolon
+      markAnnotated kind
+  when (isGadt condecls) $ markApiAnn an AnnWhere
+  exact_condecls an2 condecls
+  mapM_ markAnnotated derivings
+  return ()
+
+exactVanillaDeclHead :: ApiAnn
+                     -> LocatedN RdrName
+                     -> LHsQTyVars GhcPs
+                     -> LexicalFixity
+                     -> Maybe (LHsContext GhcPs)
+                     -> EPP ()
+exactVanillaDeclHead an thing (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))]
+          markApiAnnAll an id AnnOpenP
+          markAnnotated varl
+          markAnnotated thing
+          markAnnotated (head varsr)
+          markApiAnnAll an id AnnCloseP
+          markAnnotated (tail varsr)
+          return ()
+      | fixity == Infix = do
+         -- = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
+         -- , hsep (map (ppr.unLoc) varsr)]
+          markAnnotated varl
+          markAnnotated thing
+          markAnnotated varsr
+          return ()
+      | otherwise = do
+          -- hsep [ pprPrefixOcc (unLoc thing)
+          --      , hsep (map (ppr.unLoc) (varl:varsr))]
+          markAnnotated thing
+          mapM_ markAnnotated (varl:varsr)
+          return ()
+    exact_tyvars [] = do
+      -- pprPrefixOcc (unLoc thing)
+      markAnnotated thing
+  mapM_ markAnnotated context
+  exact_tyvars tyvars
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (InjectivityAnn GhcPs) where
+  getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an
+  exact (InjectivityAnn an lhs rhs) = do
+    markApiAnn an AnnVbar
+    markAnnotated lhs
+    markApiAnn an AnnRarrow
+    mapM_ markAnnotated rhs
+    --               Just (L _ (InjectivityAnn _ lhs rhs)) ->
+    --                 hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
+    --               Nothing -> empty
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (HsTyVarBndr () GhcPs) where
+--   getAnnotationEntry (UserTyVar an _ _)     = fromAnn an
+--   getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
+--   exact = withPpr
+
+instance (Typeable flag) => ExactPrint (HsTyVarBndr flag GhcPs) where
+  getAnnotationEntry (UserTyVar an _ _)     = fromAnn an
+  getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
+
+  exact (UserTyVar an _ n)     = do
+    markApiAnnAll an id AnnOpenP
+    markAnnotated n
+    markApiAnnAll an id AnnCloseP
+  exact (KindedTyVar an _ n k) = do
+    markApiAnnAll an id AnnOpenP
+    markAnnotated n
+    markApiAnn an AnnDcolon
+    markAnnotated k
+    markApiAnnAll an id AnnCloseP
+
+-- ---------------------------------------------------------------------
+
+-- 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
+  getAnnotationEntry (HsQualTy _ _ _)          = NoEntryVal
+  getAnnotationEntry (HsTyVar an _ _)          = fromAnn an
+  getAnnotationEntry (HsAppTy _ _ _)           = NoEntryVal
+  getAnnotationEntry (HsAppKindTy _ _ _)       = NoEntryVal
+  getAnnotationEntry (HsFunTy an _ _ _)        = fromAnn an
+  getAnnotationEntry (HsListTy an _)           = fromAnn an
+  getAnnotationEntry (HsTupleTy an _ _)        = fromAnn an
+  getAnnotationEntry (HsSumTy an _)            = fromAnn an
+  getAnnotationEntry (HsOpTy _ _ _ _)          = NoEntryVal
+  getAnnotationEntry (HsParTy an _)            = fromAnn an
+  getAnnotationEntry (HsIParamTy an _ _)       = fromAnn an
+  getAnnotationEntry (HsStarTy _ _)            = NoEntryVal
+  getAnnotationEntry (HsKindSig an _ _)        = fromAnn an
+  getAnnotationEntry (HsSpliceTy _ _)          = NoEntryVal
+  getAnnotationEntry (HsDocTy an _ _)          = fromAnn an
+  getAnnotationEntry (HsBangTy an _ _)         = fromAnn an
+  getAnnotationEntry (HsRecTy an _)            = fromAnn an
+  getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an
+  getAnnotationEntry (HsExplicitTupleTy an _)  = fromAnn an
+  getAnnotationEntry (HsTyLit _ _)             = NoEntryVal
+  getAnnotationEntry (HsWildCardTy _)          = NoEntryVal
+  getAnnotationEntry (XHsType _)               = NoEntryVal
+
+
+  exact (HsForAllTy { hst_xforall = _an
+                    , hst_tele = tele, hst_body = ty }) = do
+    markAnnotated tele
+    markAnnotated ty
+
+  exact (HsQualTy _ ctxt ty) = do
+    markAnnotated ctxt
+    -- markApiAnn an AnnDarrow
+    markAnnotated ty
+  exact (HsTyVar an promoted name) = do
+    when (promoted == IsPromoted) $ markApiAnn an AnnSimpleQuote
+    markAnnotated name
+
+  exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2
+  exact (HsAppKindTy ss ty ki) = do
+    markAnnotated ty
+    printStringAtSs ss "@"
+    markAnnotated ki
+  exact (HsFunTy an mult ty1 ty2) = do
+    markAnnotated ty1
+    markArrow an mult
+    markAnnotated ty2
+  exact (HsListTy an tys) = do
+    markOpeningParen an
+    markAnnotated tys
+    markClosingParen an
+  exact (HsTupleTy an _con tys) = do
+    markOpeningParen an
+    markAnnotated tys
+    markClosingParen an
+  exact (HsSumTy an tys) = do
+    markOpeningParen an
+    markAnnotated tys
+    markClosingParen an
+  exact (HsOpTy _an t1 lo t2) = do
+    markAnnotated t1
+    markAnnotated lo
+    markAnnotated t2
+  exact (HsParTy an ty) = do
+    markOpeningParen an
+    markAnnotated ty
+    markClosingParen an
+  exact (HsIParamTy an n t) = do
+      markAnnotated n
+      markApiAnn an AnnDcolon
+      markAnnotated t
+  exact (HsStarTy _an isUnicode)
+    = if isUnicode
+        then printStringAdvance "\x2605" -- Unicode star
+        else printStringAdvance "*"
+  exact (HsKindSig an ty k) = do
+    exact ty
+    markApiAnn an AnnDcolon
+    exact 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     -> markApiAnn an AnnTilde
+      SrcStrict   -> markApiAnn an AnnBang
+      NoSrcStrict -> return ()
+    markAnnotated ty
+  -- exact x@(HsRecTy an _)            = withPpr x
+  exact (HsExplicitListTy an prom tys) = do
+    when (isPromoted prom) $ markApiAnn an AnnSimpleQuote
+    markApiAnn an AnnOpenS
+    markAnnotated tys
+    markApiAnn an AnnCloseS
+  exact (HsExplicitTupleTy an tys) = do
+    markApiAnn an AnnSimpleQuote
+    markApiAnn an AnnOpenP
+    markAnnotated tys
+    markApiAnn an AnnCloseP
+  exact (HsTyLit _ 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 "_"
+  exact x = error $ "missing match for HsType:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsForAllTelescope GhcPs) where
+  getAnnotationEntry (HsForAllVis an _)   = fromAnn an
+  getAnnotationEntry (HsForAllInvis an _) = fromAnn an
+
+  exact (HsForAllVis an bndrs)   = do
+    markLocatedAA an fst -- AnnForall
+    markAnnotated bndrs
+    markLocatedAA an snd -- AnnRarrow
+
+  exact (HsForAllInvis an bndrs) = do
+    markLocatedAA an fst -- AnnForall
+    markAnnotated bndrs
+    markLocatedAA an snd -- AnnDot
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsDerivingClause GhcPs) where
+  getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d)
+
+  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 ]
+    markApiAnn an AnnDeriving
+    exact_strat_before
+    markAnnotated dct
+    exact_strat_after
+      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)
+            _                          -> (mapM_ markAnnotated dcs, pure ())
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (DerivStrategy GhcPs) where
+  getAnnotationEntry (StockStrategy an)    = fromAnn an
+  getAnnotationEntry (AnyclassStrategy an) = fromAnn an
+  getAnnotationEntry (NewtypeStrategy an)  = fromAnn an
+  getAnnotationEntry (ViaStrategy (XViaStrategyPs an  _)) = fromAnn an
+
+  exact (StockStrategy an)    = markApiAnn an AnnStock
+  exact (AnyclassStrategy an) = markApiAnn an AnnAnyclass
+  exact (NewtypeStrategy an)  = markApiAnn an AnnNewtype
+  exact (ViaStrategy (XViaStrategyPs an ty))
+    = markApiAnn an AnnVia >> markAnnotated ty
+
+-- ---------------------------------------------------------------------
+
+instance (ExactPrint a) => ExactPrint (LocatedC a) where
+  getAnnotationEntry (L sann _) = fromAnn sann
+
+  exact (L (SrcSpanAnn ApiAnnNotUsed _) a) = markAnnotated a
+  exact (L (SrcSpanAnn (ApiAnn _ (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) (sort opens)
+    markAnnotated a
+    mapM_ (markKwA AnnCloseP) (sort closes)
+    case ma of
+      Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r
+      Just (NormalSyntax,  r) -> markKwA AnnDarrow  r
+      Nothing -> pure ()
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (DerivClauseTys GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (DctSingle _ ty) = markAnnotated ty
+  exact (DctMulti _ tys) = do
+    -- parens (interpp'SP tys)
+    markAnnotated tys
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsSigType GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (HsSig _ bndrs ty) = do
+    markAnnotated bndrs
+    markAnnotated ty
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (LocatedN RdrName) where
+  getAnnotationEntry (L sann _) = fromAnn sann
+
+  exact (L (SrcSpanAnn ApiAnnNotUsed l) n) = do
+    p <- getPosP
+    debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n)
+    printStringAtSs l (showPprUnsafe n)
+  exact (L (SrcSpanAnn (ApiAnn _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 (AddApiAnn kwo o)
+        forM_ cs (\loc -> markKw (AddApiAnn AnnComma loc))
+        markKw (AddApiAnn kwc c)
+        markTrailing t
+      NameAnnOnly a o c t -> do
+        markName a o Nothing c
+        markTrailing t
+      NameAnnRArrow nl t -> do
+        markKw (AddApiAnn AnnRarrow nl)
+        markTrailing t
+      NameAnnQuote q name t -> do
+        debugM $ "NameAnnQuote"
+        markKw (AddApiAnn AnnSimpleQuote q)
+        markAnnotated (L name n)
+        markTrailing t
+      NameAnnTrailing t -> do
+        printStringAdvance (showPprUnsafe n)
+        markTrailing t
+
+markName :: NameAdornment
+         -> AnnAnchor -> Maybe (AnnAnchor,RdrName) -> AnnAnchor -> EPP ()
+markName adorn open mname close = do
+  let (kwo,kwc) = adornments adorn
+  markKw (AddApiAnn kwo open)
+  case mname of
+    Nothing -> return ()
+    Just (name, a) -> printStringAtAA name (showPprUnsafe a)
+  markKw (AddApiAnn kwc close)
+
+adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId)
+adornments NameParens     = (AnnOpenP, AnnCloseP)
+adornments NameParensHash = (AnnOpenPH, AnnClosePH)
+adornments NameBackquotes = (AnnBackquote, AnnBackquote)
+adornments NameSquare     = (AnnOpenS, AnnCloseS)
+
+markTrailing :: [TrailingAnn] -> EPP ()
+markTrailing ts = do
+  p <- getPosP
+  debugM $ "markTrailing:" ++ showPprUnsafe (p,ts)
+  mapM_ markKwT (sort ts)
+
+-- ---------------------------------------------------------------------
+
+-- based on pp_condecls in Decls.hs
+exact_condecls :: ApiAnn -> [LConDecl GhcPs] -> EPP ()
+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
+  | otherwise                    -- In H98 syntax
+  -- = equals <+> sep (punctuate (text " |") (map ppr cs))
+  = do
+      -- printStringAdvance "exact_condecls:not gadt"
+      markApiAnn an AnnEqual
+      mapM_ markAnnotated cs
+  where
+    gadt_syntax = case cs of
+      []                      -> False
+      (L _ ConDeclH98{}  : _) -> False
+      (L _ ConDeclGADT{} : _) -> True
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (ConDecl GhcPs) where
+  getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x)
+  getAnnotationEntry x@(ConDeclH98{})  = fromAnn (con_ext x)
+
+-- based on pprConDecl
+  exact (ConDeclH98 { con_ext = an
+                    , con_name = con
+                    , con_forall = has_forall
+                    , con_ex_tvs = ex_tvs
+                    , 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 $ markApiAnn an AnnForall
+    mapM_ markAnnotated ex_tvs
+    when has_forall $ markApiAnn an AnnDot
+    -- exactHsForall (mkHsForAllInvisTele ex_tvs) mcxt
+    mapM_ markAnnotated mcxt
+    when (isJust mcxt) $ markApiAnn an AnnDarrow
+
+    exact_details args
+
+    -- case args of
+    --   InfixCon _ _ -> return ()
+    --   _ -> markAnnotated con
+    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
+      exact_details (PrefixCon tyargs tys) = do
+        markAnnotated con
+        markAnnotated tyargs
+        markAnnotated tys
+      exact_details (RecCon fields) = do
+        markAnnotated con
+        markAnnotated fields
+
+  -- -----------------------------------
+
+  exact (ConDeclGADT { con_g_ext = an
+                     , con_names = cons
+                     , 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
+    markApiAnn an AnnDcolon
+    annotationsToComments (apiAnnAnns an)  [AnnOpenP, AnnCloseP]
+    -- when has_forall $ markApiAnn an AnnForall
+    markAnnotated bndrs
+    -- mapM_ markAnnotated qvars
+    -- when has_forall $ markApiAnn an AnnDot
+    mapM_ markAnnotated mcxt
+    when (isJust mcxt) $ markApiAnn an AnnDarrow
+    -- mapM_ markAnnotated args
+    case args of
+        (PrefixConGADT args') -> mapM_ markAnnotated args'
+        (RecConGADT fields)   -> markAnnotated fields
+          -- 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 '_']
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint Void where
+  getAnnotationEntry = const NoEntryVal
+  exact _ = return ()
+
+-- ---------------------------------------------------------------------
+
+instance (Typeable flag) => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where
+  getAnnotationEntry (HsOuterImplicit _) = NoEntryVal
+  getAnnotationEntry (HsOuterExplicit an _) = fromAnn an
+
+  exact (HsOuterImplicit _) = pure ()
+  exact (HsOuterExplicit an bndrs) = do
+    markLocatedAA an fst -- "forall"
+    markAnnotated bndrs
+    markLocatedAA an snd -- "."
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (ConDeclField GhcPs) where
+  getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f)
+
+  exact (ConDeclField an names ftype mdoc) = do
+    markAnnotated names
+    markApiAnn an AnnDcolon
+    markAnnotated ftype
+    mapM_ markAnnotated mdoc
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (FieldOcc GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (FieldOcc _ n) = markAnnotated n
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (AmbiguousFieldOcc GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (Unambiguous _ n) = markAnnotated n
+  exact (Ambiguous   _ n) = markAnnotated n
+
+-- ---------------------------------------------------------------------
+
+instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
+  getAnnotationEntry = const NoEntryVal
+  exact (HsScaled _arr t) = markAnnotated t
+
+-- ---------------------------------------------------------------------
+
+-- instance ExactPrint (LHsContext GhcPs) where
+--   getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann
+--   exact = withPpr
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (LocatedP CType) where
+  getAnnotationEntry = entryFromLocatedA
+
+  exact (L (SrcSpanAnn ApiAnnNotUsed _) ct) = withPpr ct
+  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
+
+-- instance Annotate GHC.CType where
+--   markAST _ (GHC.CType src mh f) = do
+--     -- markWithString GHC.AnnOpen src
+--     markAnnOpen src ""
+--     case mh of
+--       Nothing -> return ()
+--       Just (GHC.Header srcH _h) ->
+--          -- markWithString GHC.AnnHeader srcH
+--          markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "")
+--     -- markWithString GHC.AnnVal (fst f)
+--     markSourceText  (fst f) (GHC.unpackFS $ snd f)
+--     markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (SourceText, RuleName) where
+  -- We end up at the right place from the Located wrapper
+  getAnnotationEntry = const NoEntryVal
+
+  exact (st, rn)
+    = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "")
+
+
+-- =====================================================================
+-- LocatedL instances start --
+--
+-- Each is dealt with specifically, as they have
+-- different wrapping annotations in the al_rest zone.
+--
+-- In future, the annotation could perhaps be improved, with an
+-- 'al_pre' and 'al_post' set of annotations to be simply sorted and
+-- applied.
+-- ---------------------------------------------------------------------
+
+-- instance (ExactPrint body) => ExactPrint (LocatedL body) where
+--   getAnnotationEntry = entryFromLocatedA
+--   exact (L (SrcSpanAnn an _) b) = do
+--     markLocatedMAA an al_open
+--     markApiAnnAll an al_rest AnnSemi
+--     markAnnotated b
+--     markLocatedMAA an al_close
+
+instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where
+  getAnnotationEntry = entryFromLocatedA
+
+  exact (L (SrcSpanAnn ann _) ies) = do
+    debugM $ "LocatedL [LIE"
+    markLocatedAAL ann al_rest AnnHiding
+    p <- getPosP
+    debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p
+    markAnnList ann (markAnnotated ies)
+
+-- 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?
+    markApiAnnAll (ann la) al_rest AnnWhere
+    markLocatedMAA (ann la) al_open
+    markApiAnnAll (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?
+    markApiAnnAll (ann la) al_rest AnnWhere
+    markLocatedMAA (ann la) al_open
+    markApiAnnAll (ann la) al_rest AnnSemi
+    markAnnotated a
+    markLocatedMAA (ann la) al_close
+
+-- 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
+    debugM $ "LocatedL [ExprLStmt"
+    markAnnList an $ do
+      -- markLocatedMAA an al_open
+      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
+
+-- 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
+    debugM $ "LocatedL [CmdLStmt"
+    markLocatedMAA ann al_open
+    mapM_ markAnnotated es
+    markLocatedMAA ann al_close
+
+instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
+  getAnnotationEntry = entryFromLocatedA
+  exact (L (SrcSpanAnn an _) fs) = do
+    debugM $ "LocatedL [LConDeclField"
+    markAnnList an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_
+
+instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
+  getAnnotationEntry = entryFromLocatedA
+  exact (L (SrcSpanAnn an _) bf) = do
+    debugM $ "LocatedL [LBooleanFormula"
+    markAnnList an (markAnnotated bf)
+
+-- ---------------------------------------------------------------------
+-- LocatedL instances end --
+-- =====================================================================
+
+instance ExactPrint (IE GhcPs) where
+  getAnnotationEntry (IEVar _ _)            = NoEntryVal
+  getAnnotationEntry (IEThingAbs an _)      = fromAnn an
+  getAnnotationEntry (IEThingAll an _)      = fromAnn an
+  getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an
+  getAnnotationEntry (IEModuleContents an _)= fromAnn an
+  getAnnotationEntry (IEGroup _ _ _)        = NoEntryVal
+  getAnnotationEntry (IEDoc _ _)            = NoEntryVal
+  getAnnotationEntry (IEDocNamed _ _)       = NoEntryVal
+
+  exact (IEVar _ ln) = markAnnotated ln
+  exact (IEThingAbs _ thing) = markAnnotated thing
+  exact (IEThingAll an thing) = do
+    markAnnotated thing
+    markApiAnn an AnnOpenP
+    markApiAnn an AnnDotdot
+    markApiAnn an AnnCloseP
+
+  exact (IEThingWith an thing wc withs) = do
+    markAnnotated thing
+    markApiAnn an AnnOpenP
+    case wc of
+      NoIEWildcard -> markAnnotated withs
+      IEWildcard pos -> do
+        let (bs, as) = splitAt pos withs
+        markAnnotated bs
+        markApiAnn an AnnDotdot
+        markApiAnn an AnnComma
+        markAnnotated as
+    markApiAnn an AnnCloseP
+
+  exact (IEModuleContents an (L lm mn)) = do
+    markApiAnn an AnnModule
+    printStringAtSs lm (moduleNameString mn)
+
+  -- exact (IEGroup _ _ _)          = NoEntryVal
+  -- exact (IEDoc _ _)              = NoEntryVal
+  -- exact (IEDocNamed _ _)         = NoEntryVal
+  exact x = error $ "missing match for IE:" ++ showAst x
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (IEWrappedName RdrName) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (IEName n) = markAnnotated n
+  exact (IEPattern r n) = do
+    printStringAtAA r "pattern"
+    markAnnotated n
+  exact (IEType r n) = do
+    printStringAtAA r "type"
+    markAnnotated n
+
+-- markIEWrapped :: ApiAnn -> LIEWrappedName RdrName -> EPP ()
+-- markIEWrapped an (L _ (IEName n))
+--   = markAnnotated n
+-- markIEWrapped an (L _ (IEPattern n))
+--   = markApiAnn an AnnPattern >> markAnnotated n
+-- markIEWrapped an (L _ (IEType n))
+--   = markApiAnn an AnnType    >> markAnnotated 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
+  getAnnotationEntry (LazyPat an _)           = fromAnn an
+  getAnnotationEntry (AsPat an _ _)           = fromAnn an
+  getAnnotationEntry (ParPat an _)            = fromAnn an
+  getAnnotationEntry (BangPat an _)           = fromAnn an
+  getAnnotationEntry (ListPat an _)           = fromAnn an
+  getAnnotationEntry (TuplePat an _ _)        = fromAnn an
+  getAnnotationEntry (SumPat an _ _ _)        = fromAnn an
+  getAnnotationEntry (ConPat an _ _)          = fromAnn an
+  getAnnotationEntry (ViewPat an _ _)         = fromAnn an
+  getAnnotationEntry (SplicePat _ _)          = NoEntryVal
+  getAnnotationEntry (LitPat _ _)             = NoEntryVal
+  getAnnotationEntry (NPat an _ _ _)          = fromAnn an
+  getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
+  getAnnotationEntry (SigPat an _ _)          = fromAnn an
+
+  exact (WildPat _) = 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
+  -- | LazyPat an pat)
+  exact (AsPat an n pat) = do
+    markAnnotated n
+    markApiAnn an AnnAt
+    markAnnotated pat
+  exact (ParPat an pat) = do
+    markAnnKw an ap_open AnnOpenP
+    markAnnotated pat
+    markAnnKw an ap_close AnnCloseP
+
+  -- | BangPat an pat)
+  exact (ListPat an pats) = markAnnList an (markAnnotated pats)
+
+  exact (TuplePat an pats boxity) = do
+    case boxity of
+      Boxed   -> markApiAnn an AnnOpenP
+      Unboxed -> markApiAnn an AnnOpenPH
+    markAnnotated pats
+    case boxity of
+      Boxed   -> markApiAnn an AnnCloseP
+      Unboxed -> markApiAnn 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
+      -- markPat _ (GHC.SumPat _ pat alt arity) = do
+      --   markWithString GHC.AnnOpen "(#"
+      --   replicateM_ (alt - 1) $ mark GHC.AnnVbar
+      --   markLocated pat
+      --   replicateM_ (arity - alt) $ mark GHC.AnnVbar
+      --   markWithString GHC.AnnClose "#)"
+
+  -- | ConPat an con args)
+  exact (ConPat an con details) = exactUserCon an con details
+  exact (ViewPat an expr pat) = do
+    markAnnotated expr
+    markApiAnn an AnnRarrow
+    markAnnotated pat
+  exact (SplicePat _ splice) = markAnnotated splice
+  exact (LitPat _ lit) = printStringAdvance (hsLit2String lit)
+  exact (NPat an ol mn _) = do
+    when (isJust mn) $ markApiAnn an AnnMinus
+    markAnnotated ol
+
+  -- | NPlusKPat an n lit1 lit2 _ _)
+  exact (SigPat an pat sig) = do
+    markAnnotated pat
+    markApiAnn an AnnDcolon
+    markAnnotated sig
+  -- exact x = withPpr x
+  exact x = error $ "missing match for Pat:" ++ showAst x
+
+-- instance Annotate (GHC.Pat GHC.GhcPs) where
+--   markAST loc typ = do
+--     markPat loc typ
+--     inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat")
+--     where
+--       markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"
+--       markPat l (GHC.VarPat _ n) = do
+--         -- The parser inserts a placeholder value for a record pun rhs. This must be
+--         -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is
+--         -- resolved, particularly for pretty printing where annotations are added.
+--         let pun_RDR = "pun-right-hand-side"
+--         when (showPprUnsafe n /= pun_RDR) $
+--           unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n)
+--           -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n
+--       markPat _ (GHC.LazyPat _ p) = do
+--         mark GHC.AnnTilde
+--         markLocated p
+
+--       markPat _ (GHC.AsPat _ ln p) = do
+--         markLocated ln
+--         mark GHC.AnnAt
+--         markLocated p
+
+--       markPat _ (GHC.ParPat _ p) = do
+--         mark GHC.AnnOpenP
+--         markLocated p
+--         mark GHC.AnnCloseP
+
+--       markPat _ (GHC.BangPat _ p) = do
+--         mark GHC.AnnBang
+--         markLocated p
+
+--       markPat _ (GHC.ListPat _ ps) = do
+--         mark GHC.AnnOpenS
+--         markListIntercalateWithFunLevel markLocated 2 ps
+--         mark GHC.AnnCloseS
+
+--       markPat _ (GHC.TuplePat _ pats b) = do
+--         if b == GHC.Boxed then mark GHC.AnnOpenP
+--                           else markWithString GHC.AnnOpen "(#"
+--         markListIntercalateWithFunLevel markLocated 2 pats
+--         if b == GHC.Boxed then mark GHC.AnnCloseP
+--                           else markWithString GHC.AnnClose "#)"
+
+--       markPat _ (GHC.SumPat _ pat alt arity) = do
+--         markWithString GHC.AnnOpen "(#"
+--         replicateM_ (alt - 1) $ mark GHC.AnnVbar
+--         markLocated pat
+--         replicateM_ (arity - alt) $ mark GHC.AnnVbar
+--         markWithString GHC.AnnClose "#)"
+
+--       markPat _ (GHC.ConPatIn n dets) = do
+--         markHsConPatDetails n dets
+
+--       markPat _ GHC.ConPatOut {} =
+--         traceM "warning: ConPatOut Introduced after renaming"
+
+--       markPat _ (GHC.ViewPat _ e pat) = do
+--         markLocated e
+--         mark GHC.AnnRarrow
+--         markLocated pat
+
+--       markPat l (GHC.SplicePat _ s) = do
+--         markAST l s
+
+--       markPat l (GHC.LitPat _ lp) = markAST l lp
+
+--       markPat _ (GHC.NPat _ ol mn _) = do
+--         when (isJust mn) $ mark GHC.AnnMinus
+--         markLocated ol
+
+--       markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do
+--         markLocated ln
+--         markWithString GHC.AnnVal "+"  -- "+"
+--         markLocated ol
+
+
+--       markPat _ (GHC.SigPat _ pat ty) = do
+--         markLocated pat
+--         mark GHC.AnnDcolon
+--         markLHsSigWcType ty
+
+--       markPat _ GHC.CoPat {} =
+--         traceM "warning: CoPat introduced after renaming"
+
+--       markPat _ (GHC.XPat (GHC.L l p)) = markPat l p
+--       -- markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showPprUnsafe x
+
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsPatSigType GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact (HsPS _ ty) = markAnnotated ty
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsOverLit GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+
+  exact ol =
+    let str = case ol_val ol of
+                HsIntegral   (IL src _ _) -> src
+                HsFractional (FL{ fl_text = src }) -> src
+                HsIsString src _ -> src
+    in
+      case str of
+        SourceText s -> printStringAdvance s
+        NoSourceText -> return ()
+
+-- ---------------------------------------------------------------------
+
+hsLit2String :: HsLit GhcPs -> String
+hsLit2String lit =
+  case lit of
+    HsChar       src v   -> toSourceTextWithSuffix src v ""
+    -- It should be included here
+    -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471
+    HsCharPrim   src p   -> toSourceTextWithSuffix src p "#"
+    HsString     src v   -> toSourceTextWithSuffix src v ""
+    HsStringPrim src v   -> toSourceTextWithSuffix src v ""
+    HsInt        _ (IL src _ v)   -> toSourceTextWithSuffix src v ""
+    HsIntPrim    src v   -> toSourceTextWithSuffix src v ""
+    HsWordPrim   src v   -> toSourceTextWithSuffix src v ""
+    HsInt64Prim  src v   -> toSourceTextWithSuffix src v ""
+    HsWord64Prim src v   -> toSourceTextWithSuffix src v ""
+    HsInteger    src v _ -> toSourceTextWithSuffix src v ""
+    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
+toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix
+
+sourceTextToString :: SourceText -> String -> String
+sourceTextToString NoSourceText alt   = alt
+sourceTextToString (SourceText txt) _ = txt
+
+-- ---------------------------------------------------------------------
+
+exactUserCon :: (ExactPrint con) => ApiAnn -> con -> HsConPatDetails GhcPs -> EPP ()
+exactUserCon _  c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2
+exactUserCon an c details          = do
+  markAnnotated c
+  markApiAnn an AnnOpenC
+  exactConArgs details
+  markApiAnn an AnnCloseC
+
+
+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
+
+-- ---------------------------------------------------------------------
+
+entryFromLocatedA :: LocatedAn ann a -> Entry
+entryFromLocatedA (L la _) = fromAnn la
+
+-- =====================================================================
+-- Utility stuff
+-- ---------------------------------------------------------------------
+
+-- |This should be the final point where things are mode concrete,
+-- before output.
+-- NOTE: despite the name, this is the ghc-exactprint final output for
+-- the PRINT phase.
+printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m ()
+printStringAtLsDelta cl s = do
+  p <- getPosP
+  colOffset <- getLayoutOffsetP
+  if isGoodDeltaWithOffset cl colOffset
+    then do
+      printStringAt (undelta p cl colOffset) s
+        `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))
+    else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s))
+
+-- ---------------------------------------------------------------------
+
+isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool
+isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP l c)
+  where (l,c) = undelta (0,0) dp colOffset
+
+printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m ()
+printQueuedComment loc Comment{commentContents} dp = do
+  p <- getPosP
+  colOffset <- getLayoutOffsetP
+  let (dr,dc) = undelta (0,0) dp colOffset
+  -- do not lose comments against the left margin
+  when (isGoodDelta (DP dr (max 0 dc))) $ do
+    printCommentAt (undelta p dp colOffset) commentContents
+    setPriorEndASTD False loc
+  p' <- getPosP
+  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, epContext = pushAcs (epContext s) })
+
+------------------------------------------------------------------------
+
+setLayoutBoth :: (Monad m, Monoid w) => EP w m () -> EP w m ()
+setLayoutBoth k = do
+  oldLHS <- gets dLHS
+  oldAnchorOffset <- getLayoutOffsetP
+  debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)
+  modify (\a -> a { dMarkLayout = True
+                  , pMarkLayout = True } )
+  let reset = do
+        debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)
+        modify (\a -> a { dMarkLayout = False
+                        , dLHS = oldLHS
+                        , pMarkLayout = False
+                        , pLHS = oldAnchorOffset} )
+  k <* reset
+
+-- Use 'local', designed for this
+setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m () -> EP w m ()
+setLayoutTopLevelP k = do
+  debugM $ "setLayoutTopLevelP entered"
+  oldAnchorOffset <- getLayoutOffsetP
+  modify (\a -> a { pMarkLayout = False
+                  , pLHS = 1} )
+  k
+  debugM $ "setLayoutTopLevelP:resetting"
+  setLayoutOffsetP oldAnchorOffset
+
+------------------------------------------------------------------------
+
+getPosP :: (Monad m, Monoid w) => EP w m Pos
+getPosP = gets epPos
+
+setPosP :: (Monad m, Monoid w) => Pos -> EP w m ()
+setPosP l = do
+  debugM $ "setPosP:" ++ show l
+  modify (\s -> s {epPos = l})
+
+getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor)
+getExtraDP = gets uExtraDP
+
+setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m ()
+setExtraDP md = do
+  debugM $ "setExtraDP:" ++ show md
+  modify (\s -> s {uExtraDP = md})
+
+getPriorEndD :: (Monad m, Monoid w) => EP w m Pos
+getPriorEndD = gets dPriorEndPosition
+
+getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan
+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
+  modify (\s -> s { dPriorEndPosition = pe })
+
+setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m ()
+setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe)
+
+setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m ()
+setPriorEndASTPD layout pe@(fm,to) = do
+  debugM $ "setPriorEndASTD:pe=" ++ show pe
+  when layout $ setLayoutStartD (snd fm)
+  modify (\s -> s { dPriorEndPosition = to } )
+
+setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m ()
+setLayoutStartD p = do
+  EPState{dMarkLayout} <- get
+  when dMarkLayout $ do
+    debugM $ "setLayoutStartD: setting dLHS=" ++ show p
+    modify (\s -> s { dMarkLayout = False
+                    , dLHS = LayoutStartCol p})
+
+setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
+setAnchorU rss = do
+  debugM $ "setAnchorU:" ++ show (rs2range rss)
+  modify (\s -> s { uAnchorSpan = rss })
+
+getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment]
+getUnallocatedComments = gets epComments
+
+putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m ()
+putUnallocatedComments cs = modify (\s -> s { epComments = cs } )
+
+getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol
+getLayoutOffsetP = gets pLHS
+
+setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m ()
+setLayoutOffsetP c = do
+  debugM $ "setLayoutOffsetP:" ++ show c
+  modify (\s -> s { pLHS = c })
+
+-- getEofPos :: (Monad m, Monoid w) => EP w m RealSrcSpan
+-- getEofPos = do
+--   as <- gets epApiAnns
+--   case apiAnnEofPos as of
+--     Nothing -> return placeholderRealSpan
+--     Just ss -> return ss
+
+-- ---------------------------------------------------------------------
+-------------------------------------------------------------------------
+-- |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)
+-}
+
+-- ---------------------------------------------------------------------
+
+adjustDeltaForOffsetM :: DeltaPos -> EPP DeltaPos
+adjustDeltaForOffsetM dp = do
+  colOffset <- gets dLHS
+  return (adjustDeltaForOffset 0 colOffset dp)
+
+-- adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos
+-- adjustDeltaForOffset _ _colOffset                      dp@(DP (0,_)) = dp -- same line
+-- adjustDeltaForOffset d (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset - d)
+
+-- ---------------------------------------------------------------------
+-- Printing functions
+
+printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()
+printString layout str = do
+  EPState{epPos = (_,c), pMarkLayout} <- get
+  PrintOptions{epTokenPrint, epWhitespacePrint} <- ask
+  when (pMarkLayout && layout) $ do
+    debugM $ "printString: setting pLHS to " ++ show c
+    modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } )
+
+  -- Advance position, taking care of any newlines in the string
+  let strDP@(DP cr _cc) = dpFromString str
+  p <- getPosP
+  colOffset <- getLayoutOffsetP
+  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)
+
+  -- Debug stuff
+  -- pp <- getPosP
+  -- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str)
+  -- Debug end
+
+  --
+  if not layout && c == 0
+    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 str = do
+  ss <- getAnchorU
+  printStringAtKw' ss str
+
+--------------------------------------------------------
+
+newLine :: (Monad m, Monoid w) => EP w m ()
+newLine = do
+    (l,_) <- getPosP
+    printString False "\n"
+    setPosP (l+1,1)
+
+padUntil :: (Monad m, Monoid w) => Pos -> EP w m ()
+padUntil (l,c) = do
+    (l1,c1) <- getPosP
+    if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' '
+       | l1 < l             -> newLine >> padUntil (l,c)
+       | otherwise          -> return ()
+
+printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m ()
+printWhitespace = padUntil
+
+printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()
+printCommentAt p str = do
+  debugM $ "printCommentAt: (pos,str)" ++ show (p,str)
+  printWhitespace p >> printString False str
+
+printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()
+printStringAt p str = printWhitespace p >> printString True str
diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs
new file mode 100644
index 0000000000..8edf4ac1f0
--- /dev/null
+++ b/utils/check-exact/Lookup.hs
@@ -0,0 +1,137 @@
+module Lookup
+  (
+    keywordToString
+  , KeywordId(..)
+  , Comment(..)
+  ) where
+
+-- import Language.Haskell.ExactPrint.Types
+import GHC (AnnKeywordId(..))
+-- import GHC.Utils.Outputable hiding ( (<>) )
+-- import Data.Data (Data)
+-- import GHC.Types.SrcLoc
+-- import GHC.Driver.Session
+import Types
+
+-- | Maps `AnnKeywordId` to the corresponding String representation.
+-- There is no specific mapping for the following constructors.
+-- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`,
+-- `AnnInfix`
+keywordToString :: KeywordId -> 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 AnnAt     ) -> "@"
+      (G AnnBang   ) -> "!"
+      (G AnnBackquote ) -> "`"
+      (G AnnBy     ) -> "by"
+      (G AnnCase   ) -> "case"
+      (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 AnnLolly    ) -> "#->"
+      (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 AnnOpenPE   ) -> "$("
+      -- (G AnnOpenPTE  ) -> "$$("
+      (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) -> "⤚"
+      AnnTypeApp             -> "@"
+      (G AnnVia) -> "via"
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
new file mode 100644
index 0000000000..80c1908ce0
--- /dev/null
+++ b/utils/check-exact/Main.hs
@@ -0,0 +1,238 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- import Data.List
+-- import GHC.Types.SrcLoc
+import GHC hiding (moduleName)
+import GHC.Driver.Ppr
+import GHC.Driver.Session
+import GHC.Hs.Dump
+-- import qualified Control.Monad.IO.Class as GHC
+-- import GHC.Types.SourceText
+-- import GHC.Hs.Exact hiding (ExactPrint())
+-- import GHC.Utils.Outputable hiding (space)
+import System.Environment( getArgs )
+import System.Exit
+import System.FilePath
+import ExactPrint
+-- exactPrint = undefined
+-- showPprUnsafe = undefined
+
+-- ---------------------------------------------------------------------
+
+_tt :: IO ()
+-- _tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
+_tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
+-- _tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+
+ -- "../../testsuite/tests/printer/Ppr001.hs"
+ -- "../../testsuite/tests/printer/Ppr002.hs"
+ -- "../../testsuite/tests/printer/Ppr002a.hs"
+ -- "../../testsuite/tests/printer/Ppr003.hs"
+ -- "../../testsuite/tests/printer/Ppr004.hs"
+ -- "../../testsuite/tests/printer/Ppr005.hs"
+ -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs"
+ -- "../../testsuite/tests/printer/Ppr006.hs"
+ -- "../../testsuite/tests/printer/Ppr007.hs"
+ -- "../../testsuite/tests/printer/Ppr008.hs"
+ -- "../../testsuite/tests/hiefile/should_compile/hie008.hs"
+ -- "../../testsuite/tests/printer/Ppr009.hs"
+ -- "../../testsuite/tests/printer/Ppr011.hs"
+ -- "../../testsuite/tests/printer/Ppr012.hs"
+ -- "../../testsuite/tests/printer/Ppr013.hs"
+ -- "../../testsuite/tests/printer/Ppr014.hs"
+ -- "../../testsuite/tests/printer/Ppr015.hs"
+ -- "../../testsuite/tests/printer/Ppr016.hs"
+ -- "../../testsuite/tests/printer/Ppr017.hs"
+ -- "../../testsuite/tests/printer/Ppr018.hs"
+ -- "../../testsuite/tests/printer/Ppr019.hs"
+ -- "../../testsuite/tests/printer/Ppr020.hs"
+ -- "../../testsuite/tests/printer/Ppr021.hs"
+ -- "../../testsuite/tests/printer/Ppr022.hs"
+ -- "../../testsuite/tests/printer/Ppr023.hs"
+ -- "../../testsuite/tests/printer/Ppr024.hs"
+ -- "../../testsuite/tests/printer/Ppr025.hs"
+ -- "../../testsuite/tests/printer/Ppr026.hs"
+ -- "../../testsuite/tests/printer/Ppr027.hs"
+ -- "../../testsuite/tests/printer/Ppr028.hs"
+ -- "../../testsuite/tests/printer/Ppr029.hs"
+ -- "../../testsuite/tests/printer/Ppr030.hs"
+ -- "../../testsuite/tests/printer/Ppr031.hs"
+ -- "../../testsuite/tests/printer/Ppr032.hs"
+ -- "../../testsuite/tests/printer/Ppr033.hs"
+ -- "../../testsuite/tests/printer/Ppr034.hs"
+ -- "../../testsuite/tests/printer/Ppr035.hs"
+ -- "../../testsuite/tests/printer/Ppr036.hs"
+ -- "../../testsuite/tests/printer/Ppr037.hs"
+ -- "../../testsuite/tests/printer/Ppr038.hs"
+ -- "../../testsuite/tests/printer/Ppr039.hs"
+ -- "../../testsuite/tests/printer/Ppr040.hs"
+ -- "../../testsuite/tests/printer/Ppr041.hs"
+ -- "../../testsuite/tests/printer/Ppr042.hs"
+ -- "../../testsuite/tests/printer/Ppr043.hs"
+ -- "../../testsuite/tests/printer/Ppr044.hs"
+ -- "../../testsuite/tests/printer/Ppr045.hs"
+ -- "../../testsuite/tests/printer/Ppr046.hs"
+ -- Not tested, the GENERATED pragma is getting removed "../../testsuite/tests/printer/Ppr047.hs"
+ -- "../../testsuite/tests/printer/Ppr048.hs"
+ -- "../../testsuite/tests/printer/Ppr049.hs"
+ -- "../../testsuite/tests/printer/T13050p.hs"
+ -- "../../testsuite/tests/printer/T13199.hs"
+ -- "../../testsuite/tests/printer/T13550.hs"
+ -- "../../testsuite/tests/printer/T13942.hs"
+ -- "../../testsuite/tests/printer/T14289b.hs"
+ -- "../../testsuite/tests/printer/T14289c.hs"
+ -- "../../testsuite/tests/printer/T14289.hs"
+ -- "../../testsuite/tests/printer/T14306.hs"
+ -- "../../testsuite/tests/printer/T14343b.hs"
+ -- "../../testsuite/tests/printer/T14343.hs"
+ -- "../../testsuite/tests/printer/T15761.hs"
+ -- "../../testsuite/tests/printer/Test17519.hs"
+ -- "../../testsuite/tests/printer/T18052a.hs"
+ -- "../../testsuite/tests/printer/T18247a.hs"
+ -- "../../testsuite/tests/printer/Ppr050.hs"
+ -- "../../testsuite/tests/printer/Ppr051.hs"
+ -- "../../testsuite/tests/printer/Ppr052.hs"
+ -- "../../testsuite/tests/typecheck/should_fail/T17566c.hs"
+ -- "../../testsuite/tests/hiefile/should_compile/Constructors.hs"
+ -- "../../testsuite/tests/printer/StarBinderAnns.hs"
+ -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs"
+ -- "../../testsuite/tests/printer/Test10276.hs"
+ -- "../../testsuite/tests/printer/Test10278.hs"
+ -- "../../testsuite/tests/printer/Test12417.hs"
+ -- "../../testsuite/tests/parser/should_compile/T14189.hs"
+ -- "../../testsuite/tests/printer/Test16212.hs"
+ -- "../../testsuite/tests/printer/Test10312.hs"
+ -- "../../testsuite/tests/printer/Test10354.hs"
+ -- "../../testsuite/tests/printer/Test10357.hs"
+ -- "../../testsuite/tests/printer/Test10399.hs"
+ -- "../../testsuite/tests/printer/Test11018.hs"
+ -- "../../testsuite/tests/printer/Test11332.hs"
+ -- "../../testsuite/tests/printer/Test16230.hs"
+ -- "../../testsuite/tests/printer/Test16236.hs"
+ -- "../../testsuite/tests/printer/AnnotationLet.hs"
+ -- "../../testsuite/tests/printer/AnnotationTuple.hs"
+ -- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs"
+ -- "../../testsuite/tests/hiefile/should_compile/Scopes.hs"
+ -- "../../testsuite/tests/printer/Ppr053.hs"
+ -- "../../testsuite/tests/printer/Ppr054.hs"
+ -- "../../testsuite/tests/printer/Ppr055.hs"
+ -- "../../testsuite/tests/hiefile/should_run/PatTypes.hs"
+ -- "./cases/LocalDecls2.expected.hs"
+ -- "./cases/WhereIn3a.hs"
+ -- "./cases/AddLocalDecl1.hs"
+ -- "./cases/LayoutIn1.hs"
+ -- "./cases/EmptyWheres.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax1.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax2.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax3.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax4.hs"
+ "../../testsuite/tests/printer/PprRecordDotSyntaxA.hs"
+ -- "./cases/Windows.hs"
+
+-- exact = ppr
+
+-- ---------------------------------------------------------------------
+
+usage :: String
+usage = unlines
+    [ "usage: check-exact (libdir) (file)"
+    , ""
+    , "where libdir is the GHC library directory (e.g. the output of"
+    , "ghc --print-libdir) and file is the file to parse."
+    ]
+
+main :: IO()
+main = do
+  args <- getArgs
+  case args of
+   [libdir,fileName] -> testOneFile libdir fileName
+   _ -> putStrLn usage
+
+testOneFile :: FilePath -> String -> IO ()
+testOneFile libdir fileName = do
+       p <- parseOneFile libdir fileName
+       -- putStrLn $ "\n\ngot p"
+       let
+         origAst = showSDocUnsafe
+                     $ showAstData BlankSrcSpanFile NoBlankApiAnnotations
+                                                         (pm_parsed_source p)
+         anns'   = pm_annotations p
+         -- pped    = pragmas ++ "\n" ++ (exactPrint $ pm_parsed_source p)
+         pped    = exactPrint (pm_parsed_source p) anns'
+         -- pragmas = getPragmas anns'
+
+         newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
+         astFile = fileName <.> "ast"
+         newAstFile = fileName <.> "ast.new"
+
+       -- putStrLn $ "\n\nabout to writeFile"
+       writeFile astFile origAst
+       -- putStrLn $ "\n\nabout to pp"
+       writeFile newFile pped
+
+       -- putStrLn $ "anns':" ++ showPprUnsafe (apiAnnRogueComments anns')
+
+       p' <- parseOneFile libdir newFile
+
+       let newAstStr :: String
+           newAstStr = showSDocUnsafe
+                         $ showAstData BlankSrcSpanFile NoBlankApiAnnotations
+                                                         (pm_parsed_source p')
+       writeFile newAstFile newAstStr
+
+       -- putStrLn $ "\n\nanns':" ++ showPprUnsafe (apiAnnRogueComments anns')
+
+       if origAst == newAstStr
+         then do
+           -- putStrLn "ASTs matched"
+           exitSuccess
+         else do
+           putStrLn "exactPrint AST Match Failed"
+           putStrLn "\n===================================\nOrig\n\n"
+           putStrLn origAst
+           putStrLn "\n===================================\nNew\n\n"
+           putStrLn newAstStr
+           putStrLn "\n===================================\n\n"
+           exitFailure
+
+
+parseOneFile :: FilePath -> FilePath -> IO ParsedModule
+parseOneFile libdir fileName = do
+       let modByFile m =
+             case ml_hs_file $ ms_location m of
+               Nothing -> False
+               Just fn -> fn == fileName
+       runGhc (Just libdir) $ do
+         dflags <- getSessionDynFlags
+         let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
+         _ <- setSessionDynFlags dflags2
+         addTarget Target { targetId = TargetFile fileName Nothing
+                          , targetAllowObjCode = True
+                          , targetContents = Nothing }
+         _ <- load LoadAllTargets
+         graph <- getModuleGraph
+         let
+           modSum = case filter modByFile (mgModSummaries graph) of
+                     [x] -> x
+                     xs -> error $ "Can't find module, got:"
+                              ++ show (map (ml_hs_file . ms_location) xs)
+         -- toks <- getRichTokenStream (ms_mod modSum)
+         -- toks <- getTokenStream (ms_mod modSum)
+         -- GHC.liftIO $ putStrLn $ "toks=" ++ showPprUnsafe toks
+         parseModule modSum
+
+-- getPragmas :: ApiAnns -> String
+-- getPragmas anns' = pragmaStr
+--   where
+--     tokComment (L _ (AnnBlockComment s)) = s
+--     tokComment (L _ (AnnLineComment  s)) = s
+--     tokComment _ = ""
+
+--     comments' = map tokComment $ sortRealLocated $ apiAnnRogueComments anns'
+--     pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
+--     pragmaStr = intercalate "\n" pragmas
+
+-- pp :: (Outputable a) => a -> String
+-- pp a = showPpr unsafeGlobalDynFlags a
+
+-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs
new file mode 100644
index 0000000000..403ee3e55d
--- /dev/null
+++ b/utils/check-exact/Parsers.hs
@@ -0,0 +1,332 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- This module rexposes wrapped parsers from the GHC API. Along with
+-- returning the parse result, the corresponding annotations are also
+-- returned such that it is then easy to modify the annotations and print
+-- the result.
+--
+----------------------------------------------------------------------------
+module Parsers (
+        -- * Utility
+          Parser
+        , ParseResult
+        , withDynFlags
+        , CppOptions(..)
+        , defaultCppOptions
+
+        -- * Module Parsers
+        , parseModule
+        , parseModuleFromString
+        , parseModuleWithOptions
+        , parseModuleWithCpp
+
+        -- * Basic Parsers
+        , parseExpr
+        , parseImport
+        , parseType
+        , parseDecl
+        , parsePattern
+        , parseStmt
+
+        , parseWith
+
+        -- * Internal
+
+        , ghcWrapper
+
+        , initDynFlags
+        , initDynFlagsPure
+        , parseModuleFromStringInternal
+        , parseModuleApiAnnsWithCpp
+        , parseModuleApiAnnsWithCppInternal
+        , postParseTransform
+        ) where
+
+-- import Language.Haskell.GHC.ExactPrint.Annotate
+-- import Language.Haskell.GHC.ExactPrint.Delta
+import Preprocess
+import Types
+
+import Control.Monad.RWS
+-- import Data.Data (Data)
+
+
+-- import GHC.Paths (libdir)
+
+import qualified GHC hiding (parseModule)
+import qualified Control.Monad.IO.Class as GHC
+import qualified GHC.Data.FastString    as GHC
+import qualified GHC.Data.StringBuffer  as GHC
+import qualified GHC.Driver.Config      as GHC
+import qualified GHC.Driver.Session     as GHC
+import qualified GHC.Parser             as GHC
+import qualified GHC.Parser.Header      as GHC
+import qualified GHC.Parser.Lexer       as GHC
+import qualified GHC.Parser.PostProcess as GHC
+import qualified GHC.Parser.Errors.Ppr  as GHC
+import qualified GHC.Types.SrcLoc       as GHC
+import qualified GHC.Utils.Error        as GHC
+
+import qualified GHC.LanguageExtensions as LangExt
+
+-- import qualified Data.Map as Map
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+{-# ANN module "HLint: ignore Redundant do" #-}
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+-- ---------------------------------------------------------------------
+
+-- | Wrapper function which returns Annotations along with the parsed
+-- element.
+parseWith :: GHC.DynFlags
+          -> FilePath
+          -> GHC.P w
+          -> String
+          -> ParseResult w
+parseWith dflags fileName parser s =
+  case runParser parser dflags fileName s of
+    GHC.PFailed pst                     -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+    GHC.POk (mkApiAnns -> apianns) pmod -> Right (apianns, pmod)
+
+
+parseWithECP :: (GHC.DisambECP w)
+          => GHC.DynFlags
+          -> FilePath
+          -> GHC.P GHC.ECP
+          -> String
+          -> ParseResult (GHC.LocatedA w)
+parseWithECP dflags fileName parser s =
+    -- case runParser ff dflags fileName s of
+    -- case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of
+    case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of
+      GHC.PFailed pst                     -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+      GHC.POk (mkApiAnns -> apianns) pmod -> Right (apianns, pmod)
+
+-- ---------------------------------------------------------------------
+
+runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
+runParser parser flags filename str = GHC.unP parser parseState
+    where
+      location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
+      buffer = GHC.stringToStringBuffer str
+      parseState = GHC.initParserState (GHC.initParserOpts flags) buffer location
+
+-- ---------------------------------------------------------------------
+
+-- | Provides a safe way to consume a properly initialised set of
+-- 'DynFlags'.
+--
+-- @
+-- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr)
+-- @
+withDynFlags :: FilePath -> (GHC.DynFlags -> a) -> IO a
+withDynFlags libdir action = ghcWrapper libdir $ do
+  dflags <- GHC.getSessionDynFlags
+  void $ GHC.setSessionDynFlags dflags
+  return (action dflags)
+
+-- ---------------------------------------------------------------------
+
+parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule)
+parseFile = runParser GHC.parseModule
+
+-- ---------------------------------------------------------------------
+
+type ParseResult a = Either GHC.ErrorMessages (GHC.ApiAnns, a)
+
+type Parser a = GHC.DynFlags -> FilePath -> String
+                -> ParseResult a
+
+parseExpr :: Parser (GHC.LHsExpr GHC.GhcPs)
+parseExpr df fp = parseWithECP df fp GHC.parseExpression
+
+parseImport :: Parser (GHC.LImportDecl GHC.GhcPs)
+parseImport df fp = parseWith df fp GHC.parseImport
+
+parseType :: Parser (GHC.LHsType GHC.GhcPs)
+parseType df fp = parseWith df fp GHC.parseType
+
+-- safe, see D1007
+parseDecl :: Parser (GHC.LHsDecl GHC.GhcPs)
+parseDecl df fp = parseWith df fp GHC.parseDeclaration
+
+parseStmt :: Parser (GHC.ExprLStmt GHC.GhcPs)
+parseStmt df fp = parseWith df fp GHC.parseStatement
+
+parsePattern :: Parser (GHC.LPat GHC.GhcPs)
+parsePattern df fp = parseWith df fp GHC.parsePattern
+
+-- ---------------------------------------------------------------------
+--
+
+-- | This entry point will also work out which language extensions are
+-- required and perform CPP processing if necessary.
+--
+-- @
+-- parseModule = parseModuleWithCpp defaultCppOptions
+-- @
+--
+-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs')
+parseModule :: FilePath -> FilePath -> IO (ParseResult GHC.ParsedSource)
+parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file
+
+
+-- | This entry point will work out which language extensions are
+-- required but will _not_ perform CPP processing.
+-- In contrast to `parseModoule` the input source is read from the provided
+-- string; the `FilePath` parameter solely exists to provide a name
+-- in source location annotations.
+parseModuleFromString
+  :: FilePath -- GHC libdir
+  -> FilePath
+  -> String
+  -> IO (ParseResult GHC.ParsedSource)
+parseModuleFromString libdir fp s = ghcWrapper libdir $ do
+  dflags <- initDynFlagsPure fp s
+  return $ parseModuleFromStringInternal dflags fp s
+
+-- | Internal part of 'parseModuleFromString'.
+parseModuleFromStringInternal :: Parser GHC.ParsedSource
+parseModuleFromStringInternal dflags fileName str =
+  let (str1, lp) = stripLinePragmas str
+      res        = case runParser GHC.parseModule dflags fileName str1 of
+        GHC.PFailed pst     -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+        GHC.POk     x  pmod -> Right (mkApiAnns x, lp, dflags, pmod)
+  in  postParseTransform res
+
+parseModuleWithOptions :: FilePath -- ^ GHC libdir
+                       -> FilePath
+                       -> IO (ParseResult GHC.ParsedSource)
+parseModuleWithOptions libdir fp =
+  parseModuleWithCpp libdir defaultCppOptions fp
+
+
+-- | Parse a module with specific instructions for the C pre-processor.
+parseModuleWithCpp
+  :: FilePath -- ^ GHC libdir
+  -> CppOptions
+  -> FilePath -- ^ File to be parsed
+  -> IO (ParseResult GHC.ParsedSource)
+parseModuleWithCpp libdir cpp fp = do
+  res <- parseModuleApiAnnsWithCpp libdir cpp fp
+  return $ postParseTransform res
+
+-- ---------------------------------------------------------------------
+
+-- | Low level function which is used in the internal tests.
+-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of
+-- this function.
+parseModuleApiAnnsWithCpp
+  :: FilePath -- ^ GHC libdir
+  -> CppOptions
+  -> FilePath -- ^ File to be parsed
+  -> IO
+       ( Either
+           GHC.ErrorMessages
+           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
+       )
+parseModuleApiAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do
+  dflags <- initDynFlags file
+  parseModuleApiAnnsWithCppInternal cppOptions dflags file
+
+-- | Internal function. Default runner of GHC.Ghc action in IO.
+ghcWrapper :: FilePath -> GHC.Ghc a -> IO a
+ghcWrapper libdir a =
+  GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
+    $ GHC.runGhc (Just libdir) a
+
+-- | Internal function. Exposed if you want to muck with DynFlags
+-- before parsing.
+parseModuleApiAnnsWithCppInternal
+  :: GHC.GhcMonad m
+  => CppOptions
+  -> GHC.DynFlags
+  -> FilePath
+  -> m
+       ( Either
+           GHC.ErrorMessages
+           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
+       )
+parseModuleApiAnnsWithCppInternal cppOptions dflags file = do
+  let useCpp = GHC.xopt LangExt.Cpp dflags
+  (fileContents, injectedComments, dflags') <-
+    if useCpp
+      then do
+        (contents,dflags1) <- getPreprocessedSrcDirect cppOptions file
+        cppComments <- getCppTokensAsComments cppOptions file
+        return (contents,cppComments,dflags1)
+      else do
+        txt <- GHC.liftIO $ readFileGhc file
+        let (contents1,lp) = stripLinePragmas txt
+        return (contents1,lp,dflags)
+  return $
+    case parseFile dflags' file fileContents of
+      GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+      GHC.POk (mkApiAnns -> apianns) pmod  ->
+        Right $ (apianns, injectedComments, dflags', pmod)
+
+-- | Internal function. Exposed if you want to muck with DynFlags
+-- before parsing. Or after parsing.
+postParseTransform
+  :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
+  -> Either a (GHC.ApiAnns, GHC.ParsedSource)
+postParseTransform parseRes = fmap mkAnns parseRes
+  where
+    mkAnns (apianns, _cs, _, m) = (apianns, m)
+      -- (relativiseApiAnnsWithOptions opts cs m apianns, m)
+
+-- | Internal function. Initializes DynFlags value for parsing.
+--
+-- Passes "-hide-all-packages" to the GHC API to prevent parsing of
+-- package environment files. However this only works if there is no
+-- invocation of `setSessionDynFlags` before calling `initDynFlags`.
+-- See ghc tickets #15513, #15541.
+initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags
+initDynFlags file = do
+  dflags0         <- GHC.getSessionDynFlags
+  src_opts        <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file
+  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts
+  -- Turn this on last to avoid T10942
+  let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
+  -- Prevent parsing of .ghc.environment.* "package environment files"
+  (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
+    dflags2
+    [GHC.noLoc "-hide-all-packages"]
+  _ <- GHC.setSessionDynFlags dflags3
+  return dflags3
+
+-- | Requires GhcMonad constraint because there is
+-- no pure variant of `parseDynamicFilePragma`. Yet, in constrast to
+-- `initDynFlags`, it does not (try to) read the file at filepath, but
+-- solely depends on the module source in the input string.
+--
+-- Passes "-hide-all-packages" to the GHC API to prevent parsing of
+-- package environment files. However this only works if there is no
+-- invocation of `setSessionDynFlags` before calling `initDynFlagsPure`.
+-- See ghc tickets #15513, #15541.
+initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags
+initDynFlagsPure fp s = do
+  -- 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.
+  dflags0 <- GHC.getSessionDynFlags
+  let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp
+  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo
+  -- Turn this on last to avoid T10942
+  let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
+  -- Prevent parsing of .ghc.environment.* "package environment files"
+  (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
+    dflags2
+    [GHC.noLoc "-hide-all-packages"]
+  _ <- GHC.setSessionDynFlags dflags3
+  return dflags3
+
+-- ---------------------------------------------------------------------
+
+mkApiAnns :: GHC.PState -> GHC.ApiAnns
+mkApiAnns pstate
+  = GHC.ApiAnns {
+        GHC.apiAnnRogueComments = GHC.comment_q pstate
+     }
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
new file mode 100644
index 0000000000..aa474df2b1
--- /dev/null
+++ b/utils/check-exact/Preprocess.hs
@@ -0,0 +1,312 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | This module provides support for CPP, interpreter directives and line
+-- pragmas.
+module Preprocess
+   (
+     stripLinePragmas
+   , getCppTokensAsComments
+   , getPreprocessedSrcDirect
+   , readFileGhc
+
+   , CppOptions(..)
+   , defaultCppOptions
+   ) where
+
+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     as GHC
+import qualified GHC.Driver.Env        as GHC
+import qualified GHC.Driver.Phases     as GHC
+import qualified GHC.Driver.Pipeline   as GHC
+import qualified GHC.Fingerprint.Type  as GHC
+import qualified GHC.Parser.Errors.Ppr as GHC
+import qualified GHC.Parser.Lexer      as GHC
+import qualified GHC.Settings          as GHC
+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 GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)
+import GHC.Data.FastString (mkFastString)
+
+import Data.List hiding (find)
+import Data.Maybe
+import Types
+import Utils
+import qualified Data.Set as Set
+
+
+-- import Debug.Trace
+--
+{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
+{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
+
+-- ---------------------------------------------------------------------
+
+data CppOptions = CppOptions
+                { cppDefine :: [String]    -- ^ CPP #define macros
+                , cppInclude :: [FilePath] -- ^ CPP Includes directory
+                , cppFile :: [FilePath]    -- ^ CPP pre-include file
+                }
+
+defaultCppOptions :: CppOptions
+defaultCppOptions = CppOptions [] [] []
+
+-- ---------------------------------------------------------------------
+-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments.
+stripLinePragmas :: String -> (String, [Comment])
+stripLinePragmas = unlines' . unzip . findLines . lines
+  where
+    unlines' (a, b) = (unlines a, catMaybes b)
+
+findLines :: [String] -> [(String, Maybe Comment)]
+findLines = zipWith checkLine [1..]
+
+checkLine :: Int -> String -> (String, Maybe Comment)
+checkLine line s
+  |  "{-# LINE" `isPrefixOf` s =
+       let (pragma, res) = getPragma s
+           size   = length pragma
+           mSrcLoc = mkSrcLoc (mkFastString "LINE")
+           ss     = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))
+       in (res, Just $ mkComment pragma (GHC.spanAsAnchor 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 $ mkComment s (GHC.spanAsAnchor ss))
+  | otherwise = (s, Nothing)
+
+getPragma :: String -> (String, String)
+getPragma [] = error "Input must not be empty"
+getPragma s@(x:xs)
+  | "#-}" `isPrefixOf` s = ("#-}", "   " ++ drop 3 s)
+  | otherwise =
+      let (prag, remline) = getPragma xs
+      in (x:prag, ' ':remline)
+
+-- ---------------------------------------------------------------------
+
+-- | Replacement for original 'getRichTokenStream' which will return
+-- the tokens for a file processed by CPP.
+-- See bug <http://ghc.haskell.org/trac/ghc/ticket/8265>
+getCppTokensAsComments :: GHC.GhcMonad m
+                       => CppOptions  -- ^ Preprocessor Options
+                       -> FilePath    -- ^ Path to source file
+                       -> m [Comment]
+getCppTokensAsComments cppOptions sourceFile = do
+  source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile
+  let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1
+  (_txt,strSrcBuf,flags2') <- getPreprocessedSrcDirectPrim cppOptions sourceFile
+  let flags2 = GHC.initParserOpts flags2'
+  -- hash-ifdef tokens
+  directiveToks <- GHC.liftIO $ getPreprocessorAsComments sourceFile
+  -- Tokens without hash-ifdef
+  nonDirectiveToks <- tokeniseOriginalSrc startLoc flags2 source
+  case GHC.lexTokenStream flags2 strSrcBuf startLoc of
+        GHC.POk _ ts ->
+               do
+                  let toks = GHC.addSourceToTokens startLoc source ts
+                      cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks
+                  return $ filter goodComment
+                         $  map (tokComment . GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks
+        GHC.PFailed pst -> parseError pst
+
+goodComment :: Comment -> Bool
+goodComment (Comment "" _ _) = False
+goodComment _              = True
+
+
+toRealLocated :: GHC.Located a -> GHC.RealLocated a
+toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s              x
+toRealLocated (GHC.L _ x)                     = GHC.L badRealSrcSpan x
+
+-- ---------------------------------------------------------------------
+
+-- | Combine the three sets of tokens to produce a single set that
+-- represents the code compiled, and will regenerate the original
+-- source file.
+-- [@directiveToks@] are the tokens corresponding to preprocessor
+--                   directives, converted to comments
+-- [@origSrcToks@] are the tokenised source of the original code, with
+--                 the preprocessor directives stripped out so that
+--                 the lexer  does not complain
+-- [@postCppToks@] are the tokens that the compiler saw originally
+-- NOTE: this scheme will only work for cpp in -nomacro mode
+getCppTokens ::
+     [(GHC.Located GHC.Token, String)]
+  -> [(GHC.Located GHC.Token, String)]
+  -> [(GHC.Located GHC.Token, String)]
+  -> [(GHC.Located GHC.Token, String)]
+getCppTokens directiveToks origSrcToks postCppToks = toks
+  where
+    locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare (rs l1) (rs l2)
+    m1Toks = mergeBy locFn postCppToks directiveToks
+
+    -- We must now find the set of tokens that are in origSrcToks, but
+    -- not in m1Toks
+
+    -- GHC.Token does not have Ord, can't use a set directly
+    origSpans = map (\(GHC.L l _,_) -> rs l) origSrcToks
+    m1Spans = map (\(GHC.L l _,_) -> rs l) m1Toks
+    missingSpans = Set.fromList origSpans Set.\\ Set.fromList m1Spans
+
+    missingToks = filter (\(GHC.L l _,_) -> Set.member (rs l) missingSpans) origSrcToks
+
+    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)
+
+    toks = mergeBy locFn directiveToks missingAsComments
+
+-- ---------------------------------------------------------------------
+
+tokeniseOriginalSrc ::
+  GHC.GhcMonad m
+  => GHC.RealSrcLoc -> GHC.ParserOpts -> GHC.StringBuffer
+  -> m [(GHC.Located GHC.Token, String)]
+tokeniseOriginalSrc startLoc flags buf = do
+  let src = stripPreprocessorDirectives buf
+  case GHC.lexTokenStream flags src startLoc of
+    GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts
+    GHC.PFailed pst -> parseError pst
+
+-- ---------------------------------------------------------------------
+
+-- | Strip out the CPP directives so that the balance of the source
+-- can tokenised.
+stripPreprocessorDirectives :: GHC.StringBuffer -> GHC.StringBuffer
+stripPreprocessorDirectives buf = buf'
+  where
+    srcByLine = lines $ sbufToString buf
+    noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine
+    buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines
+
+-- ---------------------------------------------------------------------
+
+sbufToString :: GHC.StringBuffer -> String
+sbufToString sb@(GHC.StringBuffer _buf len _cur) = GHC.lexemeToString sb len
+
+-- ---------------------------------------------------------------------
+getPreprocessedSrcDirect :: (GHC.GhcMonad m)
+                         => CppOptions
+                         -> FilePath
+                         -> m (String, GHC.DynFlags)
+getPreprocessedSrcDirect cppOptions src =
+    (\(s,_,d) -> (s,d)) <$> getPreprocessedSrcDirectPrim cppOptions src
+
+getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)
+                              => CppOptions
+                              -> FilePath
+                              -> m (String, GHC.StringBuffer, GHC.DynFlags)
+getPreprocessedSrcDirectPrim cppOptions src_fn = do
+  hsc_env <- GHC.getSession
+  let dfs = GHC.hsc_dflags hsc_env
+      new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }
+  -- (dflags', hspp_fn) <-
+  r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile))
+  case r of
+    Left err -> error $ showErrorMessages 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.ErrorMessages -> String
+showErrorMessages msgs = intercalate "\n" $ map show $ GHC.bagToList msgs
+
+injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
+injectCppOptions CppOptions{..} dflags =
+  foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile)
+  where
+    mkDefine = ("-D" ++)
+    mkIncludeDir = ("-I" ++)
+    mkInclude = ("-include" ++)
+
+
+addOptP :: String -> GHC.DynFlags -> GHC.DynFlags
+addOptP   f = alterToolSettings $ \s -> s
+          { GHC.toolSettings_opt_P   = f : GHC.toolSettings_opt_P s
+          , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s)
+          }
+alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags
+alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) }
+
+fingerprintStrings :: [String] -> GHC.Fingerprint
+fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss
+
+-- ---------------------------------------------------------------------
+
+-- | Get the preprocessor directives as comment tokens from the
+-- source.
+getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)]
+getPreprocessorAsComments srcFile = do
+  fcontents <- readFileGhc srcFile
+  let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')
+                    $ zip [1..] (lines fcontents)
+
+  let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line placeholderBufSpan),line)
+       where
+         start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1
+         end   = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line)
+         l = GHC.mkSrcSpan start end
+
+  let toks = map mkTok directives
+  return toks
+
+placeholderBufSpan :: GHC.PsSpan
+placeholderBufSpan = pspan
+  where
+    bl = GHC.BufPos 0
+    pspan = GHC.PsSpan GHC.placeholderRealSpan (GHC.BufSpan bl bl)
+
+-- ---------------------------------------------------------------------
+
+parseError :: (GHC.MonadIO m) => GHC.PState -> m b
+parseError pst = do
+     let
+       -- (warns,errs) = GHC.getMessages pst dflags
+     -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
+     GHC.throwErrors (fmap GHC.pprError (GHC.getErrorMessages pst))
+
+-- ---------------------------------------------------------------------
+
+readFileGhc :: FilePath -> IO String
+readFileGhc file = do
+  buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file
+  return (GHC.lexemeToString buf len)
+
+-- ---------------------------------------------------------------------
+
+-- Copied over from MissingH, the dependency cause travis to fail
+
+{- | Merge two sorted lists using into a single, sorted whole,
+allowing the programmer to specify the comparison function.
+
+QuickCheck test property:
+
+prop_mergeBy xs ys =
+    mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys)
+          where types = xs :: [ (Int, Int) ]
+                cmp (x1,_) (x2,_) = compare x1 x2
+-}
+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
+mergeBy _cmp [] ys = ys
+mergeBy _cmp xs [] = xs
+mergeBy cmp (allx@(x:xs)) (ally@(y:ys))
+        -- Ordering derives Eq, Ord, so the comparison below is valid.
+        -- Explanation left as an exercise for the reader.
+        -- Someone please put this code out of its misery.
+    | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally
+    | otherwise = y : mergeBy cmp allx ys
+
diff --git a/utils/check-exact/README b/utils/check-exact/README
new file mode 100644
index 0000000000..b27f0fbd55
--- /dev/null
+++ b/utils/check-exact/README
@@ -0,0 +1,24 @@
+
+This programme is intended to be used by any GHC developers working on
+the AST and/or pretty printer by providing a way to check that using
+exact print on the ParsedSource reproduces the original source.
+Except for stripping trailing whitespace on lines, and discarding
+tabs.
+
+This utility is also intended to be used in tests, so that when new features are
+added the ability to round-trip the AST via exact is tested.
+
+Usage
+
+In a test Makefile
+
+  $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs
+
+AZ: update the rest here
+See examples in (REPO_HOME)/testsuite/tests/printer/Makefile
+
+The utility generates the following files for ToBeTested.hs
+
+  - ToBeTested.ppr.hs      : the ppr result
+  - ToBeTested.hs.ast      : the AST of the original source
+  - ToBeTested.hs.ast.new  : the AST of the re-parsed ppr source
diff --git a/utils/check-exact/Test.hs b/utils/check-exact/Test.hs
new file mode 100644
index 0000000000..57c09cc737
--- /dev/null
+++ b/utils/check-exact/Test.hs
@@ -0,0 +1,840 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+import Data.List
+import Data.Data
+import GHC.Types.Name.Occurrence
+import GHC.Types.Name.Reader
+import GHC hiding (moduleName)
+import GHC.Driver.Ppr
+import GHC.Driver.Session
+import GHC.Hs.Dump
+import GHC.Data.Bag
+import System.Environment( getArgs )
+import System.Exit
+import System.FilePath
+
+import Types
+import Utils
+import ExactPrint
+import Transform
+import Parsers
+
+import GHC.Parser.Lexer
+import GHC.Data.FastString
+import GHC.Types.SrcLoc
+
+-- ---------------------------------------------------------------------
+
+_tt :: IO ()
+-- _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/epw/_build/stage1/lib"
+ "cases/RenameCase1.hs" changeRenameCase1
+ -- "cases/LayoutLet2.hs" changeLayoutLet2
+ -- "cases/LayoutLet3.hs" changeLayoutLet3
+ -- "cases/LayoutLet4.hs" changeLayoutLet3
+ -- "cases/Rename1.hs" changeRename1
+ -- "cases/Rename2.hs" changeRename2
+ -- "cases/LayoutIn1.hs" changeLayoutIn1
+ -- "cases/LayoutIn3.hs" changeLayoutIn3
+ -- "cases/LayoutIn3a.hs" changeLayoutIn3
+ -- "cases/LayoutIn3b.hs" changeLayoutIn3
+ -- "cases/LayoutIn4.hs" changeLayoutIn4
+ -- "cases/LocToName.hs" changeLocToName
+ -- "cases/LetIn1.hs" changeLetIn1
+ -- "cases/WhereIn4.hs" changeWhereIn4
+ -- "cases/AddDecl1.hs" changeAddDecl1
+ -- "cases/AddDecl2.hs" changeAddDecl2
+ -- "cases/AddDecl3.hs" changeAddDecl3
+ -- "cases/LocalDecls.hs" changeLocalDecls
+ -- "cases/LocalDecls2.hs" changeLocalDecls2
+ -- "cases/WhereIn3a.hs" changeWhereIn3a
+ -- "cases/WhereIn3b.hs" changeWhereIn3b
+ -- "cases/AddLocalDecl1.hs" addLocaLDecl1
+ -- "cases/AddLocalDecl2.hs" addLocaLDecl2
+ -- "cases/AddLocalDecl3.hs" addLocaLDecl3
+ -- "cases/AddLocalDecl4.hs" addLocaLDecl4
+ -- "cases/AddLocalDecl5.hs" addLocaLDecl5
+ -- "cases/AddLocalDecl6.hs" addLocaLDecl6
+ -- "cases/RmDecl1.hs" rmDecl1
+ -- "cases/RmDecl2.hs" rmDecl2
+ -- "cases/RmDecl3.hs" rmDecl3
+ -- "cases/RmDecl4.hs" rmDecl4
+ -- "cases/RmDecl5.hs" rmDecl5
+ -- "cases/RmDecl6.hs" rmDecl6
+ -- "cases/RmDecl7.hs" rmDecl7
+ -- "cases/RmTypeSig1.hs" rmTypeSig1
+ -- "cases/RmTypeSig2.hs" rmTypeSig2
+ -- "cases/AddHiding1.hs" addHiding1
+ -- "cases/AddHiding2.hs" addHiding2
+
+-- cloneT does not need a test, function can be retired
+
+
+-- exact = ppr
+
+changers :: [(String, Changer)]
+changers =
+  [("noChange", noChange)
+  ,("changeRenameCase1", changeRenameCase1)
+  ,("changeLayoutLet2",  changeLayoutLet2)
+  ,("changeLayoutLet3",  changeLayoutLet3)
+  ,("changeLayoutIn1",   changeLayoutIn1)
+  ,("changeLayoutIn3",   changeLayoutIn3)
+  ,("changeLayoutIn4",   changeLayoutIn4)
+  ,("changeLocToName",   changeLocToName)
+  ,("changeRename1",     changeRename1)
+  ,("changeRename2",     changeRename2)
+  ,("changeWhereIn4",    changeWhereIn4)
+  ,("changeLetIn1",      changeLetIn1)
+  ,("changeAddDecl1",    changeAddDecl1)
+  ,("changeAddDecl2",    changeAddDecl2)
+  ,("changeAddDecl3",    changeAddDecl3)
+  ,("changeLocalDecls",  changeLocalDecls)
+  ,("changeLocalDecls2", changeLocalDecls2)
+  ,("changeWhereIn3a",   changeWhereIn3a)
+  ,("changeWhereIn3b",   changeWhereIn3b)
+  ,("addLocaLDecl1",     addLocaLDecl1)
+  ,("addLocaLDecl2",     addLocaLDecl2)
+  ,("addLocaLDecl3",     addLocaLDecl3)
+  ,("addLocaLDecl4",     addLocaLDecl4)
+  ,("addLocaLDecl5",     addLocaLDecl5)
+  ,("addLocaLDecl6",     addLocaLDecl6)
+  ,("rmDecl1",           rmDecl1)
+  ,("rmDecl2",           rmDecl2)
+  ,("rmDecl3",           rmDecl3)
+  ,("rmDecl4",           rmDecl4)
+  ,("rmDecl5",           rmDecl5)
+  ,("rmDecl6",           rmDecl6)
+  ,("rmDecl7",           rmDecl7)
+  ,("rmTypeSig1",        rmTypeSig1)
+  ,("rmTypeSig2",        rmTypeSig2)
+  ,("addHiding1",        addHiding1)
+  ,("addHiding2",        addHiding2)
+  ,("addHiding2",        addHiding2)
+   ]
+
+-- ---------------------------------------------------------------------
+
+usage :: String
+usage = unlines
+    [ "usage: check-ppr (libdir) (file)"
+    , ""
+    , "where libdir is the GHC library directory (e.g. the output of"
+    , "ghc --print-libdir) and file is the file to parse."
+    ]
+
+main :: IO()
+main = do
+  args <- getArgs
+  case args of
+   [libdir,fileName] -> testOneFile changers libdir fileName noChange
+   _ -> putStrLn usage
+
+deriving instance Data Token
+deriving instance Data PsSpan
+deriving instance Data BufSpan
+deriving instance Data BufPos
+
+testOneFile :: [(String, Changer)] -> FilePath -> String -> Changer -> IO ()
+testOneFile _ libdir fileName changer = do
+       (p,_toks) <- parseOneFile libdir fileName
+       -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse toks)
+       let
+         origAst = ppAst (pm_parsed_source p)
+         anns'   = pm_annotations p
+         -- pped    = pragmas ++ "\n" ++ (exactPrint $ pm_parsed_source p)
+         pped    = exactPrint (pm_parsed_source p) anns'
+         -- pragmas = getPragmas anns'
+
+         newFile         = dropExtension fileName <.> "ppr"      <.> takeExtension fileName
+         newFileChanged  = dropExtension fileName <.> "changed"  <.> takeExtension fileName
+         newFileExpected = dropExtension fileName <.> "expected" <.> takeExtension fileName
+         astFile        = fileName <.> "ast"
+         newAstFile     = fileName <.> "ast.new"
+         changedAstFile = fileName <.> "ast.changed"
+
+       -- pped' <- exactprintWithChange changeRenameCase1 (pm_parsed_source p) anns'
+       (pped', ast') <- exactprintWithChange libdir changer (pm_parsed_source p) anns'
+       -- putStrLn $ "\n\nabout to writeFile"
+       writeFile changedAstFile (ppAst ast')
+       writeFile astFile origAst
+       -- putStrLn $ "\n\nabout to pp"
+       writeFile newFile        pped
+       writeFile newFileChanged pped'
+
+       -- putStrLn $ "anns':" ++ showPprUnsafe (apiAnnRogueComments anns')
+
+       (p',_) <- parseOneFile libdir newFile
+
+       let newAstStr :: String
+           newAstStr = ppAst (pm_parsed_source p')
+       writeFile newAstFile newAstStr
+       expectedSource <- readFile newFileExpected
+       changedSource  <- readFile newFileChanged
+
+       -- putStrLn $ "\n\nanns':" ++ showPprUnsafe (apiAnnRogueComments anns')
+
+       let
+         origAstOk       = origAst == newAstStr
+         changedSourceOk = expectedSource == changedSource
+       if origAstOk && changedSourceOk
+         then do
+           -- putStrLn "ASTs matched"
+           exitSuccess
+         else if not origAstOk
+           then do
+             putStrLn "AST Match Failed"
+             -- putStrLn "\n===================================\nOrig\n\n"
+             -- putStrLn origAst
+             putStrLn "\n===================================\nNew\n\n"
+             putStrLn newAstStr
+             exitFailure
+           else do
+             putStrLn "Changed AST Source Mismatch"
+             putStrLn "\n===================================\nExpected\n\n"
+             putStrLn expectedSource
+             putStrLn "\n===================================\nChanged\n\n"
+             putStrLn changedSource
+             putStrLn "\n===================================\n"
+             putStrLn $ show changedSourceOk
+             exitFailure
+
+ppAst :: Data a => a -> String
+ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankApiAnnotations ast
+
+parseOneFile :: FilePath -> FilePath -> IO (ParsedModule, [Located Token])
+parseOneFile libdir fileName = do
+       let modByFile m =
+             case ml_hs_file $ ms_location m of
+               Nothing -> False
+               Just fn -> fn == fileName
+       runGhc (Just libdir) $ do
+         dflags <- getSessionDynFlags
+         let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
+         _ <- setSessionDynFlags dflags2
+         addTarget Target { targetId = TargetFile fileName Nothing
+                          , targetAllowObjCode = True
+                          , targetContents = Nothing }
+         _ <- load LoadAllTargets
+         graph <- getModuleGraph
+         let
+           modSum = case filter modByFile (mgModSummaries graph) of
+                     [x] -> x
+                     xs -> error $ "Can't find module, got:"
+                              ++ show (map (ml_hs_file . ms_location) xs)
+         pm <- GHC.parseModule modSum
+         toks <- getTokenStream (ms_mod modSum)
+         return (pm, toks)
+
+         -- getTokenStream :: GhcMonad m => Module -> m [Located Token]
+
+-- getPragmas :: ApiAnns -> String
+-- getPragmas anns' = pragmaStr
+--   where
+--     tokComment (L _ (AnnBlockComment s)) = s
+--     tokComment (L _ (AnnLineComment  s)) = s
+--     tokComment _ = ""
+
+--     comments' = map tokComment $ sortRealLocated $ apiAnnRogueComments anns'
+--     pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
+--     pragmaStr = intercalate "\n" pragmas
+
+-- pp :: (Outputable a) => a -> String
+-- pp a = showPpr unsafeGlobalDynFlags a
+
+-- ---------------------------------------------------------------------
+
+exactprintWithChange :: FilePath -> Changer -> ParsedSource -> ApiAnns -> IO (String, ParsedSource)
+exactprintWithChange libdir f p anns = do
+  debugM $ "exactprintWithChange:anns=" ++ showGhc (apiAnnRogueComments anns)
+  (anns',p') <- f libdir anns p
+  return (exactPrint p' anns', p')
+
+
+-- First param is libdir
+type Changer = FilePath -> (ApiAnns -> ParsedSource -> IO (ApiAnns,ParsedSource))
+
+noChange :: Changer
+noChange _libdir ans parsed = return (ans,parsed)
+
+changeRenameCase1 :: Changer
+changeRenameCase1 _libdir ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed)
+
+changeLayoutLet2 :: Changer
+changeLayoutLet2 _libdir ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed)
+
+changeLayoutLet3 :: Changer
+changeLayoutLet3 _libdir ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed)
+
+changeLayoutIn1 :: Changer
+changeLayoutIn1 _libdir ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed)
+
+changeLayoutIn3 :: Changer
+changeLayoutIn3 _libdir ans parsed = return (ans,rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed)
+
+changeLayoutIn4 :: Changer
+changeLayoutIn4 _libdir ans parsed = return (ans,rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed)
+
+changeLocToName :: Changer
+changeLocToName _libdir ans parsed = return (ans,rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed)
+
+
+changeRename1 :: Changer
+changeRename1 _libdir ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed)
+
+changeRename2 :: Changer
+changeRename2 _libdir ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed)
+
+rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a
+rename newNameStr spans' a
+  = everywhere (mkT replaceRdr) a
+  where
+    newName = mkRdrUnqual (mkVarOcc newNameStr)
+
+    cond :: SrcSpan -> Bool
+    cond ln = ss2range ln `elem` spans'
+
+    replaceRdr :: LocatedN RdrName -> LocatedN RdrName
+    replaceRdr (L ln _)
+        | cond (locA ln) = L ln newName
+    replaceRdr x = x
+
+-- ---------------------------------------------------------------------
+
+changeWhereIn4 :: Changer
+changeWhereIn4 _libdir ans parsed
+  = return (ans,everywhere (mkT replace) parsed)
+  where
+    replace :: LocatedN RdrName -> LocatedN RdrName
+    replace (L ln _n)
+      | ss2range (locA ln) == ((12,16),(12,17)) = L ln (mkRdrUnqual (mkVarOcc "p_2"))
+    replace x = x
+
+-- ---------------------------------------------------------------------
+
+changeLetIn1 :: Changer
+changeLetIn1 _libdir ans parsed
+  = return (ans,everywhere (mkT replace) parsed)
+  where
+    replace :: HsExpr GhcPs -> HsExpr GhcPs
+    replace (HsLet (ApiAnn anc (AnnsLet l _i) cs) localDecls expr)
+      =
+         let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls
+             [l2,_l1] = map wrapDecl $ bagToList bagDecls
+             bagDecls' = listToBag $ concatMap decl2Bind [l2]
+             (L (SrcSpanAnn _ le) e) = expr
+             a = (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan le) (MovedAnchor (DP 0 1))) mempty noCom) le)
+             expr' = L a e
+         in (HsLet (ApiAnn anc (AnnsLet l (AD (DP 1 0))) cs) (HsValBinds x (ValBinds xv bagDecls' sigs)) expr')
+
+    replace x = x
+-- ---------------------------------------------------------------------
+
+-- | Add a declaration to AddDecl
+changeAddDecl1 :: Changer
+changeAddDecl1 libdir ans top = do
+  Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
+  let decl' = setEntryDP' decl (DP 2 0)
+
+  let (p',(_,_),_) = runTransform mempty doAddDecl
+      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
+      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
+      replaceTopLevelDecls m = insertAtStart m decl'
+  return (ans,p')
+
+-- ---------------------------------------------------------------------
+changeAddDecl2 :: Changer
+changeAddDecl2 libdir ans top = do
+  Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
+  let decl' = setEntryDP' decl (DP 2 0)
+  let top' = anchorEof top
+
+  let (p',(_,_),_) = runTransform mempty doAddDecl
+      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top'
+      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
+      replaceTopLevelDecls m = insertAtEnd m decl'
+  return (ans,p')
+
+-- ---------------------------------------------------------------------
+changeAddDecl3 :: Changer
+changeAddDecl3 libdir ans top = do
+  Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
+  let decl' = setEntryDP' decl (DP 2 0)
+
+  let (p',(_,_),_) = runTransform mempty doAddDecl
+      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
+      f d (l1:l2:ls) = l1:d:l2':ls
+        where
+          l2' = setEntryDP' l2 (DP 2 0)
+      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
+      replaceTopLevelDecls m = insertAt f m decl'
+  return (ans,p')
+
+-- ---------------------------------------------------------------------
+
+-- | Add a local declaration with signature to LocalDecl
+changeLocalDecls :: Changer
+changeLocalDecls libdir ans (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) (DP 1 0)
+  let  sig' = setEntryDP' (L ls sig)  (DP 0 0)
+  let (p',(_,_),_w) = runTransform mempty doAddLocal
+      doAddLocal = everywhereM (mkM replaceLocalBinds) p
+      replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
+                        -> Transform (LMatch GhcPs (LHsExpr GhcPs))
+      replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do
+        let oldDecls = sortLocatedA $ map wrapDecl (bagToList binds) ++ map wrapSig sigs
+        let decls = s:d:oldDecls
+        let oldDecls' = captureLineSpacing oldDecls
+        let oldBinds     = concatMap decl2Bind oldDecls'
+            (os:oldSigs) = concatMap decl2Sig  oldDecls'
+            os' = setEntryDP' os (DP 2 0)
+        let sortKey = captureOrder decls
+        let (ApiAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van
+        let van' = (ApiAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DP 1 4)))) a b c dd) cs)
+        let binds' = (HsValBinds van'
+                          (ValBinds sortKey (listToBag $ decl':oldBinds)
+                                          (sig':os':oldSigs)))
+        return (L lm (Match an mln pats (GRHSs noExtField rhs binds')))
+      replaceLocalBinds x = return x
+  return (ans,L l p')
+
+-- ---------------------------------------------------------------------
+
+-- | Add a local declaration with signature to LocalDecl, where there was no
+-- prior local decl. So it adds a "where" annotation.
+changeLocalDecls2 :: Changer
+changeLocalDecls2 libdir ans (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) (DP 1 0)
+  let  sig' = setEntryDP' (L ls  sig) (DP 0 2)
+  let (p',(_,_),_w) = runTransform mempty 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 (DP 1 2)))
+        let anc2 = (Anchor (rs newSpan) (MovedAnchor (DP 1 4)))
+        let an = ApiAnn anc
+                        (AnnList (Just anc2) Nothing Nothing
+                                 [(undeltaSpan (rs newSpan) AnnWhere (DP 0 0))] [])
+                        noCom
+        let decls = [s,d]
+        let sortKey = captureOrder decls
+        let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl'])
+                                    [sig']))
+        return (L lm (Match ma mln pats (GRHSs noExtField rhs binds)))
+      replaceLocalBinds x = return x
+  return (ans,L l p')
+
+-- ---------------------------------------------------------------------
+
+-- | Check that balanceCommentsList is idempotent
+changeWhereIn3a :: Changer
+changeWhereIn3a _libdir ans (L l p) = do
+  let decls0 = hsmodDecls p
+      (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
+      (_de0:_:de1:_d2:_) = decls
+  debugM $ unlines w
+  debugM $ "changeWhereIn3a:de1:" ++ showAst de1
+  let p2 = p { hsmodDecls = decls}
+  return (ans,L l p2)
+
+-- ---------------------------------------------------------------------
+
+changeWhereIn3b :: Changer
+changeWhereIn3b _libdir ans (L l p) = do
+  let decls0 = hsmodDecls p
+      (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
+      (de0:_:de1:d2:_) = decls
+      de0' = setEntryDP' de0 (DP 2 0)
+      de1' = setEntryDP' de1 (DP 2 0)
+      d2' = setEntryDP' d2 (DP 2 0)
+      decls' = d2':de1':de0':(tail decls)
+  debugM $ unlines w
+  debugM $ "changeWhereIn3b:de1':" ++ showAst de1'
+  let p2 = p { hsmodDecls = decls'}
+  return (ans,L l p2)
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl1 :: Changer
+addLocaLDecl1 libdir ans lp = do
+  Right (_, (L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
+  let decl' = setEntryDP' (L ld decl) (DP 1 4)
+      doAddLocal = do
+        (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
+  debugM $ "addLocaLDecl1:" ++ intercalate "\n" w
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl2 :: Changer
+addLocaLDecl2 libdir ans lp = do
+  Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
+  let
+      doAddLocal = do
+         (de1:d2:_) <- hsDecls lp
+         (de1'',d2') <- balanceComments de1 d2
+
+         (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
+           newDecl' <- transferEntryDP' d newDecl
+           let d' = setEntryDP' d (DP 1 0)
+           return ((newDecl':d':ds),Nothing)
+
+         replaceDecls lp [parent',d2']
+
+  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl3 :: Changer
+addLocaLDecl3 libdir ans lp = do
+  Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
+  -- Right (_, newDecl@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "jj = 2")
+  let
+      doAddLocal = do
+         (de1:d2:_) <- hsDecls lp
+         (de1'',d2') <- balanceComments de1 d2
+
+         (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
+           let newDecl' = setEntryDP' newDecl (DP 1 0)
+           return (((d:ds) ++ [newDecl']),Nothing)
+
+         replaceDecls (anchorEof lp) [parent',d2']
+
+  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl4 :: Changer
+addLocaLDecl4 libdir ans lp = do
+  Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
+  Right (_, newSig)  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")
+  -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp
+  let
+      doAddLocal = do
+         (parent:ds) <- hsDecls lp
+
+         let newDecl' = setEntryDP' newDecl (DP 1 0)
+         let newSig'  = setEntryDP' newSig  (DP 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
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl5 :: Changer
+addLocaLDecl5 _libdir ans lp = do
+  let
+      doAddLocal = do
+         decls <- hsDecls lp
+         [s1,de1,d2,d3] <- balanceCommentsList decls
+
+         let d3' = setEntryDP' d3 (DP 2 0)
+
+         (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do
+           let d2' = setEntryDP' d2 (DP 1 0)
+           return ([d2'],Nothing)
+         replaceDecls lp [s1,de1',d3']
+
+  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl6 :: Changer
+addLocaLDecl6 libdir ans lp = do
+  Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3")
+  let
+      newDecl' = setEntryDP' newDecl (DP 1 4)
+      doAddLocal = do
+        decls0 <- hsDecls lp
+        [de1'',d2] <- balanceCommentsList decls0
+
+        let de1 = captureMatchLineSpacing de1''
+        let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1
+        let [ma1,_ma2] = ms
+
+        (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do
+           return ((newDecl' : decls),Nothing)
+        replaceDecls lp [de1', d2]
+
+  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl1 :: Changer
+rmDecl1 _libdir ans lp = do
+  let doRmDecl = do
+         tlDecs0 <- hsDecls lp
+         tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0
+         let (de1:_s1:_d2:ds) = tlDecs
+
+         replaceDecls lp (de1:ds)
+
+  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl2 :: Changer
+rmDecl2 _libdir ans lp = do
+  let
+      doRmDecl = do
+        let
+          go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs)
+          go e@(GHC.L _ (GHC.HsLet{})) = do
+            decs0 <- hsDecls e
+            decs <- balanceCommentsList $ captureLineSpacing decs0
+            e' <- replaceDecls e (init decs)
+            return e'
+          go x = return x
+
+        everywhereM (mkM go) lp
+
+  let (lp',(_,_),_w) = runTransform mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl3 :: Changer
+rmDecl3 _libdir ans lp = do
+  let
+      doRmDecl = do
+         [de1,d2] <- hsDecls lp
+
+         (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do
+           let sd1' = setEntryDP' sd1 (DP 2 0)
+           return ([],Just sd1')
+
+         replaceDecls lp [de1',sd1,d2]
+
+  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl4 :: Changer
+rmDecl4 _libdir ans lp = do
+  let
+      doRmDecl = do
+         [de1] <- hsDecls lp
+
+         (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do
+           sd2' <- transferEntryDP' sd1 sd2
+
+           let sd1' = setEntryDP' sd1 (DP 2 0)
+           return ([sd2'],Just sd1')
+
+         replaceDecls (anchorEof lp) [de1',sd1]
+
+  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl5 :: Changer
+rmDecl5 _libdir ans lp = do
+  let
+      doRmDecl = do
+        let
+          go :: HsExpr GhcPs -> Transform (HsExpr GhcPs)
+          go (HsLet a lb expr) = do
+            decs <- hsDeclsValBinds lb
+            let dec = last decs
+            _ <- transferEntryDPT (head decs) dec
+            lb' <- replaceDeclsValbinds WithoutWhere lb [dec]
+            return (HsLet a lb' expr)
+          go x = return x
+
+        everywhereM (mkM go) lp
+
+  let (lp',(_,_),_w) = runTransform mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl6 :: Changer
+rmDecl6 _libdir ans lp = do
+  let
+      doRmDecl = do
+         [de1] <- hsDecls lp
+
+         (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do
+           let (ss1:_sd1:sd2:sds) = subDecs
+           sd2' <- transferEntryDP' ss1 sd2
+
+           return (sd2':sds,Nothing)
+
+         replaceDecls lp [de1']
+
+  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl7 :: Changer
+rmDecl7 _libdir ans lp = do
+  let
+      doRmDecl = do
+         tlDecs <- hsDecls lp
+         [s1,de1,d2,d3] <- balanceCommentsList tlDecs
+
+         d3' <- transferEntryDP' d2 d3
+
+         replaceDecls lp [s1,de1,d3']
+
+  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmTypeSig1 :: Changer
+rmTypeSig1 _libdir ans lp = do
+  let doRmDecl = do
+         tlDecs <- hsDecls lp
+         let (s0:de1:d2) = tlDecs
+             s1 = captureTypeSigSpacing s0
+             (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1
+         n2' <- transferEntryDP n1 n2
+         let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ)))
+         replaceDecls lp (s1':de1:d2)
+
+  let (lp',(_,_),_w) = runTransform mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+rmTypeSig2 :: Changer
+rmTypeSig2 _libdir ans lp = do
+  let doRmDecl = do
+         tlDecs <- hsDecls lp
+         let [de1] = tlDecs
+
+         (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do
+           d' <- transferEntryDPT s d
+           return ([d'],Nothing)
+         replaceDecls lp [de1']
+
+  let (lp',(_,_),_w) = runTransform mempty doRmDecl
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+addHiding1 :: Changer
+addHiding1 _libdir ans (L l p) = do
+  let doTransform = do
+        l0 <- uniqueSrcSpanT
+        l1 <- uniqueSrcSpanT
+        l2 <- uniqueSrcSpanT
+        let
+          [L li imp1,imp2] = hsmodImports p
+          n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))
+          n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))
+          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1)))
+          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2)))
+          impHiding = L (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan l0) m0)
+                                     (AnnList Nothing
+                                              (Just (AddApiAnn AnnOpenP  d1))
+                                              (Just (AddApiAnn AnnCloseP d0))
+                                              [(AddApiAnn AnnHiding d1)]
+                                              [])
+                                       noCom) l0) [v1,v2]
+          imp1' = imp1 { ideclHiding = Just (True,impHiding)}
+          p' = p { hsmodImports = [L li imp1',imp2]}
+        return (L l p')
+
+  let (lp',(_ans',_),_w) = runTransform mempty doTransform
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+-- ---------------------------------------------------------------------
+
+addHiding2 :: Changer
+addHiding2 _libdir ans (L l p) = do
+  let doTransform = do
+        l1 <- uniqueSrcSpanT
+        l2 <- uniqueSrcSpanT
+        let
+          [L li imp1] = hsmodImports p
+          Just (_,L lh ns) = ideclHiding imp1
+          lh' = (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan (locA lh)) m0)
+                                     (AnnList Nothing
+                                              (Just (AddApiAnn AnnOpenP  d1))
+                                              (Just (AddApiAnn AnnCloseP d0))
+                                              [(AddApiAnn AnnHiding d1)]
+                                              [])
+                                       noCom) (locA lh))
+          n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))
+          n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))
+          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1)))
+          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2)))
+          L ln n = last ns
+          n' = L (addComma ln) n
+          imp1' = imp1 { ideclHiding = Just (True,L lh' (init ns ++ [n',v1,v2]))}
+          p' = p { hsmodImports = [L li imp1']}
+        return (L l p')
+
+  let (lp',(_ans',_),_w) = runTransform mempty doTransform
+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
+  return (ans,lp')
+
+
+-- ---------------------------------------------------------------------
+-- From SYB
+
+-- | Apply transformation on each level of a tree.
+--
+-- Just like 'everything', this is stolen from SYB package.
+everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
+everywhere f = f . gmapT (everywhere f)
+
+-- | Create generic transformation.
+--
+-- Another function stolen from SYB package.
+mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)
+mkT f = case cast f of
+    Just f' -> f'
+    Nothing -> id
+
+-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
new file mode 100644
index 0000000000..2901356879
--- /dev/null
+++ b/utils/check-exact/Transform.hs
@@ -0,0 +1,1513 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Haskell.GHC.ExactPrint.Transform
+--
+-- This module is currently under heavy development, and no promises are made
+-- about API stability. Use with care.
+--
+-- We welcome any feedback / contributions on this, as it is the main point of
+-- the library.
+--
+-----------------------------------------------------------------------------
+module Transform
+        (
+        -- * The Transform Monad
+          Transform
+        , TransformT(..)
+        , hoistTransform
+        , runTransform
+        , runTransformT
+        , runTransformFrom
+        , runTransformFromT
+
+        -- * 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
+        , modifyValD
+        -- *** Utility, does not manage layout
+        , hsDeclsValBinds, replaceDeclsValbinds
+        , WithWhere(..)
+
+        -- ** New gen functions
+        , noAnnSrcSpanDP
+        , noAnnSrcSpanDP0
+        , noAnnSrcSpanDP1
+        , noAnnSrcSpanDPn
+        , d0, d1, dn
+        , m0, m1, mn
+        , addComma
+
+        -- ** Managing lists, Transform monad
+        , insertAt
+        , insertAtStart
+        , insertAtEnd
+        , insertAfter
+        , insertBefore
+
+        -- *** Low level operations used in 'HasDecls'
+        , balanceComments
+        , balanceCommentsList
+        , balanceCommentsList'
+        , balanceTrailingComments
+        , moveTrailingComments
+        , anchorEof
+
+        -- ** Managing lists, pure functions
+        , captureOrder
+        , captureLineSpacing
+        , captureMatchLineSpacing
+        , captureTypeSigSpacing
+
+        -- * Operations
+        , isUniqueSrcSpan
+
+        -- * Pure functions
+        , mergeAnns
+        , mergeAnnList
+        , setPrecedingLinesDecl
+        , setPrecedingLines
+        , getEntryDP
+        , setEntryDP
+        , setEntryDP'
+        , transferEntryDP
+        , transferEntryDP'
+        , addTrailingComma
+        , wrapSig, wrapDecl
+        , decl2Sig, decl2Bind
+        , deltaAnchor
+        ) where
+
+import Types
+import Utils
+
+import Control.Monad.RWS
+import qualified Control.Monad.Fail as Fail
+
+import GHC  hiding (parseModule, parsedSource)
+import GHC.Data.Bag
+import GHC.Data.FastString
+
+-- import qualified Data.Generics as SYB
+
+import Data.Data
+import Data.List
+import Data.Maybe
+
+import qualified Data.Map as Map
+
+import Data.Functor.Identity
+import Control.Monad.State
+import Control.Monad.Writer
+
+-- import Debug.Trace
+
+------------------------------------------------------------------------------
+-- Transformation of source elements
+
+-- | Monad type for updating the AST and managing the annotations at the same
+-- time. The W state is used to generate logging information if required.
+type Transform = TransformT Identity
+
+-- |Monad transformer version of 'Transform' monad
+newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a }
+                deriving (Monad,Applicative,Functor
+                         ,MonadReader ()
+                         ,MonadWriter [String]
+                         ,MonadState (Anns,Int)
+                         ,MonadTrans
+                         )
+
+instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where
+    fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg
+
+-- | 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
+
+runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String])
+runTransformT ans f = runTransformFromT 0 ans 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)
+
+-- |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)
+
+-- | Change inner monad of 'TransformT'.
+hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a
+hoistTransform nt (TransformT m) = TransformT (mapRWST nt m)
+
+-- |Log a string to the output of the Monad
+logTr :: (Monad m) => String -> TransformT m ()
+logTr str = tell [str]
+
+-- |Log a representation of the given AST with annotations to the output of the
+-- Monad
+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.
+uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan
+uniqueSrcSpanT = do
+  (an,col) <- get
+  put (an,col + 1 )
+  let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col
+  return $ mkSrcSpan pos pos
+
+-- |Test whether a given 'SrcSpan' was generated by 'uniqueSrcSpanT'
+isUniqueSrcSpan :: SrcSpan -> Bool
+isUniqueSrcSpan ss = srcSpanStartLine' ss == -1
+
+srcSpanStartLine' :: SrcSpan -> Int
+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.
+captureOrder :: [LocatedA b] -> AnnSortKey
+captureOrder ls = AnnSortKey $ map (rs . getLocA) ls
+
+-- ---------------------------------------------------------------------
+
+captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs
+captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f)))
+                       = L l (ValD x (FunBind a b (MG c (L d ms') e) f))
+    where
+      ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
+      ms' = captureLineSpacing ms
+captureMatchLineSpacing d = d
+
+captureLineSpacing :: Monoid t
+                   => [LocatedAn t e] -> [GenLocated (SrcSpanAnn' (ApiAnn' t)) e]
+captureLineSpacing [] = []
+captureLineSpacing [d] = [d]
+captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds)
+  where
+    (l1,_) = ss2pos $ rs $ getLocA de1
+    (l2,_) = ss2pos $ rs $ getLocA d2
+    d2' = setEntryDP' d2 (DP (l2-l1) 0)
+
+-- ---------------------------------------------------------------------
+
+captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs
+captureTypeSigSpacing (L l (SigD x (TypeSig (ApiAnn anc (AnnSig dc rs') cs) ns (HsWC xw ty))))
+  = (L l (SigD x (TypeSig (ApiAnn anc (AnnSig dc' rs') cs) ns (HsWC xw ty'))))
+  where
+    -- we want DPs for the distance from the end of the ns to the
+    -- AnnDColon, and to the start of the ty
+    AddApiAnn kw dca = dc
+    rd = case last ns of
+      L (SrcSpanAnn ApiAnnNotUsed   ll) _ -> realSrcSpan ll
+      L (SrcSpanAnn (ApiAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
+    -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r
+    dc' = case dca of
+      AR r -> AddApiAnn kw (AD $ ss2delta (ss2posEnd rd) r)
+      AD _ -> AddApiAnn kw dca
+
+    -- ---------------------------------
+
+    ty' :: LHsSigType GhcPs
+    ty' = case ty of
+      (L (SrcSpanAnn ApiAnnNotUsed    ll) b)
+        -> let
+             op = case dca of
+               AR r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))
+               AD _ -> MovedAnchor (DP 0 1)
+           in (L (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan ll) op) mempty noCom) ll) b)
+      (L (SrcSpanAnn (ApiAnn (Anchor r op) a c) ll) b)
+        -> let
+              op' = case op of
+                MovedAnchor _ -> op
+                _ -> case dca of
+                  AR dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r)
+                  AD _ -> MovedAnchor (DP 0 1)
+           in (L (SrcSpanAnn (ApiAnn (Anchor r op') a c) ll) b)
+
+captureTypeSigSpacing s = s
+
+-- ---------------------------------------------------------------------
+
+-- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does
+-- nothing to any annotations that may be attached to either of the elements.
+-- It is used as a utility function in 'replaceDecls'
+decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs]
+decl2Bind (L l (ValD _ s)) = [L l s]
+decl2Bind _                      = []
+
+-- |Pure function to convert a 'LSig' to a 'LHsBind'. This does
+-- nothing to any annotations that may be attached to either of the elements.
+-- It is used as a utility function in 'replaceDecls'
+decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs]
+decl2Sig (L l (SigD _ s)) = [L l s]
+decl2Sig _                = []
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'LSig' into a 'LHsDecl'
+wrapSig :: LSig GhcPs -> LHsDecl GhcPs
+wrapSig (L l s) = L l (SigD NoExtField s)
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'LHsBind' into a 'LHsDecl'
+wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
+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 (DP 0 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 :: (Data a,Monad m) => LocatedA a -> DeltaPos -> TransformT m ()
+setEntryDPT ast dp = do
+  modifyAnnsT (setEntryDP ast dp)
+
+-- ---------------------------------------------------------------------
+
+-- |'Transform' monad version of 'transferEntryDP'
+transferEntryDPT :: (Data a,Data b,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 ::  (Data a,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 :: (Data a) => LocatedA a -> Int -> Int -> Anns -> Anns
+setPrecedingLines ast n c anne = setEntryDP ast (DP 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  -> DP 0 0
+    Just ann -> annTrueEntryDelta ann
+
+-- ---------------------------------------------------------------------
+
+setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs
+setEntryDPDecl decl@(L _  (ValD x (FunBind a b (MG c (L d ms ) e) f))) dp
+                   = L l' (ValD x (FunBind a b (MG c (L d ms') e) f))
+    where
+      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
+
+-- ---------------------------------------------------------------------
+
+-- |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 ApiAnnNotUsed l) a) dp
+  = L (SrcSpanAnn
+           (ApiAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty noCom)
+           l) a
+setEntryDP' (L (SrcSpanAnn (ApiAnn (Anchor r _) an (AnnComments [])) l) a) dp
+  = L (SrcSpanAnn
+           (ApiAnn (Anchor r (MovedAnchor dp)) an (AnnComments []))
+           l) a
+setEntryDP' (L (SrcSpanAnn (ApiAnn (Anchor r _) an cs) l) a) dp
+  = case sort (priorComments cs) of
+      [] ->
+        L (SrcSpanAnn
+               (ApiAnn (Anchor r (MovedAnchor dp)) an cs)
+               l) a
+      (L ca c:cs') ->
+        L (SrcSpanAnn
+               (ApiAnn (Anchor r (MovedAnchor edp)) an cs'')
+               l) a
+              where
+                cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs')
+                lc = head $ reverse $ (L ca c:cs')
+                DP line col = ss2delta (ss2pos $ anchor $ getLoc lc) r
+                -- TODO: this adjustment by 1 happens all over the place. Generalise it
+                edp' = if line == 0 then DP line col
+                                    else DP line (col - 1)
+                edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
+                -- edp = if line == 0 then DP (line, col)
+                --                    else DP (line, col - 1)
+
+-- |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 -> Anns -> Anns
+setEntryDP _ast _dp anns = anns
+
+-- ---------------------------------------------------------------------
+
+addAnnAnchorDelta :: LayoutStartCol -> RealSrcSpan -> AnnAnchor -> AnnAnchor
+addAnnAnchorDelta _off _anc (AD d) = AD d
+addAnnAnchorDelta  off  anc (AR r)
+  = AD (adjustDeltaForOffset 0 off (ss2deltaEnd anc r))
+
+-- Set the entry DP for an element coming after an existing keyword annotation
+setEntryDPFromAnchor :: LayoutStartCol -> AnnAnchor -> LocatedA t -> LocatedA t
+setEntryDPFromAnchor _off (AD _) (L la a) = L la a
+setEntryDPFromAnchor  off (AR anc) ll@(L la _) = setEntryDP' ll dp'
+  where
+    r = case la of
+      (SrcSpanAnn ApiAnnNotUsed l) -> realSrcSpan l
+      (SrcSpanAnn (ApiAnn (Anchor r' _) _ _) _) -> r'
+    dp' = adjustDeltaForOffset 0 off (ss2deltaEnd anc r)
+
+-- ---------------------------------------------------------------------
+
+-- -- |When setting an entryDP, the leading comment needs to be adjusted too
+-- setCommentEntryDP :: Annotation -> DeltaPos -> Annotation
+-- -- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann'
+-- setCommentEntryDP ann dp = ann'
+--   where
+--     ann' = case (annPriorComments ann) of
+--       [] -> ann
+--       [(pc,_)]     -> ann { annPriorComments = [(pc,dp)] }
+--       ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) }
+
+-- ---------------------------------------------------------------------
+
+-- |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 (L (SrcSpanAnn ApiAnnNotUsed l1) _) (L (SrcSpanAnn ApiAnnNotUsed _) b) = do
+  logTr $ "transferEntryDP': ApiAnnNotUsed,ApiAnnNotUsed"
+  return (L (SrcSpanAnn ApiAnnNotUsed l1) b)
+transferEntryDP (L (SrcSpanAnn (ApiAnn anc _an cs) _l1) _) (L (SrcSpanAnn ApiAnnNotUsed l2) b) = do
+  logTr $ "transferEntryDP': ApiAnn,ApiAnnNotUsed"
+  return (L (SrcSpanAnn (ApiAnn anc mempty cs) l2) b)
+transferEntryDP (L (SrcSpanAnn (ApiAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (ApiAnn _anc2 an2 cs2) l2) b) = do
+  logTr $ "transferEntryDP': ApiAnn,ApiAnn"
+  -- Problem: if the original had preceding comments, blindly
+  -- transferring the location is not correct
+  case priorComments cs1 of
+    [] -> return (L (SrcSpanAnn (ApiAnn anc1 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 (ApiAnn (kludgeAnchor anc) an2 cs2) l2) b)
+transferEntryDP (L (SrcSpanAnn ApiAnnNotUsed _l1) _) (L (SrcSpanAnn (ApiAnn anc2 an2 cs2) l2) b) = do
+  logTr $ "transferEntryDP': ApiAnnNotUsed,ApiAnn"
+  return (L (SrcSpanAnn (ApiAnn anc2' an2 cs2) l2) b)
+    where
+      anc2' = case anc2 of
+        Anchor _a op   -> Anchor (realSrcSpan l2) op
+
+-- |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
+transferEntryDP' :: (Monad m) => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs)
+transferEntryDP' la lb = do
+  (L l2 b) <- transferEntryDP la lb
+  return (L l2 (pushDeclDP b (DP 0 0)))
+
+-- There is an off-by-one in DPs. I *think* it has to do wether we
+-- calculate the final position when applying it against the stored
+-- final pos or against another RealSrcSpan.  Must get to the bottom
+-- of it and come up with a canonical DP.  This function adjusts a
+-- "comment space" DP to a "enterAnn" space one
+kludgeAnchor :: Anchor -> Anchor
+kludgeAnchor a@(Anchor _ (MovedAnchor (DP 0 _))) = a
+kludgeAnchor (Anchor a (MovedAnchor (DP r c))) = (Anchor a (MovedAnchor (DP r (c - 1))))
+kludgeAnchor a = a
+
+pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs
+pushDeclDP (ValD x (FunBind a b (MG c (L d  ms ) e) f)) dp
+          = ValD x (FunBind a b (MG c (L d' ms') e) f)
+    where
+      L d' _ = setEntryDP' (L d ms) dp
+      ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
+      ms' = case ms of
+        [] -> []
+        (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
+  (a',b') <- balanceComments a b
+  r <- balanceCommentsList (b':ls)
+  return (a':r)
+
+-- |The relatavise phase puts all comments appearing between the end of one AST
+-- item and the beginning of the next as 'annPriorComments' for the second one.
+-- This function takes two adjacent AST items and moves any 'annPriorComments'
+-- from the second one to the 'annFollowingComments' of the first if they belong
+-- to it instead. This is typically required before deleting or duplicating
+-- either of the AST elements.
+balanceComments :: (Monad m)
+  => LHsDecl GhcPs -> LHsDecl GhcPs
+  -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs)
+balanceComments first second = do
+  -- ++AZ++ : replace the nested casts with appropriate gmapM
+  -- 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
+      return (L l' (ValD x fb'), second')
+    _ -> balanceComments' first second
+
+-- |Once 'balanceComments' has been called to move trailing comments to a
+-- 'FunBind', these need to be pushed down from the top level to the last
+-- 'Match' if that 'Match' needs to be manipulated.
+balanceCommentsFB :: (Data b,Monad m)
+  => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b)
+balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do
+  logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf)
+  matches' <- balanceCommentsList' matches
+  let (m,ms) = case reverse matches' of
+                 (m':ms') -> (m',ms')
+                 _ -> error "balanceCommentsFB"
+  (m',second') <- balanceComments' m second
+  m'' <- balanceCommentsMatch m'
+  logTr $ "balanceCommentsMatch done"
+  return (L lf (FunBind x n (MG mx (L lm (reverse (m'':ms))) o) t), second')
+balanceCommentsFB f s = balanceComments' f s
+
+-- | Move comments on the same line as the end of the match into the
+-- GRHS, prior to the binds
+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: (l'', grhss')=" ++ showAst (l'', grhss')
+  return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds')))
+  where
+    simpleBreak (r,_) = r /= 0
+    (SrcSpanAnn an1 _loc1) = l
+    anc1 = addCommentOrigDeltas $ apiAnnComments an1
+    cs1f = getFollowingComments anc1
+    -- (move',stay') = break simpleBreak (commentsDeltas (anchorFromLocatedA (L l ())) cs1f)
+    (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f)
+    move = map snd move'
+    stay = map snd stay'
+    (l'', grhss', binds', logInfo)
+      = case reverse grhss of
+          [] -> (l, [], binds, (AnnComments [], SrcSpanAnn ApiAnnNotUsed noSrcSpan))
+          (L lg g@(GRHS ApiAnnNotUsed _grs _rhs):gs) -> (l, reverse (L lg g:gs), binds, (AnnComments [], SrcSpanAnn ApiAnnNotUsed noSrcSpan))
+          (L lg (GRHS ag grs rhs):gs) ->
+            let
+              anc1' = setFollowingComments anc1 stay
+              an1' = setCommentsSrcAnn l anc1'
+
+              -- ---------------------------------
+              (moved,bindsm) = pushTrailingComments WithWhere (AnnCommentsBalanced [] move) binds
+              -- ---------------------------------
+
+              (ApiAnn anc an lgc) = ag
+              lgc' = splitComments (realSrcSpan lg) $ addCommentOrigDeltas lgc
+              ag' = if moved
+                      then ApiAnn anc an lgc'
+                      else ApiAnn anc an (lgc' <> (AnnCommentsBalanced [] move))
+              -- ag' = ApiAnn anc an lgc'
+
+            in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1'))
+
+pushTrailingComments :: WithWhere -> ApiAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs)
+pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b)
+pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds"
+pushTrailingComments w cs lb@(HsValBinds an _)
+  = (True, HsValBinds an' vb)
+  where
+    (decls, _, _ws1) = runTransform mempty (hsDeclsValBinds lb)
+    (an', decls') = case reverse decls of
+      [] -> (addCommentsToApiAnn (spanHsLocaLBinds lb) an cs, decls)
+      (L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds)
+    (vb,_ws2) = case runTransform mempty (replaceDeclsValbinds w lb decls') of
+      ((HsValBinds _ vb'), _, ws2') -> (vb', ws2')
+      _ -> (ValBinds NoAnnSortKey emptyBag [], [])
+
+
+balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a]
+balanceCommentsList' [] = return []
+balanceCommentsList' [x] = return [x]
+balanceCommentsList' (a:b:ls) = do
+  logTr $ "balanceCommentsList' entered"
+  (a',b') <- balanceComments' a b
+  r <- balanceCommentsList' (b':ls)
+  return (a':r)
+
+-- |Prior to moving an AST element, make sure any trailing comments belonging to
+-- it are attached to it, and not the following element. Of necessity this is a
+-- heuristic process, to be tuned later. Possibly a variant should be provided
+-- with a passed-in decision function.
+-- The initial situation is that all comments for a given anchor appear as prior comments
+-- Many of these should in fact be following comments for the previous anchor
+balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b)
+balanceComments' la1 la2 = do
+  logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2)
+  logTr $ "balanceComments': (anchorFromLocatedA la1)=" ++ showGhc (anchorFromLocatedA la1)
+  logTr $ "balanceComments': (sort cs2b)=" ++ showAst (sort cs2b)
+  logTr $ "balanceComments': (move',stay')=" ++ showAst (move',stay')
+  logTr $ "balanceComments': (move'',stay'')=" ++ showAst (move'',stay'')
+  logTr $ "balanceComments': (move,stay)=" ++ showAst (move,stay)
+  return (la1', la2')
+  where
+    simpleBreak n (r,_) = r > n
+    L (SrcSpanAnn an1 loc1) f = la1
+    L (SrcSpanAnn an2 loc2) s = la2
+    anc1 = addCommentOrigDeltas $ apiAnnComments an1
+    anc2 = addCommentOrigDeltas $ apiAnnComments an2
+    cs1f = getFollowingComments anc1
+    cs2b = priorComments anc2
+    (stay'',move') = break (simpleBreak 1) (priorCommentsDeltas (anchorFromLocatedA la2) cs2b)
+    -- 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 = map snd (move'' ++ move')
+    stay = map snd stay'
+    cs1 = setFollowingComments anc1 (sort $ cs1f ++ move)
+    cs2 = setPriorComments anc2 stay
+
+    an1' = setCommentsSrcAnn (getLoc la1) cs1
+    an2' = setCommentsSrcAnn (getLoc la2) cs2
+    la1' = L an1' f
+    la2' = L an2' s
+
+-- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start
+trailingCommentsDeltas :: RealSrcSpan -> [LAnnotationComment]
+               -> [(Int, LAnnotationComment)]
+trailingCommentsDeltas _ [] = []
+trailingCommentsDeltas anc (la@(L l _):las)
+  = deltaComment anc la : trailingCommentsDeltas (anchor l) las
+  where
+    deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+      where
+        (al,_) = ss2posEnd anc'
+        (ll,_) = ss2pos (anchor loc)
+
+-- AZ:TODO: this is identical to commentsDeltas
+priorCommentsDeltas :: RealSrcSpan -> [LAnnotationComment]
+                    -> [(Int, LAnnotationComment)]
+priorCommentsDeltas anc cs = go anc (reverse $ sort cs)
+  where
+    go :: RealSrcSpan -> [LAnnotationComment] -> [(Int, LAnnotationComment)]
+    go _ [] = []
+    go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las
+
+    deltaComment :: RealSrcSpan -> LAnnotationComment -> (Int, LAnnotationComment)
+    deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+      where
+        (al,_) = ss2pos anc'
+        (ll,_) = ss2pos (anchor loc)
+
+
+-- | Split comments into ones occuring before the end of the reference
+-- span, and those after it.
+splitComments :: RealSrcSpan -> ApiAnnComments -> ApiAnnComments
+splitComments p (AnnComments cs) = cs'
+  where
+    cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p
+    (before, after) = break cmp cs
+    cs' = case after of
+      [] -> AnnComments cs
+      _ -> AnnCommentsBalanced before after
+splitComments p (AnnCommentsBalanced cs ts) = AnnCommentsBalanced cs' ts'
+  where
+    cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p
+    (before, after) = break cmp cs
+    cs' = before
+    ts' = after <> ts
+
+-- | A GHC comment includes the span of the preceding (non-comment)
+-- token.  Takes an original list of comments, and converts the
+-- 'Anchor's to have a have a `MovedAnchor` operation based on the
+-- original locations.
+commentOrigDeltas :: [LAnnotationComment] -> [LAnnotationComment]
+commentOrigDeltas [] = []
+commentOrigDeltas lcs@(L _ (GHC.AnnComment _ pt):_) = go pt lcs
+  -- TODO:AZ: we now have deltas wrt *all* tokens, not just preceding
+  -- non-comment. Simplify this.
+  where
+    go :: RealSrcSpan -> [LAnnotationComment] -> [LAnnotationComment]
+    go _ [] = []
+    go p (L (Anchor la _) (GHC.AnnComment t pp):ls)
+      = L (Anchor la op) (GHC.AnnComment t pp) : go p' ls
+      where
+        p' = p
+        (r,c) = ss2posEnd pp
+        op' = if r == 0
+               then MovedAnchor (ss2delta (r,c+1) la)
+               else MovedAnchor (ss2delta (r,c)   la)
+        op = if t == AnnEofComment && op' == MovedAnchor (DP 0 0)
+               then MovedAnchor (DP 1 0)
+               else op'
+
+addCommentOrigDeltas :: ApiAnnComments -> ApiAnnComments
+addCommentOrigDeltas (AnnComments cs) = AnnComments (commentOrigDeltas cs)
+addCommentOrigDeltas (AnnCommentsBalanced pcs fcs)
+  = AnnCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs)
+
+addCommentOrigDeltasAnn :: (ApiAnn' a) -> (ApiAnn' a)
+addCommentOrigDeltasAnn ApiAnnNotUsed   = ApiAnnNotUsed
+addCommentOrigDeltasAnn (ApiAnn e a cs) = ApiAnn e a (addCommentOrigDeltas cs)
+
+-- TODO: this is replicating functionality in ExactPrint. Sort out the
+-- import loop`
+anchorFromLocatedA :: LocatedA a -> RealSrcSpan
+anchorFromLocatedA (L (SrcSpanAnn an loc) _)
+  = case an of
+      ApiAnnNotUsed    -> realSrcSpan loc
+      (ApiAnn anc _ _) -> anchor anc
+
+-- ---------------------------------------------------------------------
+
+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
+  logTr $ "balanceSameLineComments: (la)=" ++ showGhc (ss2range $ locA la)
+  logTr $ "balanceSameLineComments: [logInfo]=" ++ showAst logInfo
+  return (L la' (Match anm mctxt pats (GRHSs x grhss' lb)))
+  where
+    simpleBreak n (r,_) = r > n
+    (la',grhss', logInfo) = case reverse grhss of
+      [] -> (la,grhss,[])
+      (L lg g@(GRHS ApiAnnNotUsed _gs _rhs):grs) -> (la,reverse $ (L lg g):grs,[])
+      (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))])
+        where
+          (SrcSpanAnn an1 _loc1) = la
+          anc1 = addCommentOrigDeltas $ apiAnnComments an1
+          (ApiAnn anc an _) = ga :: ApiAnn' GrhsAnn
+          (csp,csf) = case anc1 of
+            AnnComments cs -> ([],cs)
+            AnnCommentsBalanced p f -> (p,f)
+          (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchor anc) csf)
+          move = map snd move'
+          stay = map snd stay'
+          cs1 = AnnCommentsBalanced csp stay
+
+          gac = addCommentOrigDeltas $ apiAnnComments ga
+          gfc = getFollowingComments gac
+          gac' = setFollowingComments gac (sort $ gfc ++ move)
+          ga' = (ApiAnn anc an gac')
+
+          an1' = setCommentsSrcAnn la cs1
+          la'' = an1'
+
+-- ---------------------------------------------------------------------
+
+
+-- |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 (_,DP r _c) = r > 0
+
+  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 an _lo _mn _exps _imps _decls _ _)) = L l (m { hsmodAnn = an' })
+  where
+    an' = addCommentOrigDeltasAnn an
+
+-- ---------------------------------------------------------------------
+
+-- | 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' (ApiAnn' ann)
+noAnnSrcSpanDP l dp
+  = SrcSpanAnn (ApiAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty noCom) l
+
+noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (ApiAnn' ann)
+noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (DP 0 0)
+
+noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (ApiAnn' ann)
+noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (DP 0 1)
+
+noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (ApiAnn' ann)
+noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (DP 0 s)
+
+d0 :: AnnAnchor
+d0 = AD $ DP 0 0
+
+d1 :: AnnAnchor
+d1 = AD $ DP 0 1
+
+dn :: Int -> AnnAnchor
+dn n = AD $ DP 0 n
+
+m0 :: AnchorOperation
+m0 = MovedAnchor $ DP 0 0
+
+m1 :: AnchorOperation
+m1 = MovedAnchor $ DP 0 1
+
+mn :: Int -> AnchorOperation
+mn n = MovedAnchor $ DP 0 n
+
+addComma :: SrcSpanAnnA -> SrcSpanAnnA
+addComma (SrcSpanAnn ApiAnnNotUsed l)
+  = (SrcSpanAnn (ApiAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) noCom) l)
+addComma (SrcSpanAnn (ApiAnn anc (AnnListItem as) cs) l)
+  = (SrcSpanAnn (ApiAnn anc (AnnListItem (AddCommaAnn d0:as)) cs) l)
+
+-- ---------------------------------------------------------------------
+
+-- | Insert a declaration into an AST element having sub-declarations
+-- (@HasDecls@) according to the given location function.
+insertAt :: (HasDecls ast)
+              => (LHsDecl GhcPs
+                  -> [LHsDecl GhcPs]
+                  -> [LHsDecl GhcPs])
+              -> ast
+              -> LHsDecl GhcPs
+              -> Transform ast
+insertAt f t decl = do
+  oldDecls <- hsDecls t
+  replaceDecls t (f decl oldDecls)
+
+-- |Insert a declaration at the beginning or end of the subdecls of the given
+-- AST item
+insertAtStart, insertAtEnd :: (HasDecls ast)
+              => ast
+              -> LHsDecl GhcPs
+              -> Transform ast
+
+insertAtStart = insertAt (:)
+insertAtEnd   = insertAt (\x xs -> xs ++ [x])
+
+-- |Insert a declaration at a specific location in the subdecls of the given
+-- AST item
+insertAfter, insertBefore :: (HasDecls (LocatedA ast))
+                          => LocatedA old
+                          -> LocatedA ast
+                          -> LHsDecl GhcPs
+                          -> Transform (LocatedA ast)
+insertAfter (getLocA -> k) = insertAt findAfter
+  where
+    findAfter x xs =
+      case span (\(L l _) -> locA l /= k) xs of
+        ([],[]) -> [x]
+        (fs,[]) -> fs++[x]
+        (fs, b:bs) -> fs ++ (b : x : bs)
+      -- let (fs, b:bs) = span (\(L l _) -> locA l /= k) xs
+      -- in fs ++ (b : x : bs)
+insertBefore (getLocA -> k) = insertAt findBefore
+  where
+    findBefore x xs =
+      let (fs, bs) = span (\(L l _) -> locA l /= k) xs
+      in fs ++ (x : bs)
+
+-- =====================================================================
+-- start of HasDecls instances
+-- =====================================================================
+
+-- |Provide a means to get and process the immediate child declartions of a
+-- given AST element.
+class (Data t) => HasDecls t where
+-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent
+
+    -- | Return the 'HsDecl's that are directly enclosed in the
+    -- given syntax phrase. They are always returned in the wrapped 'HsDecl'
+    -- form, even if orginating in local decls. This is safe, as annotations
+    -- never attach to the wrapper, only to the wrapped item.
+    hsDecls :: (Monad m) => t -> TransformT m [LHsDecl GhcPs]
+
+    -- | Replace the directly enclosed decl list by the given
+    --  decl list. Runs in the 'Transform' monad to be able to update list order
+    --  annotations, and rebalance comments and other layout changes as needed.
+    --
+    -- For example, a call on replaceDecls for a wrapped 'FunBind' having no
+    -- where clause will convert
+    --
+    -- @
+    -- -- |This is a function
+    -- foo = x -- comment1
+    -- @
+    -- in to
+    --
+    -- @
+    -- -- |This is a function
+    -- foo = x -- comment1
+    --   where
+    --     nn = 2
+    -- @
+    replaceDecls :: (Monad m) => t -> [LHsDecl GhcPs] -> TransformT m t
+
+-- ---------------------------------------------------------------------
+
+instance HasDecls ParsedSource where
+  hsDecls (L _ (HsModule _ _lo _mn _exps _imps decls _ _)) = return decls
+  replaceDecls (L l (HsModule a lo mname exps imps _decls deps haddocks)) decls
+    = do
+        logTr "replaceDecls LHsModule"
+        -- modifyAnnsT (captureOrder m decls)
+        return (L l (HsModule a lo mname exps imps decls deps haddocks))
+
+-- ---------------------------------------------------------------------
+
+instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
+  hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsValBinds lb
+
+  replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) []
+    = do
+        logTr "replaceDecls LMatch empty decls"
+        binds'' <- replaceDeclsValbinds WithoutWhere binds []
+        return (L l (Match xm c p (GRHSs xr rhs binds'')))
+
+  replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds
+    = do
+        logTr "replaceDecls LMatch nonempty decls"
+        -- Need to throw in a fresh where clause if the binds were empty,
+        -- in the annotations.
+        (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 (matchApiAnn 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')
+            return (l', grhssGRHSs $ m_grhss m')
+          _ -> return (l, rhs)
+        binds'' <- replaceDeclsValbinds WithWhere binds newBinds
+        logDataWithAnnsTr "Match.replaceDecls:binds'" binds''
+        return (L l' (Match xm c p (GRHSs xr rhs' binds'')))
+
+-- ---------------------------------------------------------------------
+
+instance HasDecls (LocatedA (HsExpr GhcPs)) where
+  hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsValBinds decls
+  hsDecls _                         = return []
+
+  replaceDecls (L ll (HsLet x binds ex)) newDecls
+    = do
+        logTr "replaceDecls HsLet"
+        let lastAnc = realSrcSpan $ spanHsLocaLBinds binds
+        -- TODO: may be an intervening comment, take account for lastAnc
+        let (x', ex',newDecls') = case x of
+              ApiAnnNotUsed -> (x, ex, newDecls)
+              (ApiAnn a (AnnsLet l i) cs) ->
+                let
+                  off = case l of
+                          (AR r) -> LayoutStartCol $ snd $ ss2pos r
+                          (AD (DP 0 _)) -> LayoutStartCol 0
+                          (AD (DP _ c)) -> LayoutStartCol c
+                  ex'' = setEntryDPFromAnchor off i ex
+                  newDecls'' = case newDecls of
+                    [] -> newDecls
+                    (d:ds) -> setEntryDPDecl d (DP 0 0) : ds
+                in ( ApiAnn a (AnnsLet l (addAnnAnchorDelta off lastAnc i)) cs
+                   , ex''
+                   , newDecls'')
+        binds' <- replaceDeclsValbinds WithoutWhere binds newDecls'
+        return (L ll (HsLet x' binds' ex'))
+
+  -- TODO: does this make sense? Especially as no hsDecls for HsPar
+  replaceDecls (L l (HsPar x e)) newDecls
+    = do
+        logTr "replaceDecls HsPar"
+        e' <- replaceDecls e newDecls
+        return (L l (HsPar x e'))
+  replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old
+
+-- ---------------------------------------------------------------------
+
+-- | Extract the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This
+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
+-- idempotent.
+hsDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
+hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d)
+hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
+
+-- | Extract the immediate declarations for a 'PatBind'. This
+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
+-- idempotent.
+hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
+hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb
+hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
+
+-- -------------------------------------
+
+-- | Replace the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This
+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
+-- idempotent.
+replaceDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> [LHsDecl GhcPs]
+                     -> TransformT m (LHsDecl GhcPs)
+replaceDeclsPatBindD (L l (ValD x d)) newDecls = do
+  (L _ d') <- replaceDeclsPatBind (L l d) newDecls
+  return (L l (ValD x d'))
+replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x
+
+-- | Replace the immediate declarations for a 'PatBind'. This
+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
+-- idempotent.
+replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs]
+                    -> TransformT m (LHsBind GhcPs)
+replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) 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'') b))
+replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
+  hsDecls (L _ (LetStmt _ lb))      = hsDeclsValBinds lb
+  hsDecls (L _ (LastStmt _ e _ _))  = hsDecls e
+  hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e
+  hsDecls (L _ (BodyStmt _ e _ _))  = hsDecls e
+  hsDecls _                         = return []
+
+  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
+        e' <- replaceDecls e newDecls
+        return (L l (LastStmt x e' d se))
+  replaceDecls (L l (BindStmt x pat e)) newDecls
+    = do
+      e' <- replaceDecls e newDecls
+      return (L l (BindStmt x pat e'))
+
+  replaceDecls (L l (BodyStmt x e a b)) newDecls
+    = do
+      e' <- replaceDecls e newDecls
+      return (L l (BodyStmt x e' a b))
+  replaceDecls x _newDecls = return x
+
+-- =====================================================================
+-- end of HasDecls instances
+-- =====================================================================
+
+-- ---------------------------------------------------------------------
+
+-- |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)
+             => AnnSortKey -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
+orderedDecls sortKey decls = do
+  case sortKey of
+    NoAnnSortKey -> do
+      -- return decls
+      return $ sortBy (\a b -> compare (realSrcSpan $ getLocA a) (realSrcSpan $ getLocA b)) decls
+    AnnSortKey keys -> do
+      let ds = map (\s -> (rs $ getLocA s,s)) decls
+          ordered = map snd $ orderByKey ds keys
+      return ordered
+
+-- ---------------------------------------------------------------------
+
+hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
+hsDeclsValBinds lb = case lb of
+    HsValBinds _ (ValBinds sortKey bs sigs) -> do
+      let
+        bds = map wrapDecl (bagToList bs)
+        sds = map wrapSig sigs
+      orderedDecls sortKey (bds ++ sds)
+    HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
+    HsIPBinds {}       -> return []
+    EmptyLocalBinds {} -> return []
+
+data WithWhere = WithWhere
+               | WithoutWhere
+               deriving (Eq,Show)
+
+-- | Utility function for returning decls to 'HsLocalBinds'. Use with
+-- care, as this does not manage the declaration order, the
+-- ordering should be done by the calling function from the 'HsLocalBinds'
+-- context in the AST.
+replaceDeclsValbinds :: (Monad m)
+                     => WithWhere
+                     -> HsLocalBinds GhcPs -> [LHsDecl GhcPs]
+                     -> TransformT m (HsLocalBinds GhcPs)
+replaceDeclsValbinds _ _ [] = do
+  return (EmptyLocalBinds NoExtField)
+replaceDeclsValbinds w b@(HsValBinds a _) new
+    = do
+        logTr "replaceDeclsValbinds"
+        let oldSpan = spanHsLocaLBinds b
+        an <- oldWhereAnnotation a w (realSrcSpan oldSpan)
+        let decs = listToBag $ concatMap decl2Bind new
+        let sigs = concatMap decl2Sig new
+        let sortKey = captureOrder new
+        return (HsValBinds an (ValBinds sortKey decs sigs))
+replaceDeclsValbinds _ (HsIPBinds {}) _new    = error "undefined replaceDecls HsIPBinds"
+replaceDeclsValbinds w (EmptyLocalBinds _) new
+    = do
+        logTr "replaceDecls HsLocalBinds"
+        an <- newWhereAnnotation w
+        let newBinds = concatMap decl2Bind new
+            newSigs  = concatMap decl2Sig  new
+        let decs = listToBag $ newBinds
+        let sigs = newSigs
+        let sortKey = captureOrder new
+        return (HsValBinds an (ValBinds sortKey decs sigs))
+
+oldWhereAnnotation :: (Monad m)
+  => ApiAnn' AnnList -> WithWhere -> RealSrcSpan -> TransformT m (ApiAnn' AnnList)
+oldWhereAnnotation ApiAnnNotUsed ww _oldSpan = do
+  newSpan <- uniqueSrcSpanT
+  let w = case ww of
+        WithWhere -> [AddApiAnn AnnWhere (AD (DP 0 0))]
+        WithoutWhere -> []
+  let anc2' = Anchor (rs newSpan) (MovedAnchor (DP 0 1))
+  (anc, anc2) <- do
+          newSpan' <- uniqueSrcSpanT
+          return ( Anchor (rs newSpan') (MovedAnchor (DP 1 2))
+                 , anc2')
+  let an = ApiAnn anc
+                  (AnnList (Just anc2) Nothing Nothing w [])
+                  noCom
+  return an
+oldWhereAnnotation (ApiAnn anc an cs) ww _oldSpan = do
+  -- TODO: when we set DP (0,0) for the HsValBinds ApiAnnAnchor, change the AnnList anchor to have the correct DP too
+  let (AnnList ancl o c _r t) = an
+  let w = case ww of
+        WithWhere -> [AddApiAnn AnnWhere (AD (DP 0 0))]
+        WithoutWhere -> []
+  (anc', ancl') <- do
+        case ww of
+          WithWhere -> return (anc, ancl)
+          WithoutWhere -> return (anc, ancl)
+  let an' = ApiAnn anc'
+                  (AnnList ancl' o c w t)
+                  cs
+  return an'
+
+newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (ApiAnn' AnnList)
+newWhereAnnotation ww = do
+  newSpan <- uniqueSrcSpanT
+  let anc  = Anchor (rs newSpan) (MovedAnchor (DP 1 2))
+  let anc2 = Anchor (rs newSpan) (MovedAnchor (DP 1 4))
+  let w = case ww of
+        WithWhere -> [AddApiAnn AnnWhere (AD (DP 0 0))]
+        WithoutWhere -> []
+  let an = ApiAnn anc
+                  (AnnList (Just anc2) Nothing Nothing w [])
+                  noCom
+  return an
+
+-- ---------------------------------------------------------------------
+
+type Decl  = LHsDecl GhcPs
+type PMatch = LMatch GhcPs (LHsExpr GhcPs)
+
+-- |Modify a 'LHsBind' wrapped in a 'ValD'. For a 'PatBind' the
+-- declarations are extracted and returned after modification. For a
+-- 'FunBind' the supplied 'SrcSpan' is used to identify the specific
+-- 'Match' to be transformed, for when there are multiple of them.
+modifyValD :: forall m t. (HasTransform m)
+                => SrcSpan
+                -> Decl
+                -> (PMatch -> [Decl] -> m ([Decl], Maybe t))
+                -> m (Decl,Maybe t)
+modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f =
+  if (locA ss) == p
+     then do
+       ds <- liftT $ hsDeclsPatBindD pb
+       (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds
+       pb' <- liftT $ replaceDeclsPatBindD pb ds'
+       return (pb',r)
+     else return (pb,Nothing)
+modifyValD p ast f = do
+  (ast',r) <- runStateT (everywhereM (mkM doModLocal) ast) Nothing
+  return (ast',r)
+  where
+    doModLocal :: PMatch -> StateT (Maybe t) m PMatch
+    doModLocal  (match@(L ss _) :: PMatch) = do
+         if (locA ss) == p
+           then do
+             ds <- lift $ liftT $ hsDecls match
+             (ds',r) <- lift $ f match ds
+             put r
+             match' <- lift $ liftT $ replaceDecls match ds'
+             return match'
+           else return match
+
+-- ---------------------------------------------------------------------
+
+-- |Used to integrate a @Transform@ into other Monad stacks
+class (Monad m) => (HasTransform m) where
+  liftT :: Transform a -> m a
+
+instance Monad m => HasTransform (TransformT m) where
+  liftT = hoistTransform (return . runIdentity)
+
+-- ---------------------------------------------------------------------
+
+-- | Apply a transformation to the decls contained in @t@
+modifyDeclsT :: (HasDecls t,HasTransform m)
+             => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs])
+             -> t -> m t
+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
new file mode 100644
index 0000000000..46ce9b4291
--- /dev/null
+++ b/utils/check-exact/Types.hs
@@ -0,0 +1,331 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiWayIf           #-}
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns         #-}
+
+module Types
+  where
+
+import GHC hiding (AnnComment)
+-- import GHC.Hs.Extension
+-- import GHC.Parser.Lexer (AddApiAnn(..))
+-- import GHC.Types.Basic hiding (EP)
+-- import GHC.Types.Name.Reader
+-- import GHC.Types.SrcLoc
+import GHC.Utils.Outputable hiding ( (<>) )
+-- import GHC.Driver.Session
+import GHC.Driver.Ppr
+-- import Control.Monad.Identity
+-- import Control.Monad.RWS
+import Data.Data (Data, toConstr,cast)
+-- import Data.Foldable
+-- import Data.List (sortBy, elemIndex)
+-- import Data.Maybe (fromMaybe)
+-- import Data.Ord (comparing)
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+-- import qualified GHC
+-- import Lookup
+
+-- ---------------------------------------------------------------------
+
+-- ---------------------------------------------------------------------
+-- | 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)
+-- deriving instance Ord SrcSpan
+
+-- 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)
+
+deltaRow, deltaColumn :: DeltaPos -> Int
+deltaRow (DP r _) = r
+deltaColumn (DP _ c) = c
+
+-- ---------------------------------------------------------------------
+
+annNone :: Annotation
+annNone = Ann (DP 0 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 ACS' a = ACS
+  { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should
+                            -- propagate down the AST. Removed when it hits zero
+  } deriving (Show)
+
+instance Semigroup (ACS' AstContext) where
+  ACS a <> ACS b = ACS (Map.unionWith max a b)
+  -- For Data.Map, mappend == union, which is a left-biased replace
+  -- for key collisions
+
+instance Monoid (ACS' AstContext) where
+  mempty = ACS mempty
+
+type AstContextSet = ACS' AstContext
+-- data AstContextSet = ACS
+--   { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should
+--                                      -- propagate down the AST. Removed when it
+--                                      -- hits zero
+--   } deriving (Show)
+
+defaultACS :: AstContextSet
+defaultACS = ACS Map.empty
+
+-- instance Outputable AstContextSet where
+instance (Show a) => Outputable (ACS' a) where
+  ppr x = text $ show x
+
+data AstContext = -- LambdaExpr
+                  CaseAlt
+                | NoPrecedingSpace
+                | HasHiding
+                | AdvanceLine
+                | NoAdvanceLine
+                | Intercalate -- This item may have a list separator following
+                | InIE -- possible 'type' or 'pattern'
+                | PrefixOp
+                | PrefixOpDollar
+                | InfixOp -- RdrName may be used as an infix operator
+                | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently
+                | ListItem -- Identifies subsequent elements of a list in layout
+                | TopLevelDecl -- top level declaration
+                | NoDarrow
+                | AddVbar
+                | Deriving
+                | Parens -- TODO: Not currently used?
+                | ExplicitNeverActive
+                | InGadt
+                | InRecCon
+                | InClassDecl
+                | InSpliceDecl
+                | LeftMost -- Is this the leftmost operator in a chain of OpApps?
+                | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt
+                          -- TODO:AZ: do we actually need this?
+
+                -- Next four used to identify current list context
+                | CtxOnly
+                | CtxFirst
+                | CtxMiddle
+                | CtxLast
+                | CtxPos Int -- 0 for first, increasing for subsequent
+
+                -- Next are used in tellContext to push context up the tree
+                | FollowingLine
+                deriving (Eq, Ord, Show)
+
+
+data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) }
+  deriving (Eq,Show)
+
+-- ---------------------------------------------------------------------
+
+data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
+
+-- -- ---------------------------------------------------------------------
+-- -- | 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 SrcSpan AnnConName
+--                   deriving (Eq, Data, Ord)
+-- deriving instance Ord SrcSpan
+
+-- -- 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 l (annGetConstr a)
+
+-- mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey
+-- mkAnnKeyPrimA (L l a) = AnnKey (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)
+
+-- -- | A relative positions, row then column
+-- newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Data)
+
+-- deltaRow, deltaColumn :: DeltaPos -> Int
+-- deltaRow (DP (r, _)) = r
+-- deltaColumn (DP (_, c)) = c
+
+-- ---------------------------------------------------------------------
+
+-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted
+-- from an @AnnKeywordId@ because the annotation must be interleaved into the
+-- stream and does not have a well-defined position
+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
+    , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
+    }
+  deriving (Eq)
+
+instance Show Comment where
+  show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show o ++ ")"
+
+instance Ord Comment where
+  compare (Comment _ ss1 _) (Comment _ ss2 _) = compare (anchor ss1) (anchor ss2)
+
+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
+               | AnnTypeApp          -- ^ Visible type application annotation
+               | 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 AnnTypeApp      = "AnnTypeApp"
+  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
+showGhc :: (Outputable a) => a -> String
+showGhc = showPprUnsafe
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
new file mode 100644
index 0000000000..23f166514f
--- /dev/null
+++ b/utils/check-exact/Utils.hs
@@ -0,0 +1,596 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Utils
+  -- (
+  --  -- * Manipulating Positons
+  --   ss2pos
+  -- , ss2posEnd
+  -- , undelta
+  -- , isPointSrcSpan
+  -- , pos2delta
+  -- , ss2delta
+  -- , addDP
+  -- , spanLength
+  -- , isGoodDelta
+  -- ) where
+  where
+import Control.Monad.State
+-- import qualified Data.ByteString as B
+-- import GHC.Generics hiding (Fixity)
+import Data.Function
+import Data.Ord (comparing)
+
+import GHC.Hs.Dump
+-- import Language.Haskell.GHC.ExactPrint.Types
+import Lookup
+
+-- import GHC.Data.Bag
+-- import GHC.Driver.Session
+-- import GHC.Data.FastString
+import GHC hiding (AnnComment)
+import qualified GHC
+-- import qualified Name           as GHC
+-- import qualified NameSet        as GHC
+-- import GHC.Utils.Outputable
+import GHC.Types.Name
+import GHC.Types.Name.Reader
+import GHC.Types.SrcLoc
+import GHC.Driver.Ppr
+import GHC.Data.FastString
+-- import GHC.Types.Var
+-- import GHC.Types.Name.Occurrence
+
+-- import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief)
+import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceBrief)
+
+import Control.Arrow
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Data hiding ( Fixity )
+import Data.List
+
+import Debug.Trace
+import Types
+
+-- ---------------------------------------------------------------------
+-- ---------------------------------------------------------------------
+-- ---------------------------------------------------------------------
+
+-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print
+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
+-- warn = flip trace
+warn c _ = c
+
+-- | A good delta has no negative values.
+isGoodDelta :: DeltaPos -> Bool
+isGoodDelta (DP ro co) = ro >= 0 && co >= 0
+
+
+-- | Create a delta from the current position to the start of the given
+-- @SrcSpan@.
+ss2delta :: Pos -> RealSrcSpan -> DeltaPos
+ss2delta ref ss = pos2delta ref (ss2pos ss)
+
+-- | create a delta from the end of a current span.  The +1 is because
+-- the stored position ends up one past the span, this is prior to
+-- that adjustment
+ss2deltaEnd :: RealSrcSpan -> RealSrcSpan -> DeltaPos
+ss2deltaEnd rrs ss = ss2delta ref ss
+  where
+    (r,c) = ss2posEnd rrs
+    ref = if r == 0
+             then (r,c+1)
+             else (r,c)
+
+-- | create a delta from the start of a current span.  The +1 is
+-- because the stored position ends up one past the span, this is
+-- prior to that adjustment
+ss2deltaStart :: RealSrcSpan -> RealSrcSpan -> DeltaPos
+ss2deltaStart rrs ss = ss2delta ref ss
+  where
+    (r,c) = ss2pos rrs
+    ref = if r == 0
+             -- then (r,c+1)
+             then (r,c)
+             else (r,c)
+
+-- | Convert the start of the second @Pos@ to be an offset from the
+-- first. The assumption is the reference starts before the second @Pos@
+pos2delta :: Pos -> Pos -> DeltaPos
+pos2delta (refl,refc) (l,c) = DP lo co
+  where
+    lo = l - refl
+    co = if lo == 0 then c - refc
+                    else c
+
+-- | Apply the delta to the current position, taking into account the
+-- current column offset if advancing to a new line
+undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos
+undelta (l,c) (DP dl dc) (LayoutStartCol co) = (fl,fc)
+  where
+    fl = l + dl
+    fc = if dl == 0 then c  + dc
+                    else co + dc
+
+undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddApiAnn
+undeltaSpan anchor kw dp = AddApiAnn kw (AR sp)
+  where
+    (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0)
+    len = length (keywordToString (G 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 a b) (DP c d) =
+  if c >= 1 then DP (a+c) d
+            else DP a     (b+d)
+
+-- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the
+-- remaining delta for the second after the first has been applied.
+-- invariant : if c = a `addDP` b
+--             then a `stepDP` c == b
+--
+-- Cases where first DP is <= than second
+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1)
+-- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0)
+-- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1)
+-- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4)
+--
+-- Cases where first DP is > than second
+-- > DP (0,  3) `addDP` DP (0, 2) == DP (0,1)  -- advance one at least
+-- > DP (3,  3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col
+-- > DP (3,  3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least
+-- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col
+stepDP :: DeltaPos -> DeltaPos -> DeltaPos
+stepDP (DP a b) (DP c d)
+  | (a,b) == (c,d) = DP a b
+  | a == c = if b < d then DP 0 (d - b)
+                      else if d == 0
+                             then DP 1 0
+                             else DP c d
+  | a < c = DP (c - a) d
+  | otherwise = DP 1 d
+
+-- ---------------------------------------------------------------------
+
+adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos
+adjustDeltaForOffset _ _colOffset                      dp@(DP 0 _) = dp -- same line
+adjustDeltaForOffset d (LayoutStartCol colOffset) (DP l c) = DP l (c - colOffset - d)
+
+-- ---------------------------------------------------------------------
+
+ss2pos :: RealSrcSpan -> Pos
+ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
+
+ss2posEnd :: RealSrcSpan -> Pos
+ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndCol ss)
+
+ss2range :: SrcSpan -> (Pos,Pos)
+ss2range ss = (ss2pos $ rs ss, ss2posEnd $ rs ss)
+
+rs2range :: RealSrcSpan -> (Pos,Pos)
+rs2range ss = (ss2pos ss, ss2posEnd ss)
+
+rs :: SrcSpan -> RealSrcSpan
+rs (RealSrcSpan s _) = s
+rs _ = badRealSrcSpan
+
+range2rs :: (Pos,Pos) -> RealSrcSpan
+range2rs (s,e) = mkRealSrcSpan (mkLoc s) (mkLoc e)
+  where
+    mkLoc (l,c) = mkRealSrcLoc (fsLit "ghc-exactprint") l c
+
+badRealSrcSpan :: RealSrcSpan
+badRealSrcSpan = mkRealSrcSpan bad bad
+  where
+    bad = mkRealSrcLoc (fsLit "ghc-exactprint-nospan") 0 0
+
+spanLength :: RealSrcSpan -> Int
+spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol
+
+-- ---------------------------------------------------------------------
+-- | Checks whether a SrcSpan has zero length.
+isPointSrcSpan :: RealSrcSpan -> Bool
+isPointSrcSpan ss = spanLength ss == 0
+                  && srcSpanStartLine ss == srcSpanEndLine ss
+
+-- ---------------------------------------------------------------------
+
+-- |Given a list of items and a list of keys, returns a list of items
+-- ordered by their position in the list of keys.
+orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)]
+orderByKey keys order
+    -- AZ:TODO: if performance becomes a problem, consider a Map of the order
+    -- SrcSpan to an index, and do a lookup instead of elemIndex.
+
+    -- Items not in the ordering are placed to the start
+ = sortBy (comparing (flip elemIndex order . fst)) keys
+
+-- ---------------------------------------------------------------------
+
+isListComp :: HsStmtContext name -> Bool
+isListComp cts = case cts of
+          ListComp  -> True
+          MonadComp -> True
+
+          DoExpr {}    -> False
+          MDoExpr {}   -> False
+          ArrowExpr    -> False
+          GhciStmtCtxt -> False
+
+          PatGuard {}      -> False
+          ParStmtCtxt {}   -> False
+          TransStmtCtxt {} -> False
+
+-- ---------------------------------------------------------------------
+
+isGadt :: [LConDecl (GhcPass p)] -> Bool
+isGadt [] = False
+isGadt ((L _ (ConDeclGADT{})):_) = True
+isGadt _ = 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
+
+-- ---------------------------------------------------------------------
+
+ghcCommentText :: LAnnotationComment -> String
+ghcCommentText (L _ (GHC.AnnComment (AnnDocCommentNext s) _))  = s
+ghcCommentText (L _ (GHC.AnnComment (AnnDocCommentPrev s) _))  = s
+ghcCommentText (L _ (GHC.AnnComment (AnnDocCommentNamed s) _)) = s
+ghcCommentText (L _ (GHC.AnnComment (AnnDocSection _ s) _))    = s
+ghcCommentText (L _ (GHC.AnnComment (AnnDocOptions s) _))      = s
+ghcCommentText (L _ (GHC.AnnComment (AnnLineComment s) _))     = s
+ghcCommentText (L _ (GHC.AnnComment (AnnBlockComment s) _))    = s
+ghcCommentText (L _ (GHC.AnnComment (AnnEofComment) _))        = ""
+
+tokComment :: LAnnotationComment -> Comment
+tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt
+
+mkComment :: String -> Anchor -> Comment
+mkComment c anc = Comment c anc Nothing
+
+-- Windows comments include \r in them from the lexer.
+normaliseCommentText :: String -> String
+normaliseCommentText [] = []
+normaliseCommentText ('\r':xs) = normaliseCommentText xs
+normaliseCommentText (x:xs) = x:normaliseCommentText xs
+
+-- | Makes a comment which originates from a specific keyword.
+mkKWComment :: AnnKeywordId -> AnnAnchor -> Comment
+mkKWComment kw (AR ss)
+  = Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw)
+mkKWComment kw (AD dp)
+  = Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw)
+
+comment2dp :: (Comment,  DeltaPos) -> (KeywordId, DeltaPos)
+comment2dp = first AnnComment
+
+
+rogueComments :: ApiAnns -> [Comment]
+rogueComments as = extractRogueComments as
+  -- where
+  --   go :: Comment -> (Comment, DeltaPos)
+  --   go c@(Comment _str loc _mo) = (c, ss2delta (1,1) loc)
+
+-- extractComments :: ApiAnns -> [Comment]
+-- extractComments anns
+--   -- cm has type :: Map RealSrcSpan [LAnnotationComment]
+--   -- = map tokComment . sortRealLocated . concat $ Map.elems (apiAnnComments anns)
+--   = []
+
+extractRogueComments :: ApiAnns -> [Comment]
+extractRogueComments anns
+  -- cm has type :: Map RealSrcSpan [LAnnotationComment]
+  = map tokComment $ sortAnchorLocated  (apiAnnRogueComments anns)
+
+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 (DP 0 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
+    `addDP` annEntryDelta
+
+-- | Take an annotation and a required "true entry" and calculate an equivalent
+-- one relative to the last comment in the annPriorComments.
+annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos
+annCommentEntryDelta Ann{annPriorComments} trueDP = dp
+  where
+    commentDP =
+      foldr addDP (DP 0 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
+    dp = stepDP commentDP trueDP
+
+-- | 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
+dpFromString xs = dpFromString' xs 0 0
+  where
+    dpFromString' "" line col = DP line col
+    dpFromString' ('\n': cs) line _   = dpFromString' cs (line + 1) 0
+    dpFromString' (_:cs)     line col = dpFromString' cs line       (col + 1)
+
+-- ---------------------------------------------------------------------
+
+isSymbolRdrName :: RdrName -> Bool
+isSymbolRdrName n = isSymOcc $ rdrNameOcc n
+
+rdrName2String :: RdrName -> String
+rdrName2String r =
+  case isExact_maybe r of
+    Just n  -> name2String n
+    Nothing ->
+      case r of
+        Unqual occ       -> occNameString occ
+        Qual modname occ -> moduleNameString modname ++ "."
+                                ++ occNameString occ
+        Orig _ occ       -> occNameString occ
+        Exact n          -> getOccString n
+
+name2String :: Name -> String
+name2String = showPprUnsafe
+
+-- ---------------------------------------------------------------------
+
+-- | Put the provided context elements into the existing set with fresh level
+-- counts
+setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet
+setAcs ctxt acs = setAcsWithLevel ctxt 3 acs
+
+-- | Put the provided context elements into the existing set with given level
+-- counts
+-- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet
+-- setAcsWithLevel ctxt level (ACS a) = ACS a'
+--   where
+--     upd s (k,v) = Map.insert k v s
+--     a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level)
+setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a
+setAcsWithLevel ctxt level (ACS a) = ACS a'
+  where
+    upd s (k,v) = Map.insert k v s
+    a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level)
+
+-- ---------------------------------------------------------------------
+-- | Remove the provided context element from the existing set
+-- unsetAcs :: AstContext -> AstContextSet -> AstContextSet
+unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a
+unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a
+
+-- ---------------------------------------------------------------------
+
+-- | Are any of the contexts currently active?
+-- inAcs :: Set.Set AstContext -> AstContextSet -> Bool
+inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool
+inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a)
+
+-- | propagate the ACS down a level, dropping all values which hit zero
+-- pushAcs :: AstContextSet -> AstContextSet
+pushAcs :: ACS' a -> ACS' a
+pushAcs (ACS a) = ACS $ Map.mapMaybe f a
+  where
+    f n
+      | n <= 1    = Nothing
+      | otherwise = Just (n - 1)
+
+-- |Sometimes we have to pass the context down unchanged. Bump each count up by
+-- one so that it is unchanged after a @pushAcs@ call.
+-- bumpAcs :: AstContextSet -> AstContextSet
+bumpAcs :: ACS' a -> ACS' a
+bumpAcs (ACS a) = ACS $ Map.mapMaybe f a
+  where
+    f n = Just (n + 1)
+
+-- ---------------------------------------------------------------------
+
+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 ""
+
+{-
+data NameSpace = VarName        -- Variables, including "real" data constructors
+               | DataName       -- "Source" data constructors
+               | TvName         -- Type variables
+               | TcClsName      -- Type constructors and classes; Haskell has them
+                                -- in the same name space for now.
+-}
+
+ -- ---------------------------------------------------------------------
+
+locatedAnAnchor :: LocatedAn a t -> RealSrcSpan
+locatedAnAnchor (L (SrcSpanAnn ApiAnnNotUsed l) _) = realSrcSpan l
+locatedAnAnchor (L (SrcSpanAnn (ApiAnn a _ _) _) _) = anchor a
+
+ -- ---------------------------------------------------------------------
+
+-- showSDoc_ :: SDoc -> String
+-- showSDoc_ = showSDoc unsafeGlobalDynFlags
+
+-- showSDocDebug_ :: SDoc -> String
+-- showSDocDebug_ = showSDocDebug unsafeGlobalDynFlags
+
+
+ -- ---------------------------------------------------------------------
+
+showAst :: (Data a) => a -> String
+showAst ast
+  = showSDocUnsafe
+    $ showAstData NoBlankSrcSpan NoBlankApiAnnotations ast
+
+-- ---------------------------------------------------------------------
+-- Putting these here for the time being, to avoid import loops
+
+ghead :: String -> [a] -> a
+ghead  info []    = error $ "ghead "++info++" []"
+ghead _info (h:_) = h
+
+glast :: String -> [a] -> a
+glast  info []    = error $ "glast " ++ info ++ " []"
+glast _info h     = last h
+
+gtail :: String -> [a] -> [a]
+gtail  info []   = error $ "gtail " ++ info ++ " []"
+gtail _info h    = tail h
+
+gfromJust :: String -> Maybe a -> a
+gfromJust _info (Just h) = h
+gfromJust  info Nothing = error $ "gfromJust " ++ info ++ " Nothing"
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+-- | Make a generic monadic transformation;
+--   start from a type-specific case;
+--   resort to return otherwise
+--
+mkM :: ( Monad m
+       , Typeable a
+       , Typeable b
+       )
+    => (b -> m b)
+    -> a
+    -> m a
+mkM = extM return
+
+-- | Flexible type extension
+ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a
+ext0 def ext = maybe def id (gcast ext)
+
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+-- | Flexible type extension
+ext2 :: (Data a, Typeable t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2 def ext = maybe def id (dataCast2 ext)
+
+
+-- | Extend a generic monadic transformation by a type-specific case
+extM :: ( Monad m
+        , Typeable a
+        , Typeable b
+        )
+     => (a -> m a) -> (b -> m b) -> a -> m a
+extM def ext = unM ((M def) `ext0` (M ext))
+
+-- | Type extension of monadic transformations for type constructors
+ext2M :: (Monad m, Data d, Typeable t)
+      => (forall e. Data e => e -> m e)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))
+      -> d -> m d
+ext2M def ext = unM ((M def) `ext2` (M ext))
+
+-- | The type constructor for transformations
+newtype M m x = M { unM :: x -> m x }
+
+-- | Generic monadic transformations,
+--   i.e., take an \"a\" and compute an \"a\"
+--
+type GenericM m = forall a. Data a => a -> m a
+
+-- | Monadic variation on everywhere
+everywhereM :: forall m. Monad m => GenericM m -> GenericM m
+
+-- Bottom-up order is also reflected in order of do-actions
+everywhereM f = go
+  where
+    go :: GenericM m
+    go x = do
+      x' <- gmapM go x
+      f x'
diff --git a/utils/check-exact/cases/AddDecl1.expected.hs b/utils/check-exact/cases/AddDecl1.expected.hs
new file mode 100644
index 0000000000..88ef0fdd7d
--- /dev/null
+++ b/utils/check-exact/cases/AddDecl1.expected.hs
@@ -0,0 +1,13 @@
+module AddDecl where
+
+nn = n2
+
+-- Adding a declaration to an existing file
+
+-- | Do foo
+foo a b = a + b
+
+-- | Do bar
+bar x y = {- baz -} foo (x+y) x
+
+-- end of file
diff --git a/utils/check-exact/cases/AddDecl1.hs b/utils/check-exact/cases/AddDecl1.hs
new file mode 100644
index 0000000000..45c0cb3864
--- /dev/null
+++ b/utils/check-exact/cases/AddDecl1.hs
@@ -0,0 +1,11 @@
+module AddDecl where
+
+-- Adding a declaration to an existing file
+
+-- | Do foo
+foo a b = a + b
+
+-- | Do bar
+bar x y = {- baz -} foo (x+y) x
+
+-- end of file
diff --git a/utils/check-exact/cases/AddDecl2.expected.hs b/utils/check-exact/cases/AddDecl2.expected.hs
new file mode 100644
index 0000000000..2bbbcf5b37
--- /dev/null
+++ b/utils/check-exact/cases/AddDecl2.expected.hs
@@ -0,0 +1,13 @@
+module AddDecl where
+
+-- Adding a declaration to an existing file
+
+-- | Do foo
+foo a b = a + b
+
+-- | Do bar
+bar x y = {- baz -} foo (x+y) x
+
+nn = n2
+
+-- end of file
diff --git a/utils/check-exact/cases/AddDecl2.hs b/utils/check-exact/cases/AddDecl2.hs
new file mode 100644
index 0000000000..45c0cb3864
--- /dev/null
+++ b/utils/check-exact/cases/AddDecl2.hs
@@ -0,0 +1,11 @@
+module AddDecl where
+
+-- Adding a declaration to an existing file
+
+-- | Do foo
+foo a b = a + b
+
+-- | Do bar
+bar x y = {- baz -} foo (x+y) x
+
+-- end of file
diff --git a/utils/check-exact/cases/AddDecl3.expected.hs b/utils/check-exact/cases/AddDecl3.expected.hs
new file mode 100644
index 0000000000..dd3044fcc5
--- /dev/null
+++ b/utils/check-exact/cases/AddDecl3.expected.hs
@@ -0,0 +1,13 @@
+module AddDecl where
+
+-- Adding a declaration to an existing file
+
+-- | Do foo
+foo a b = a + b
+
+nn = n2
+
+-- | Do bar
+bar x y = {- baz -} foo (x+y) x
+
+-- end of file
diff --git a/utils/check-exact/cases/AddDecl3.hs b/utils/check-exact/cases/AddDecl3.hs
new file mode 100644
index 0000000000..45c0cb3864
--- /dev/null
+++ b/utils/check-exact/cases/AddDecl3.hs
@@ -0,0 +1,11 @@
+module AddDecl where
+
+-- Adding a declaration to an existing file
+
+-- | Do foo
+foo a b = a + b
+
+-- | Do bar
+bar x y = {- baz -} foo (x+y) x
+
+-- end of file
diff --git a/utils/check-exact/cases/AddHiding1.expected.hs b/utils/check-exact/cases/AddHiding1.expected.hs
new file mode 100644
index 0000000000..f3c8f17c8b
--- /dev/null
+++ b/utils/check-exact/cases/AddHiding1.expected.hs
@@ -0,0 +1,8 @@
+module AddHiding1 where
+
+import Data.Maybe hiding (n1,n2)
+
+import Data.Maybe hiding (n1,n2)
+
+f = 1
+
diff --git a/utils/check-exact/cases/AddHiding1.hs b/utils/check-exact/cases/AddHiding1.hs
new file mode 100644
index 0000000000..abcd47879a
--- /dev/null
+++ b/utils/check-exact/cases/AddHiding1.hs
@@ -0,0 +1,8 @@
+module AddHiding1 where
+
+import Data.Maybe
+
+import Data.Maybe hiding (n1,n2)
+
+f = 1
+
diff --git a/utils/check-exact/cases/AddHiding2.expected.hs b/utils/check-exact/cases/AddHiding2.expected.hs
new file mode 100644
index 0000000000..d62005227b
--- /dev/null
+++ b/utils/check-exact/cases/AddHiding2.expected.hs
@@ -0,0 +1,5 @@
+module AddHiding2 where
+
+import Data.Maybe hiding (f1,f2,n1,n2)
+
+f = 1
diff --git a/utils/check-exact/cases/AddHiding2.hs b/utils/check-exact/cases/AddHiding2.hs
new file mode 100644
index 0000000000..f5f551a9cb
--- /dev/null
+++ b/utils/check-exact/cases/AddHiding2.hs
@@ -0,0 +1,5 @@
+module AddHiding2 where
+
+import Data.Maybe hiding (f1,f2)
+
+f = 1
diff --git a/utils/check-exact/cases/AddLocalDecl1.expected.hs b/utils/check-exact/cases/AddLocalDecl1.expected.hs
new file mode 100644
index 0000000000..023e2ea05d
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl1.expected.hs
@@ -0,0 +1,15 @@
+module AddLocalDecl1 where
+
+-- |This is a function
+foo = x -- comment1
+  where
+    nn = 2
+-- trailing 1
+
+-- |Another fun
+x = a -- comment2
+  where
+    a = 3
+-- trailing 2
+
+y = 3
diff --git a/utils/check-exact/cases/AddLocalDecl1.hs b/utils/check-exact/cases/AddLocalDecl1.hs
new file mode 100644
index 0000000000..3bb4953c51
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl1.hs
@@ -0,0 +1,13 @@
+module AddLocalDecl1 where
+
+-- |This is a function
+foo = x -- comment1
+-- trailing 1
+
+-- |Another fun
+x = a -- comment2
+  where
+    a = 3
+-- trailing 2
+
+y = 3
diff --git a/utils/check-exact/cases/AddLocalDecl2.expected.hs b/utils/check-exact/cases/AddLocalDecl2.expected.hs
new file mode 100644
index 0000000000..ff25b79157
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl2.expected.hs
@@ -0,0 +1,11 @@
+module AddLocalDecl2 where
+
+-- |This is a function
+foo = x -- comment 0
+  where nn = 2
+        p = 2 -- comment 1
+
+-- |Another fun
+bar = a -- comment 2
+  where nn = 2
+        p = 2 -- comment 3
diff --git a/utils/check-exact/cases/AddLocalDecl2.hs b/utils/check-exact/cases/AddLocalDecl2.hs
new file mode 100644
index 0000000000..7609f657ed
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl2.hs
@@ -0,0 +1,10 @@
+module AddLocalDecl2 where
+
+-- |This is a function
+foo = x -- comment 0
+  where p = 2 -- comment 1
+
+-- |Another fun
+bar = a -- comment 2
+  where nn = 2
+        p = 2 -- comment 3
diff --git a/utils/check-exact/cases/AddLocalDecl3.expected.hs b/utils/check-exact/cases/AddLocalDecl3.expected.hs
new file mode 100644
index 0000000000..deaf1e7cb8
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl3.expected.hs
@@ -0,0 +1,13 @@
+module AddLocalDecl3 where
+
+-- |This is a function
+foo = x -- comment 0
+  where p = 2 -- comment 1
+        nn = 2
+ -- comment f
+
+-- |Another fun
+bar = a -- comment 2
+  where p = 2 -- comment 3
+        nn = 2
+ -- comment b
diff --git a/utils/check-exact/cases/AddLocalDecl3.hs b/utils/check-exact/cases/AddLocalDecl3.hs
new file mode 100644
index 0000000000..eb14013031
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl3.hs
@@ -0,0 +1,12 @@
+module AddLocalDecl3 where
+
+-- |This is a function
+foo = x -- comment 0
+  where p = 2 -- comment 1
+ -- comment f
+
+-- |Another fun
+bar = a -- comment 2
+  where p = 2 -- comment 3
+        nn = 2
+ -- comment b
diff --git a/utils/check-exact/cases/AddLocalDecl4.expected.hs b/utils/check-exact/cases/AddLocalDecl4.expected.hs
new file mode 100644
index 0000000000..b3c1445d0d
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl4.expected.hs
@@ -0,0 +1,6 @@
+module AddLocalDecl4 where
+
+toplevel x = c * x
+  where
+    nn :: Int
+    nn = 2
diff --git a/utils/check-exact/cases/AddLocalDecl4.hs b/utils/check-exact/cases/AddLocalDecl4.hs
new file mode 100644
index 0000000000..2ec2c0bf73
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl4.hs
@@ -0,0 +1,3 @@
+module AddLocalDecl4 where
+
+toplevel x = c * x
diff --git a/utils/check-exact/cases/AddLocalDecl5.expected.hs b/utils/check-exact/cases/AddLocalDecl5.expected.hs
new file mode 100644
index 0000000000..5e66dc5a6b
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl5.expected.hs
@@ -0,0 +1,9 @@
+module AddLocalDecl5 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+  where
+    -- c,d :: Integer
+    c = 7
+
+d = 9
diff --git a/utils/check-exact/cases/AddLocalDecl5.hs b/utils/check-exact/cases/AddLocalDecl5.hs
new file mode 100644
index 0000000000..9f07e1071b
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl5.hs
@@ -0,0 +1,8 @@
+module AddLocalDecl5 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
diff --git a/utils/check-exact/cases/AddLocalDecl6.expected.hs b/utils/check-exact/cases/AddLocalDecl6.expected.hs
new file mode 100644
index 0000000000..9cedb7d63f
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl6.expected.hs
@@ -0,0 +1,12 @@
+module AddLocalDecl6 where
+
+foo [] = 1 -- comment 0
+  where
+    x = 3
+foo xs = 2 -- comment 1
+
+bar [] = 1 -- comment 2
+  where
+    x = 3
+bar xs = 2 -- comment 3
+
diff --git a/utils/check-exact/cases/AddLocalDecl6.hs b/utils/check-exact/cases/AddLocalDecl6.hs
new file mode 100644
index 0000000000..d0bdffca41
--- /dev/null
+++ b/utils/check-exact/cases/AddLocalDecl6.hs
@@ -0,0 +1,10 @@
+module AddLocalDecl6 where
+
+foo [] = 1 -- comment 0
+foo xs = 2 -- comment 1
+
+bar [] = 1 -- comment 2
+  where
+    x = 3
+bar xs = 2 -- comment 3
+
diff --git a/utils/check-exact/cases/EmptyWheres.hs b/utils/check-exact/cases/EmptyWheres.hs
new file mode 100644
index 0000000000..edc0570012
--- /dev/null
+++ b/utils/check-exact/cases/EmptyWheres.hs
@@ -0,0 +1,9 @@
+module EmptyWheres where
+
+x = 2 where
+y = 3
+
+instance Foo1 Int where
+
+ff = ff where g = g where
+type T = Int
diff --git a/utils/check-exact/cases/LayoutIn1.expected.hs b/utils/check-exact/cases/LayoutIn1.expected.hs
new file mode 100644
index 0000000000..2b23b21853
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn1.expected.hs
@@ -0,0 +1,9 @@
+module LayoutIn1 where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'sq' to 'square'.
+
+sumSquares x y= square x + square y where sq x= x^pow
+          --There is a comment.
+                                          pow=2
diff --git a/utils/check-exact/cases/LayoutIn1.hs b/utils/check-exact/cases/LayoutIn1.hs
new file mode 100644
index 0000000000..3ea1f8402c
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn1.hs
@@ -0,0 +1,9 @@
+module LayoutIn1 where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'sq' to 'square'.
+
+sumSquares x y= sq x + sq y where sq x= x^pow
+  --There is a comment.
+                                  pow=2
diff --git a/utils/check-exact/cases/LayoutIn3.expected.hs b/utils/check-exact/cases/LayoutIn3.expected.hs
new file mode 100644
index 0000000000..900d6daf63
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn3.expected.hs
@@ -0,0 +1,13 @@
+module LayoutIn3 where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'x' after 'let'  to 'anotherX'.
+
+foo x = let anotherX = 12 in (let y = 3
+                                  z = 2 in anotherX * y * z * w) where   y = 2
+                                                                         --there is a comment.
+                                                                         w = x
+                                                                           where
+                                                                             x = let y = 5 in y + 3
+
diff --git a/utils/check-exact/cases/LayoutIn3.hs b/utils/check-exact/cases/LayoutIn3.hs
new file mode 100644
index 0000000000..c8c110d65c
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn3.hs
@@ -0,0 +1,13 @@
+module LayoutIn3 where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'x' after 'let'  to 'anotherX'.
+
+foo x = let x = 12 in (let y = 3
+                           z = 2 in x * y * z * w) where   y = 2
+                                                           --there is a comment.
+                                                           w = x
+                                                             where
+                                                               x = let y = 5 in y + 3
+
diff --git a/utils/check-exact/cases/LayoutIn3a.expected.hs b/utils/check-exact/cases/LayoutIn3a.expected.hs
new file mode 100644
index 0000000000..c0a552c0d0
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn3a.expected.hs
@@ -0,0 +1,13 @@
+module LayoutIn3a where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'x' after 'let'  to 'anotherX'.
+
+foo x = let anotherX = 12 in (
+                                    anotherX            ) where   y = 2
+                                                                  --there is a comment.
+                                                                  w = x
+                                                                    where
+                                                                      x = let y = 5 in y + 3
+
diff --git a/utils/check-exact/cases/LayoutIn3a.hs b/utils/check-exact/cases/LayoutIn3a.hs
new file mode 100644
index 0000000000..58b36b07f8
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn3a.hs
@@ -0,0 +1,13 @@
+module LayoutIn3a where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'x' after 'let'  to 'anotherX'.
+
+foo x = let x = 12 in (
+                                    x            ) where   y = 2
+                                                           --there is a comment.
+                                                           w = x
+                                                             where
+                                                               x = let y = 5 in y + 3
+
diff --git a/utils/check-exact/cases/LayoutIn3b.expected.hs b/utils/check-exact/cases/LayoutIn3b.expected.hs
new file mode 100644
index 0000000000..057d9d346a
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn3b.expected.hs
@@ -0,0 +1,12 @@
+module LayoutIn3b where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'x' after 'let'  to 'anotherX'.
+
+foo x = let anotherX = 12 in (             anotherX            ) where   y = 2
+                                                                         --there is a comment.
+                                                                         w = x
+                                                                           where
+                                                                             x = let y = 5 in y + 3
+
diff --git a/utils/check-exact/cases/LayoutIn3b.hs b/utils/check-exact/cases/LayoutIn3b.hs
new file mode 100644
index 0000000000..32bc294ae4
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn3b.hs
@@ -0,0 +1,12 @@
+module LayoutIn3b where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'x' after 'let'  to 'anotherX'.
+
+foo x = let x = 12 in (             x            ) where   y = 2
+                                                           --there is a comment.
+                                                           w = x
+                                                             where
+                                                               x = let y = 5 in y + 3
+
diff --git a/utils/check-exact/cases/LayoutIn4.expected.hs b/utils/check-exact/cases/LayoutIn4.expected.hs
new file mode 100644
index 0000000000..531478da48
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn4.expected.hs
@@ -0,0 +1,13 @@
+module LayoutIn4 where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'ioFun' to  'io'
+
+main = io "hello" where io s= do  let  k = reverse s
+--There is a comment
+                                  s <- getLine
+                                  let  q = (k ++ s)
+                                  putStr q
+                                  putStr "foo"
+
diff --git a/utils/check-exact/cases/LayoutIn4.hs b/utils/check-exact/cases/LayoutIn4.hs
new file mode 100644
index 0000000000..d99d05649d
--- /dev/null
+++ b/utils/check-exact/cases/LayoutIn4.hs
@@ -0,0 +1,13 @@
+module LayoutIn4 where
+
+--Layout rule applies after 'where','let','do' and 'of'
+
+--In this Example: rename 'ioFun' to  'io'
+
+main = ioFun "hello" where ioFun s= do  let  k = reverse s
+ --There is a comment
+                                        s <- getLine
+                                        let  q = (k ++ s)
+                                        putStr q
+                                        putStr "foo"
+
diff --git a/utils/check-exact/cases/LayoutLet2.expected.hs b/utils/check-exact/cases/LayoutLet2.expected.hs
new file mode 100644
index 0000000000..8da499ce3a
--- /dev/null
+++ b/utils/check-exact/cases/LayoutLet2.expected.hs
@@ -0,0 +1,8 @@
+module LayoutLet2 where
+
+-- Simple let expression, rename xxx to something longer or shorter
+-- and the let/in layout should adjust accordingly
+-- In this case the tokens for xxx + a + b should also shift out
+
+foo xxxlonger = let a = 1
+                    b = 2 in xxxlonger + a + b
diff --git a/utils/check-exact/cases/LayoutLet2.hs b/utils/check-exact/cases/LayoutLet2.hs
new file mode 100644
index 0000000000..378aa587a8
--- /dev/null
+++ b/utils/check-exact/cases/LayoutLet2.hs
@@ -0,0 +1,8 @@
+module LayoutLet2 where
+
+-- Simple let expression, rename xxx to something longer or shorter
+-- and the let/in layout should adjust accordingly
+-- In this case the tokens for xxx + a + b should also shift out
+
+foo xxx = let a = 1
+              b = 2 in xxx + a + b
diff --git a/utils/check-exact/cases/LayoutLet3.expected.hs b/utils/check-exact/cases/LayoutLet3.expected.hs
new file mode 100644
index 0000000000..797cf5f483
--- /dev/null
+++ b/utils/check-exact/cases/LayoutLet3.expected.hs
@@ -0,0 +1,10 @@
+module LayoutLet3 where
+
+-- Simple let expression, rename xxx to something longer or shorter
+-- and the let/in layout should adjust accordingly
+-- In this case the tokens for xxx + a + b should also shift out
+
+foo xxxlonger = let a = 1
+                    b = 2
+                in xxxlonger + a + b
+
diff --git a/utils/check-exact/cases/LayoutLet3.hs b/utils/check-exact/cases/LayoutLet3.hs
new file mode 100644
index 0000000000..5ba80aff6a
--- /dev/null
+++ b/utils/check-exact/cases/LayoutLet3.hs
@@ -0,0 +1,10 @@
+module LayoutLet3 where
+
+-- Simple let expression, rename xxx to something longer or shorter
+-- and the let/in layout should adjust accordingly
+-- In this case the tokens for xxx + a + b should also shift out
+
+foo xxx = let a = 1
+              b = 2
+          in xxx + a + b
+
diff --git a/utils/check-exact/cases/LayoutLet4.expected.hs b/utils/check-exact/cases/LayoutLet4.expected.hs
new file mode 100644
index 0000000000..b3c52f424e
--- /dev/null
+++ b/utils/check-exact/cases/LayoutLet4.expected.hs
@@ -0,0 +1,12 @@
+module LayoutLet4 where
+
+-- Simple let expression, rename xxx to something longer or shorter
+-- and the let/in layout should adjust accordingly
+-- In this case the tokens for xxx + a + b should also shift out
+
+foo xxxlonger = let a = 1
+                    b = 2
+                in xxxlonger + a + b
+
+bar = 3
+
diff --git a/utils/check-exact/cases/LayoutLet4.hs b/utils/check-exact/cases/LayoutLet4.hs
new file mode 100644
index 0000000000..28fe599432
--- /dev/null
+++ b/utils/check-exact/cases/LayoutLet4.hs
@@ -0,0 +1,12 @@
+module LayoutLet4 where
+
+-- Simple let expression, rename xxx to something longer or shorter
+-- and the let/in layout should adjust accordingly
+-- In this case the tokens for xxx + a + b should also shift out
+
+foo xxx = let a = 1
+              b = 2
+          in xxx + a + b
+
+bar = 3
+
diff --git a/utils/check-exact/cases/LetIn1.expected.hs b/utils/check-exact/cases/LetIn1.expected.hs
new file mode 100644
index 0000000000..d233115ee6
--- /dev/null
+++ b/utils/check-exact/cases/LetIn1.expected.hs
@@ -0,0 +1,18 @@
+module LetIn1 where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the local  'pow' to 'sq'
+--This example also aims to test the demoting a local declaration in 'let'.
+
+sumSquares x y = let sq 0=0
+                     sq z=z^pow
+                 in sq x + sq y
+
+
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
+
diff --git a/utils/check-exact/cases/LetIn1.hs b/utils/check-exact/cases/LetIn1.hs
new file mode 100644
index 0000000000..f1109b8f03
--- /dev/null
+++ b/utils/check-exact/cases/LetIn1.hs
@@ -0,0 +1,19 @@
+module LetIn1 where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the local  'pow' to 'sq'
+--This example also aims to test the demoting a local declaration in 'let'.
+
+sumSquares x y = let sq 0=0
+                     sq z=z^pow
+                     pow=2
+                 in sq x + sq y
+
+
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
+
diff --git a/utils/check-exact/cases/LocToName.expected.hs b/utils/check-exact/cases/LocToName.expected.hs
new file mode 100644
index 0000000000..0b1484873a
--- /dev/null
+++ b/utils/check-exact/cases/LocToName.expected.hs
@@ -0,0 +1,25 @@
+module LocToName where
+
+{-
+
+
+
+
+
+
+
+
+-}
+
+
+
+
+
+
+
+LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs
+    -- where sq x = x ^pow
+    --       pow = 2
+
+LocToName.newPoint [] = 0
+
diff --git a/utils/check-exact/cases/LocToName.hs b/utils/check-exact/cases/LocToName.hs
new file mode 100644
index 0000000000..89a0acea12
--- /dev/null
+++ b/utils/check-exact/cases/LocToName.hs
@@ -0,0 +1,25 @@
+module LocToName where
+
+{-
+
+
+
+
+
+
+
+
+-}
+
+
+
+
+
+
+
+sumSquares (x:xs) = x ^2 + sumSquares xs
+    -- where sq x = x ^pow
+    --       pow = 2
+
+sumSquares [] = 0
+
diff --git a/utils/check-exact/cases/LocalDecls.expected.hs b/utils/check-exact/cases/LocalDecls.expected.hs
new file mode 100644
index 0000000000..7c41178ba0
--- /dev/null
+++ b/utils/check-exact/cases/LocalDecls.expected.hs
@@ -0,0 +1,11 @@
+module LocalDecls where
+
+foo a = bar a
+  where
+    nn :: Int
+    nn = 2
+
+    bar :: Int -> Int
+    bar x = x + 2
+
+    baz = 4
diff --git a/utils/check-exact/cases/LocalDecls.hs b/utils/check-exact/cases/LocalDecls.hs
new file mode 100644
index 0000000000..ebb774ac63
--- /dev/null
+++ b/utils/check-exact/cases/LocalDecls.hs
@@ -0,0 +1,8 @@
+module LocalDecls where
+
+foo a = bar a
+  where
+    bar :: Int -> Int
+    bar x = x + 2
+
+    baz = 4
diff --git a/utils/check-exact/cases/LocalDecls2.expected.hs b/utils/check-exact/cases/LocalDecls2.expected.hs
new file mode 100644
index 0000000000..d2353e94c5
--- /dev/null
+++ b/utils/check-exact/cases/LocalDecls2.expected.hs
@@ -0,0 +1,8 @@
+module LocalDecls2 where
+
+foo a = bar a
+  where
+    nn :: Int
+    nn = 2
+
+
diff --git a/utils/check-exact/cases/LocalDecls2.hs b/utils/check-exact/cases/LocalDecls2.hs
new file mode 100644
index 0000000000..92a8649649
--- /dev/null
+++ b/utils/check-exact/cases/LocalDecls2.hs
@@ -0,0 +1,3 @@
+module LocalDecls2 where
+
+foo a = bar a
diff --git a/utils/check-exact/cases/Rename1.expected.hs b/utils/check-exact/cases/Rename1.expected.hs
new file mode 100644
index 0000000000..353a7420e2
--- /dev/null
+++ b/utils/check-exact/cases/Rename1.expected.hs
@@ -0,0 +1,6 @@
+module Rename1 where
+
+bar2 x y =
+   do c <- getChar
+      return c
+
diff --git a/utils/check-exact/cases/Rename1.hs b/utils/check-exact/cases/Rename1.hs
new file mode 100644
index 0000000000..1ad343afd3
--- /dev/null
+++ b/utils/check-exact/cases/Rename1.hs
@@ -0,0 +1,6 @@
+module Rename1 where
+
+foo x y =
+   do c <- getChar
+      return c
+
diff --git a/utils/check-exact/cases/Rename2.expected.hs b/utils/check-exact/cases/Rename2.expected.hs
new file mode 100644
index 0000000000..6be3ff6e0a
--- /dev/null
+++ b/utils/check-exact/cases/Rename2.expected.hs
@@ -0,0 +1,4 @@
+
+joe x = case (odd x) of
+  True -> "Odd"
+  False -> "Even"
diff --git a/utils/check-exact/cases/Rename2.hs b/utils/check-exact/cases/Rename2.hs
new file mode 100644
index 0000000000..29fea060c2
--- /dev/null
+++ b/utils/check-exact/cases/Rename2.hs
@@ -0,0 +1,4 @@
+
+foo' x = case (odd x) of
+  True -> "Odd"
+  False -> "Even"
diff --git a/utils/check-exact/cases/RenameCase1.expected.hs b/utils/check-exact/cases/RenameCase1.expected.hs
new file mode 100644
index 0000000000..dad6765012
--- /dev/null
+++ b/utils/check-exact/cases/RenameCase1.expected.hs
@@ -0,0 +1,5 @@
+module RenameCase1 where
+
+foo x = case (bazLonger x) of
+    1 -> "a"
+    _ -> "b"
diff --git a/utils/check-exact/cases/RenameCase1.hs b/utils/check-exact/cases/RenameCase1.hs
new file mode 100644
index 0000000000..22d549367a
--- /dev/null
+++ b/utils/check-exact/cases/RenameCase1.hs
@@ -0,0 +1,5 @@
+module RenameCase1 where
+
+foo x = case (baz x) of
+    1 -> "a"
+    _ -> "b"
diff --git a/utils/check-exact/cases/RmDecl1.expected.hs b/utils/check-exact/cases/RmDecl1.expected.hs
new file mode 100644
index 0000000000..6bb503aede
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl1.expected.hs
@@ -0,0 +1,9 @@
+module RmDecl1 where
+
+sumSquares x = x * p
+         where p=2  {-There is a comment-}
+
+{- foo bar -}
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/RmDecl1.hs b/utils/check-exact/cases/RmDecl1.hs
new file mode 100644
index 0000000000..15cd9f1e04
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl1.hs
@@ -0,0 +1,13 @@
+module RmDecl1 where
+
+sumSquares x = x * p
+         where p=2  {-There is a comment-}
+
+sq :: Int -> Int -> Int
+sq pow 0 = 0
+sq pow z = z^pow  --there is a comment
+
+{- foo bar -}
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/RmDecl2.expected.hs b/utils/check-exact/cases/RmDecl2.expected.hs
new file mode 100644
index 0000000000..d77b760dca
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl2.expected.hs
@@ -0,0 +1,9 @@
+module RmDecl2 where
+
+sumSquares x y = let sq 0=0
+                     sq z=z^pow
+                 in sq x + sq y
+
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/RmDecl2.hs b/utils/check-exact/cases/RmDecl2.hs
new file mode 100644
index 0000000000..2f0dbd3ace
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl2.hs
@@ -0,0 +1,10 @@
+module RmDecl2 where
+
+sumSquares x y = let sq 0=0
+                     sq z=z^pow
+                     pow=2
+                 in sq x + sq y
+
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/RmDecl3.expected.hs b/utils/check-exact/cases/RmDecl3.expected.hs
new file mode 100644
index 0000000000..ca14f33ad5
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl3.expected.hs
@@ -0,0 +1,9 @@
+module RmDecl3 where
+
+-- Remove last declaration from a where clause, where should disappear too
+ff y = y + zz
+
+zz = 1
+
+foo = 3
+-- EOF
diff --git a/utils/check-exact/cases/RmDecl3.hs b/utils/check-exact/cases/RmDecl3.hs
new file mode 100644
index 0000000000..280bccf259
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl3.hs
@@ -0,0 +1,9 @@
+module RmDecl3 where
+
+-- Remove last declaration from a where clause, where should disappear too
+ff y = y + zz
+  where
+    zz = 1
+
+foo = 3
+-- EOF
diff --git a/utils/check-exact/cases/RmDecl4.expected.hs b/utils/check-exact/cases/RmDecl4.expected.hs
new file mode 100644
index 0000000000..e7c71dbd08
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl4.expected.hs
@@ -0,0 +1,10 @@
+module RmDecl4 where
+
+-- Remove first declaration from a where clause, last should still be indented
+ff y = y + zz + xx
+  where
+    xx = 2
+
+zz = 1
+
+-- EOF
diff --git a/utils/check-exact/cases/RmDecl4.hs b/utils/check-exact/cases/RmDecl4.hs
new file mode 100644
index 0000000000..532b738763
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl4.hs
@@ -0,0 +1,9 @@
+module RmDecl4 where
+
+-- Remove first declaration from a where clause, last should still be indented
+ff y = y + zz + xx
+  where
+    zz = 1
+    xx = 2
+
+-- EOF
diff --git a/utils/check-exact/cases/RmDecl5.expected.hs b/utils/check-exact/cases/RmDecl5.expected.hs
new file mode 100644
index 0000000000..67ac8ddfab
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl5.expected.hs
@@ -0,0 +1,5 @@
+module RmDecl5 where
+
+sumSquares x y = let pow=2
+                 in sq x + sq y
+
diff --git a/utils/check-exact/cases/RmDecl5.hs b/utils/check-exact/cases/RmDecl5.hs
new file mode 100644
index 0000000000..40f86199ce
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl5.hs
@@ -0,0 +1,7 @@
+module RmDecl5 where
+
+sumSquares x y = let sq 0=0
+                     sq z=z^pow
+                     pow=2
+                 in sq x + sq y
+
diff --git a/utils/check-exact/cases/RmDecl6.expected.hs b/utils/check-exact/cases/RmDecl6.expected.hs
new file mode 100644
index 0000000000..a2bd7d0443
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl6.expected.hs
@@ -0,0 +1,9 @@
+module RmDecl6 where
+
+foo a = baz
+  where
+    x = 1
+
+    y :: Int -> Int -> Int
+    y a b = undefined
+
diff --git a/utils/check-exact/cases/RmDecl6.hs b/utils/check-exact/cases/RmDecl6.hs
new file mode 100644
index 0000000000..cab5093ce8
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl6.hs
@@ -0,0 +1,12 @@
+module RmDecl6 where
+
+foo a = baz
+  where
+    baz :: Int
+    baz = x  + a
+
+    x = 1
+
+    y :: Int -> Int -> Int
+    y a b = undefined
+
diff --git a/utils/check-exact/cases/RmDecl7.expected.hs b/utils/check-exact/cases/RmDecl7.expected.hs
new file mode 100644
index 0000000000..9d7b8b9a69
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl7.expected.hs
@@ -0,0 +1,7 @@
+module RmDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+d = 9
+
diff --git a/utils/check-exact/cases/RmDecl7.hs b/utils/check-exact/cases/RmDecl7.hs
new file mode 100644
index 0000000000..62cefe2154
--- /dev/null
+++ b/utils/check-exact/cases/RmDecl7.hs
@@ -0,0 +1,9 @@
+module RmDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
+
diff --git a/utils/check-exact/cases/RmTypeSig1.expected.hs b/utils/check-exact/cases/RmTypeSig1.expected.hs
new file mode 100644
index 0000000000..46f7b13399
--- /dev/null
+++ b/utils/check-exact/cases/RmTypeSig1.expected.hs
@@ -0,0 +1,8 @@
+module RmTypeSig1 where
+
+anotherFun :: Int -> Int
+sq 0 = 0
+sq z = z^2
+
+anotherFun x = x^2
+
diff --git a/utils/check-exact/cases/RmTypeSig1.hs b/utils/check-exact/cases/RmTypeSig1.hs
new file mode 100644
index 0000000000..498892d791
--- /dev/null
+++ b/utils/check-exact/cases/RmTypeSig1.hs
@@ -0,0 +1,8 @@
+module RmTypeSig1 where
+
+sq,anotherFun :: Int -> Int
+sq 0 = 0
+sq z = z^2
+
+anotherFun x = x^2
+
diff --git a/utils/check-exact/cases/RmTypeSig2.expected.hs b/utils/check-exact/cases/RmTypeSig2.expected.hs
new file mode 100644
index 0000000000..c30e201bd0
--- /dev/null
+++ b/utils/check-exact/cases/RmTypeSig2.expected.hs
@@ -0,0 +1,7 @@
+module RmTypeSig2 where
+
+-- Pattern bind
+tup@(h,t) = (1,ff)
+  where
+    ff = 15
+
diff --git a/utils/check-exact/cases/RmTypeSig2.hs b/utils/check-exact/cases/RmTypeSig2.hs
new file mode 100644
index 0000000000..e8771f99dd
--- /dev/null
+++ b/utils/check-exact/cases/RmTypeSig2.hs
@@ -0,0 +1,8 @@
+module RmTypeSig2 where
+
+-- Pattern bind
+tup@(h,t) = (1,ff)
+  where
+    ff :: Int
+    ff = 15
+
diff --git a/utils/check-exact/cases/WhereIn3a.expected.hs b/utils/check-exact/cases/WhereIn3a.expected.hs
new file mode 100644
index 0000000000..acc94d3621
--- /dev/null
+++ b/utils/check-exact/cases/WhereIn3a.expected.hs
@@ -0,0 +1,20 @@
+module WhereIn3a where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the top level 'sq' to 'sumSquares'
+--In this case (there are multi matches), the parameters are not folded after demoting.
+
+sumSquares x y = sq p x + sq p y
+         where p=2  {-There is a comment-}
+
+sq :: Int -> Int -> Int
+sq pow 0 = 0      -- prior comment
+sq pow z = z^pow  --there is a comment
+
+-- A leading comment
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/WhereIn3a.hs b/utils/check-exact/cases/WhereIn3a.hs
new file mode 100644
index 0000000000..acc94d3621
--- /dev/null
+++ b/utils/check-exact/cases/WhereIn3a.hs
@@ -0,0 +1,20 @@
+module WhereIn3a where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the top level 'sq' to 'sumSquares'
+--In this case (there are multi matches), the parameters are not folded after demoting.
+
+sumSquares x y = sq p x + sq p y
+         where p=2  {-There is a comment-}
+
+sq :: Int -> Int -> Int
+sq pow 0 = 0      -- prior comment
+sq pow z = z^pow  --there is a comment
+
+-- A leading comment
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/WhereIn3b.expected.hs b/utils/check-exact/cases/WhereIn3b.expected.hs
new file mode 100644
index 0000000000..80ddc04825
--- /dev/null
+++ b/utils/check-exact/cases/WhereIn3b.expected.hs
@@ -0,0 +1,27 @@
+module WhereIn3a where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the top level 'sq' to 'sumSquares'
+--In this case (there are multi matches), the parameters are not folded after demoting.
+
+-- A leading comment
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
+sq pow 0 = 0      -- prior comment
+sq pow z = z^pow  --there is a comment
+
+sumSquares x y = sq p x + sq p y
+         where p=2  {-There is a comment-}
+
+sq :: Int -> Int -> Int
+sq pow 0 = 0      -- prior comment
+sq pow z = z^pow  --there is a comment
+
+-- A leading comment
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/WhereIn3b.hs b/utils/check-exact/cases/WhereIn3b.hs
new file mode 100644
index 0000000000..acc94d3621
--- /dev/null
+++ b/utils/check-exact/cases/WhereIn3b.hs
@@ -0,0 +1,20 @@
+module WhereIn3a where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the top level 'sq' to 'sumSquares'
+--In this case (there are multi matches), the parameters are not folded after demoting.
+
+sumSquares x y = sq p x + sq p y
+         where p=2  {-There is a comment-}
+
+sq :: Int -> Int -> Int
+sq pow 0 = 0      -- prior comment
+sq pow z = z^pow  --there is a comment
+
+-- A leading comment
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/WhereIn4.expected.hs b/utils/check-exact/cases/WhereIn4.expected.hs
new file mode 100644
index 0000000000..4357bfdac7
--- /dev/null
+++ b/utils/check-exact/cases/WhereIn4.expected.hs
@@ -0,0 +1,19 @@
+module WhereIn4 where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the top level 'sq' to 'sumSquares'
+--In this case (there is single matches), if possible,
+--the parameters will be folded after demoting and type sigature will be removed.
+
+sumSquares x y = sq p x + sq p y
+         where p_2=2  {-There is a comment-}
+
+sq::Int->Int->Int
+sq pow z = z^pow  --there is a comment
+
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/WhereIn4.hs b/utils/check-exact/cases/WhereIn4.hs
new file mode 100644
index 0000000000..8b941fff4a
--- /dev/null
+++ b/utils/check-exact/cases/WhereIn4.hs
@@ -0,0 +1,19 @@
+module WhereIn4 where
+
+--A definition can be demoted to the local 'where' binding of a friend declaration,
+--if it is only used by this friend declaration.
+
+--Demoting a definition narrows down the scope of the definition.
+--In this example, demote the top level 'sq' to 'sumSquares'
+--In this case (there is single matches), if possible,
+--the parameters will be folded after demoting and type sigature will be removed.
+
+sumSquares x y = sq p x + sq p y
+         where p=2  {-There is a comment-}
+
+sq::Int->Int->Int
+sq pow z = z^pow  --there is a comment
+
+anotherFun 0 y = sq y
+     where  sq x = x^2
+
diff --git a/utils/check-exact/cases/Windows.hs b/utils/check-exact/cases/Windows.hs
new file mode 100644
index 0000000000..ad8ae692b6
--- /dev/null
+++ b/utils/check-exact/cases/Windows.hs
@@ -0,0 +1,10 @@
+module Windows where
+
+{-
+ This file has windows-style line endings, to check that trailing
+ \r's get stripped in comments.
+-}
+baz = 2
+
+-- Another comment
+foo = 1
diff --git a/utils/check-exact/check-exact.cabal b/utils/check-exact/check-exact.cabal
new file mode 100644
index 0000000000..40188c094f
--- /dev/null
+++ b/utils/check-exact/check-exact.cabal
@@ -0,0 +1,38 @@
+Name: check-exact
+Version: 0.1
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: A utilities for checking the consistency of GHC's exact printer
+Description:
+    This utility is used to check the consistency of the GHC exact
+    printer, by parsing a file, exact printing it, and then comparing
+    it to the original version.  version. See
+    @utils/check-exact/README@ in GHC's source distribution for
+    details.
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable check-exact
+    Default-Language: Haskell2010
+    Main-Is: Main.hs
+    Ghc-Options: -Wall
+    other-modules: ExactPrint
+                   Lookup
+                   Parsers
+                   Preprocess
+                   Transform
+                   Types
+                   Utils
+    Build-Depends: base       >= 4   && < 5,
+                   bytestring,
+                   containers,
+                   Cabal      >= 3.2 && < 3.6,
+                   directory,
+                   filepath,
+                   ghc,
+                   ghc-boot,
+                   mtl
diff --git a/utils/check-api-annotations/ghc.mk b/utils/check-exact/ghc.mk
index 413d433ce5..f8ad02948b 100644
--- a/utils/check-api-annotations/ghc.mk
+++ b/utils/check-exact/ghc.mk
@@ -10,9 +10,9 @@
 #
 # -----------------------------------------------------------------------------
 
-utils/check-api-annotations_USES_CABAL                   = YES
-utils/check-api-annotations_PACKAGE                      = check-api-annotations
-utils/check-api-annotations_dist-install_PROGNAME        = check-api-annotations
-utils/check-api-annotations_dist-install_INSTALL         = NO
-utils/check-api-annotations_dist-install_INSTALL_INPLACE = YES
-$(eval $(call build-prog,utils/check-api-annotations,dist-install,2))
+utils/check-exact_USES_CABAL                   = YES
+utils/check-exact_PACKAGE                      = check-exact
+utils/check-exact_dist-install_PROGNAME        = check-exact
+utils/check-exact_dist-install_INSTALL         = NO
+utils/check-exact_dist-install_INSTALL_INPLACE = YES
+$(eval $(call build-prog,utils/check-exact,dist-install,2))
diff --git a/utils/check-exact/run.sh b/utils/check-exact/run.sh
new file mode 100755
index 0000000000..a4f0858128
--- /dev/null
+++ b/utils/check-exact/run.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+../../_build/stage1/bin/ghc --interactive
diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs
index 9d025633ef..0559e20f10 100644
--- a/utils/check-ppr/Main.hs
+++ b/utils/check-ppr/Main.hs
@@ -35,11 +35,11 @@ testOneFile libdir fileName = do
        p <- parseOneFile libdir fileName
        let
          origAst = showPprUnsafe
-                     $ showAstData BlankSrcSpan
+                     $ showAstData BlankSrcSpan BlankApiAnnotations
                      $ eraseLayoutInfo (pm_parsed_source p)
          pped    = pragmas ++ "\n" ++ pp (pm_parsed_source p)
-         anns    = pm_annotations p
-         pragmas = getPragmas anns
+         anns'   = pm_annotations p
+         pragmas = getPragmas anns'
 
          newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
          astFile = fileName <.> "ast"
@@ -52,7 +52,7 @@ testOneFile libdir fileName = do
 
        let newAstStr :: String
            newAstStr = showPprUnsafe
-                         $ showAstData BlankSrcSpan
+                         $ showAstData BlankSrcSpan BlankApiAnnotations
                          $ eraseLayoutInfo (pm_parsed_source p')
        writeFile newAstFile newAstStr
 
@@ -61,7 +61,7 @@ testOneFile libdir fileName = do
            -- putStrLn "ASTs matched"
            exitSuccess
          else do
-           putStrLn "AST Match Failed"
+           putStrLn "ppr AST Match Failed"
            putStrLn "\n===================================\nOrig\n\n"
            putStrLn origAst
            putStrLn "\n===================================\nNew\n\n"
@@ -92,14 +92,15 @@ parseOneFile libdir fileName = do
          parseModule modSum
 
 getPragmas :: ApiAnns -> String
-getPragmas anns = pragmaStr
+getPragmas anns' = pragmaStr
   where
-    tokComment (L _ (AnnBlockComment s)) = s
-    tokComment (L _ (AnnLineComment  s)) = s
+    tokComment (L _ (AnnComment (AnnBlockComment s) _)) = s
+    tokComment (L _ (AnnComment (AnnLineComment  s) _)) = s
     tokComment _ = ""
 
-    comments = map tokComment $ sortRealLocated $ apiAnnRogueComments anns
-    pragmas = filter (\c -> isPrefixOf "{-#" c ) comments
+    cmp (L l1 _) (L l2 _) = compare (anchor l1) (anchor l2)
+    comments' = map tokComment $ sortBy cmp $ apiAnnRogueComments anns'
+    pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
     pragmaStr = intercalate "\n" pragmas
 
 pp :: (Outputable a) => a -> String
diff --git a/utils/haddock b/utils/haddock
-Subproject d930bd87cd43d840bf2877e4a51b2a48c2e18f7
+Subproject 3eb51fa32aaefe80bf2b6731dae2a2b26aba9e7