diff --git a/ChangeLog b/ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,5 @@
+2019-05-27 v0.6.1
+        * Support GHC 8.8 (alpha1)
 2019-03-01 v0.6
         * Remove orphan MonadFail Identity instance
 	* MonadFail TransformT instance is defined unconditionally
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -1,5 +1,5 @@
 name:                ghc-exactprint
-version:             0.6
+version:             0.6.1
 synopsis:            ExactPrint for GHC
 description:         Using the API Annotations available from GHC 7.10.2, this
                      library provides a means to round trip any code that can
@@ -38,7 +38,8 @@
                    , GHC == 8.4.4
                    , GHC == 8.6.1
                    , GHC == 8.6.2
-                   , GHC == 8.6.3
+                   , GHC == 8.6.4
+                   , GHC == 8.6.5
 extra-source-files:  ChangeLog
                      src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs
                      tests/examples/failing/*.hs
@@ -48,6 +49,7 @@
                      tests/examples/ghc82/*.hs
                      tests/examples/ghc84/*.hs
                      tests/examples/ghc86/*.hs
+                     tests/examples/ghc88/*.hs
                      tests/examples/pre-ghc86/*.hs
                      tests/examples/vect/*.hs
                      tests/examples/transform/*.hs
@@ -92,7 +94,7 @@
   -- other-modules:
   -- other-extensions:
   GHC-Options:         -Wall
-  build-depends:       base >=4.8 && <4.13
+  build-depends:       base >=4.8 && <4.14
                      , bytestring >= 0.10.6
                      , containers >= 0.5
                      , directory >= 1.2
@@ -111,19 +113,22 @@
       build-depends: ghc-boot
   hs-source-dirs:      src
 
-  if impl (ghc > 8.4.4)
-      hs-source-dirs: src-ghc86
+  if impl (ghc > 8.6.5)
+      hs-source-dirs: src-ghc88
   else
-    if impl (ghc > 8.2.2)
-        hs-source-dirs: src-ghc84
+    if impl (ghc > 8.4.4)
+        hs-source-dirs: src-ghc86
     else
-      if impl (ghc > 8.0.3)
-          hs-source-dirs: src-ghc82
+      if impl (ghc > 8.2.2)
+          hs-source-dirs: src-ghc84
       else
-        if impl (ghc > 7.10.3)
-            hs-source-dirs: src-ghc80
+        if impl (ghc > 8.0.3)
+            hs-source-dirs: src-ghc82
         else
-            hs-source-dirs: src-ghc710
+          if impl (ghc > 7.10.3)
+              hs-source-dirs: src-ghc80
+          else
+              hs-source-dirs: src-ghc710
 
   default-language:    Haskell2010
   if impl (ghc < 7.10.2)
@@ -137,19 +142,22 @@
   else
     hs-source-dirs:      tests
 
-  if impl (ghc > 8.4.4)
-      hs-source-dirs: src-ghc86
+  if impl (ghc > 8.6.5)
+      hs-source-dirs: src-ghc88
   else
-    if impl (ghc > 8.2.2)
-        hs-source-dirs: src-ghc84
+    if impl (ghc > 8.4.4)
+        hs-source-dirs: src-ghc86
     else
-      if impl (ghc > 8.0.3)
-          hs-source-dirs: src-ghc82
+      if impl (ghc > 8.2.2)
+          hs-source-dirs: src-ghc84
       else
-        if impl (ghc > 7.10.3)
-            hs-source-dirs: src-ghc80
+        if impl (ghc > 8.0.3)
+            hs-source-dirs: src-ghc82
         else
-            hs-source-dirs: src-ghc710
+          if impl (ghc > 7.10.3)
+              hs-source-dirs: src-ghc80
+          else
+              hs-source-dirs: src-ghc710
 
   main-is:             Test.hs
   other-modules:       Test.Common
@@ -161,7 +169,7 @@
   if impl (ghc < 7.10.2)
       buildable: False
   Build-depends:       HUnit >= 1.2
-                     , base < 4.13
+                     , base < 4.14
                      , bytestring
                      , containers >= 0.5
                      , Diff
diff --git a/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs
new file mode 100644
--- /dev/null
+++ b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs
@@ -0,0 +1,2938 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ViewPatterns      #-}
+
+
+-- | 'annotate' is a function which given a GHC AST fragment, constructs
+-- a syntax tree which indicates which annotations belong to each specific
+-- part of the fragment.
+--
+-- "Delta" and "Print" provide two interpreters for this structure. You
+-- should probably use those unless you know what you're doing!
+--
+-- The functor 'AnnotationF' has a number of constructors which correspond
+-- to different sitations which annotations can arise. It is hoped that in
+-- future versions of GHC these can be simplified by making suitable
+-- modifications to the AST.
+
+module Language.Haskell.GHC.ExactPrint.Annotater
+       (
+         annotate
+       , AnnotationF(..)
+       , Annotated
+       , Annotate(..)
+       , withSortKeyContextsHelper
+       ) where
+
+
+import Language.Haskell.GHC.ExactPrint.AnnotateTypes
+import Language.Haskell.GHC.ExactPrint.Types
+import Language.Haskell.GHC.ExactPrint.Utils
+
+import qualified Bag            as GHC
+import qualified BasicTypes     as GHC
+import qualified BooleanFormula as GHC
+import qualified Class          as GHC
+import qualified CoAxiom        as GHC
+import qualified FastString     as GHC
+import qualified ForeignCall    as GHC
+import qualified GHC            as GHC
+--  import qualified HsDoc          as GHC
+import qualified Name           as GHC
+import qualified RdrName        as GHC
+import qualified Outputable     as GHC
+import qualified SrcLoc         as GHC
+
+import Control.Monad.Identity
+import Data.Data
+import Data.Maybe
+
+import qualified Data.Set as Set
+
+import Debug.Trace
+
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+{-# ANN module "HLint: ignore Redundant do" #-}
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+-- ---------------------------------------------------------------------
+
+class Data ast => Annotate ast where
+  markAST :: GHC.SrcSpan -> ast -> Annotated ()
+
+-- ---------------------------------------------------------------------
+
+-- | Construct a syntax tree which represent which KeywordIds must appear
+-- where.
+annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated ()
+annotate = markLocated
+
+-- instance Annotate (GHC.SrcSpanLess ast) where
+--   markAST s ast = undefined
+instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where
+  markAST l (GHC.L _ ast) = markAST l ast
+
+-- ---------------------------------------------------------------------
+
+-- | Constructs a syntax tree which contains information about which
+-- annotations are required by each element.
+markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast,  GHC.HasSrcSpan ast)
+             => ast -> Annotated ()
+markLocated ast =
+  case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of
+    Just d  -> markLHsDecl d
+    Nothing -> withLocated ast markAST
+
+-- ---------------------------------------------------------------------
+
+-- |When adding missing annotations, do not put a preceding space in front of a list
+markListNoPrecedingSpace :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+                         => Bool -> [ast] -> Annotated ()
+markListNoPrecedingSpace intercal ls =
+    case ls of
+      [] -> return ()
+      (l:ls') -> do
+        if intercal
+        then do
+          if null ls'
+            then setContext (Set.fromList [NoPrecedingSpace            ]) $ markLocated l
+            else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l
+          markListIntercalate ls'
+        else do
+          setContext (Set.singleton NoPrecedingSpace) $ markLocated l
+          mapM_ markLocated ls'
+
+-- ---------------------------------------------------------------------
+
+
+-- |Mark a list, with the given keyword as a list item separator
+markListIntercalate :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+                    => [ast] -> Annotated ()
+markListIntercalate ls = markListIntercalateWithFun markLocated ls
+
+-- ---------------------------------------------------------------------
+
+markListWithContexts :: Annotate ast
+  => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated ()
+markListWithContexts ctxInitial ctxRest ls =
+  case ls of
+    [] -> return ()
+    [x] -> setContextLevel ctxInitial 2 $ markLocated x
+    (x:xs) -> do
+      setContextLevel ctxInitial 2 $ markLocated x
+      setContextLevel ctxRest    2 $ mapM_ markLocated xs
+
+-- ---------------------------------------------------------------------
+
+-- Context for only if just one, else first item, middle ones, and last one
+markListWithContexts' :: Annotate ast
+                      => ListContexts
+                      -> [GHC.Located ast] -> Annotated ()
+markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls =
+  case ls of
+    [] -> return ()
+    [x] -> setContextLevel ctxOnly level $ markLocated x
+    (x:xs) -> do
+      setContextLevel ctxInitial level $ markLocated x
+      go xs
+  where
+    level = 2
+    go []  = return ()
+    go [x] = setContextLevel ctxLast level $ markLocated x
+    go (x:xs) = do
+      setContextLevel ctxMiddle level $ markLocated x
+      go xs
+
+
+-- ---------------------------------------------------------------------
+
+markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markListWithLayout ls =
+  setLayoutFlag $ markList ls
+
+-- ---------------------------------------------------------------------
+
+markList :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markList ls =
+  setContext (Set.singleton NoPrecedingSpace)
+   $ markListWithContexts' listContexts' ls
+
+markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()
+markLocalBindsWithLayout binds = markHsLocalBinds binds
+
+-- ---------------------------------------------------------------------
+
+-- |This function is used to get around shortcomings in the GHC AST for 7.10.1
+markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated ()
+markLocatedFromKw kw (GHC.L l a) = do
+  -- Note: l is needed so that the pretty printer can make something up
+  ss <- getSrcSpanForKw l kw
+  AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a))
+  markLocated (GHC.L ss' a)
+
+-- ---------------------------------------------------------------------
+
+markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()
+markMaybe Nothing    = return ()
+markMaybe (Just ast) = markLocated ast
+
+-- ---------------------------------------------------------------------
+-- Managing lists which have been separated, e.g. Sigs and Binds
+
+prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())]
+prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsModule GHC.GhcPs) where
+  markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do
+
+    case mmn of
+      Nothing -> return ()
+      Just (GHC.L ln mn) -> do
+        mark GHC.AnnModule
+        markExternal ln GHC.AnnVal (GHC.moduleNameString mn)
+
+        forM_ mdepr markLocated
+        forM_ mexp markLocated
+
+        mark GHC.AnnWhere
+
+    markOptional GHC.AnnOpenC -- Possible '{'
+    markManyOptional GHC.AnnSemi -- possible leading semis
+    setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps
+
+    setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs
+
+    markOptional GHC.AnnCloseC -- Possible '}'
+
+    markEOF
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.WarningTxt where
+  markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do
+    markAnnOpen txt "{-# WARNING"
+    mark GHC.AnnOpenS
+    markListIntercalate lss
+    mark GHC.AnnCloseS
+    markWithString GHC.AnnClose "#-}"
+
+  markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do
+    markAnnOpen txt "{-# DEPRECATED"
+    mark GHC.AnnOpenS
+    markListIntercalate lss
+    mark GHC.AnnCloseS
+    markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.StringLiteral where
+  markAST l (GHC.StringLiteral src fs) = do
+    markExternalSourceText l src (show (GHC.unpackFS fs))
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.SourceText,GHC.FastString) where
+  markAST l (src,fs) = do
+    markExternalSourceText l src (show (GHC.unpackFS fs))
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LIE GHC.GhcPs] where
+   markAST _ ls = do
+     inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl
+     mark GHC.AnnOpenP -- '('
+     -- Can't use markListIntercalate, there can be trailing commas, but only in imports.
+     markListIntercalateWithFunLevel markLocated 2 ls
+
+     mark GHC.AnnCloseP -- ')'
+
+instance Annotate (GHC.IE GHC.GhcPs) where
+  markAST _ ie = do
+
+    case ie of
+        GHC.IEVar _ ln -> markLocated ln
+
+        GHC.IEThingAbs _ ln -> do
+          setContext (Set.singleton PrefixOp) $ markLocated ln
+
+        GHC.IEThingWith _ ln wc ns _lfs -> do
+          setContext (Set.singleton PrefixOp) $ markLocated ln
+          mark GHC.AnnOpenP
+          case wc of
+            GHC.NoIEWildcard ->
+              unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+                $ markListIntercalate ns
+            GHC.IEWildcard n -> do
+              setContext (Set.fromList [PrefixOp,Intercalate])
+                $ mapM_ markLocated (take n ns)
+              mark GHC.AnnDotdot
+              case drop n ns of
+                [] -> return ()
+                ns' -> do
+                  mark GHC.AnnComma
+                  unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+                    $ markListIntercalate ns'
+          mark GHC.AnnCloseP
+
+        (GHC.IEThingAll _ ln) -> do
+          setContext (Set.fromList [PrefixOp]) $ markLocated ln
+          mark GHC.AnnOpenP
+          mark GHC.AnnDotdot
+          mark GHC.AnnCloseP
+
+        (GHC.IEModuleContents _ (GHC.L lm mn)) -> do
+          mark GHC.AnnModule
+          markExternal lm GHC.AnnVal (GHC.moduleNameString mn)
+
+        -- Only used in Haddock mode so we can ignore them.
+        (GHC.IEGroup {})    -> return ()
+
+        (GHC.IEDoc {})      -> return ()
+
+        (GHC.IEDocNamed {}) -> return ()
+        GHC.XIE x -> error $ "got XIE for :" ++ showGhc x
+    ifInContext (Set.fromList [Intercalate])
+      (mark         GHC.AnnComma)
+      (markOptional GHC.AnnComma)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.IEWrappedName GHC.RdrName) where
+  markAST _ (GHC.IEName ln) = do
+    unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+      $ markLocated ln
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+  markAST _ (GHC.IEPattern ln) = do
+    mark GHC.AnnPattern
+    setContext (Set.singleton PrefixOp) $ markLocated ln
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+  markAST _ (GHC.IEType ln) = do
+    mark GHC.AnnType
+    setContext (Set.singleton PrefixOp) $ markLocated ln
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+isSymRdr :: GHC.RdrName -> Bool
+isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "."
+
+instance Annotate GHC.RdrName where
+  markAST l n = do
+    let
+      str = rdrName2String n
+      isSym = isSymRdr n
+      doNormalRdrName = do
+        let str' = case str of
+              -- TODO: unicode support?
+                        "forall" -> if spanLength l == 1 then "∀" else str
+                        _ -> str
+
+        let
+          markParen :: GHC.AnnKeywordId -> Annotated ()
+          markParen pa = do
+            if isSym
+              then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar])
+                                       (mark         pa) -- '('
+                                       (markOptional pa)
+              else markOptional pa
+
+        markOptional GHC.AnnSimpleQuote
+        markParen GHC.AnnOpenP
+        unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0
+        cnt  <- countAnns GHC.AnnVal
+        case cnt of
+          0 -> markExternal l GHC.AnnVal str'
+          1 -> markWithString GHC.AnnVal str'
+          _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)
+        unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1
+        markParen GHC.AnnCloseP
+
+    case n of
+      GHC.Unqual _ -> doNormalRdrName
+      GHC.Qual _ _ -> doNormalRdrName
+      GHC.Orig _ _ -> if str == "~"
+                        then doNormalRdrName
+                        -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen)
+                        else markExternal l GHC.AnnVal str
+      -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str
+      -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]"
+      GHC.Exact n'  -> do
+       case str of
+         -- Special handling for Exact RdrNames, which are built-in Names
+         "[]" -> do
+           mark GHC.AnnOpenS  -- '['
+           mark GHC.AnnCloseS -- ']'
+         "()" -> do
+           mark GHC.AnnOpenP  -- '('
+           mark GHC.AnnCloseP -- ')'
+         ('(':'#':_) -> do
+           markWithString GHC.AnnOpen  "(#" -- '(#'
+           let cnt = length $ filter (==',') str
+           replicateM_ cnt (mark GHC.AnnCommaTuple)
+           markWithString GHC.AnnClose  "#)"-- '#)'
+         "[::]" -> do
+           markWithString GHC.AnnOpen  "[:" -- '[:'
+           markWithString GHC.AnnClose ":]" -- ':]'
+         "->" -> do
+           mark GHC.AnnOpenP -- '('
+           mark GHC.AnnRarrow
+           mark GHC.AnnCloseP -- ')'
+         -- "~#"  -> do
+         --   mark GHC.AnnOpenP -- '('
+         --   mark GHC.AnnTildehsh
+         --   mark GHC.AnnCloseP
+         "~"  -> do
+           doNormalRdrName
+         "*"  -> do
+           markExternal l GHC.AnnVal str
+         "★"  -> do -- Note: unicode star
+           markExternal l GHC.AnnVal str
+         ":"  -> do
+           -- Note: The OccName for ":" has the following attributes (via occAttributes)
+           -- (d, Data DataSym Sym Val )
+           -- consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
+           doNormalRdrName
+           -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName
+         ('(':',':_) -> do
+           mark GHC.AnnOpenP
+           let cnt = length $ filter (==',') str
+           replicateM_ cnt (mark GHC.AnnCommaTuple)
+           mark GHC.AnnCloseP -- ')'
+         _ -> do
+            let isSym' = isSymRdr  (GHC.nameRdrName n')
+            when isSym' $ mark GHC.AnnOpenP -- '('
+            markWithString GHC.AnnVal str
+            when isSym $ mark GHC.AnnCloseP -- ')'
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ImportDecl GHC.GhcPs) where
+ markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do
+
+   -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
+   mark GHC.AnnImport
+
+   -- "{-# SOURCE" and "#-}"
+   case msrc of
+     GHC.SourceText _txt -> do
+       markAnnOpen msrc "{-# SOURCE"
+       markWithString GHC.AnnClose "#-}"
+     GHC.NoSourceText -> return ()
+   when safeflag (mark GHC.AnnSafe)
+   when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)
+   case mpkg of
+    Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) ->
+      markWithString GHC.AnnPackageName srcPkg
+    _ -> return ()
+
+   markLocated modname
+
+   case GHC.ideclAs imp of
+      Nothing -> return ()
+      Just mn -> do
+          mark GHC.AnnAs
+          markLocated mn
+
+   case hiding of
+     Nothing -> return ()
+     Just (isHiding,lie) -> do
+       if isHiding
+         then setContext (Set.singleton HasHiding) $
+                markLocated lie
+         else markLocated lie
+   markTrailingSemi
+
+ markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.ModuleName where
+   markAST l mname =
+    markExternal l GHC.AnnVal (GHC.moduleNameString mname)
+
+-- ---------------------------------------------------------------------
+
+markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated ()
+markLHsDecl (GHC.L l decl) =
+    case decl of
+      GHC.TyClD _ d       -> markLocated (GHC.L l d)
+      GHC.InstD _ d       -> markLocated (GHC.L l d)
+      GHC.DerivD _ d      -> markLocated (GHC.L l d)
+      GHC.ValD _ d        -> markLocated (GHC.L l d)
+      GHC.SigD _ d        -> markLocated (GHC.L l d)
+      GHC.DefD _ d        -> markLocated (GHC.L l d)
+      GHC.ForD _ d        -> markLocated (GHC.L l d)
+      GHC.WarningD _ d    -> markLocated (GHC.L l d)
+      GHC.AnnD _ d        -> markLocated (GHC.L l d)
+      GHC.RuleD _ d       -> markLocated (GHC.L l d)
+      GHC.SpliceD _ d     -> markLocated (GHC.L l d)
+      GHC.DocD _ d        -> markLocated (GHC.L l d)
+      GHC.RoleAnnotD _ d  -> markLocated (GHC.L l d)
+      GHC.XHsDecl x  -> error $ "got XHsDecl for:" ++ showGhc x
+
+instance Annotate (GHC.HsDecl GHC.GhcPs) where
+  markAST l d = markLHsDecl (GHC.L l d)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where
+  markAST _ (GHC.RoleAnnotDecl _ ln mr) = do
+    mark GHC.AnnType
+    mark GHC.AnnRole
+    setContext (Set.singleton PrefixOp) $ markLocated ln
+    mapM_ markLocated mr
+  markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x
+
+instance Annotate (Maybe GHC.Role) where
+  markAST l Nothing  = markExternal l GHC.AnnVal "_"
+  markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.SpliceDecl GHC.GhcPs) where
+  markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do
+    markLocated e
+    markTrailingSemi
+  markAST _ (GHC.SpliceDecl _ e _flag) = do
+    markLocated e
+    markTrailingSemi
+
+  markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RuleDecls GHC.GhcPs) where
+  markAST _ (GHC.HsRules _ src rules) = do
+    markAnnOpen src "{-# RULES"
+    setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules
+    markWithString GHC.AnnClose "#-}"
+    markTrailingSemi
+  markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RuleDecl GHC.GhcPs) where
+  markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do
+    markLocated ln
+    setContext (Set.singleton ExplicitNeverActive) $ markActivation l act
+
+    case mtybndrs of
+      Nothing -> return ()
+      Just bndrs -> do
+        mark GHC.AnnForall
+        mapM_ markLocated bndrs
+        mark GHC.AnnDot
+
+    mark GHC.AnnForall
+    mapM_ markLocated termbndrs
+    mark GHC.AnnDot
+
+    markLocated lhs
+    mark GHC.AnnEqual
+    markLocated rhs
+    inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi
+    markTrailingSemi
+{-
+  = HsRule -- Source rule
+       { rd_ext  :: XHsRule pass
+           -- ^ After renamer, free-vars from the LHS and RHS
+       , rd_name :: Located (SourceText,RuleName)
+           -- ^ Note [Pragma source text] in BasicTypes
+       , rd_act  :: Activation
+       , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]
+           -- ^ Forall'd type vars
+       , rd_tmvs :: [LRuleBndr pass]
+           -- ^ Forall'd term vars, before typechecking; after typechecking
+           --    this includes all forall'd vars
+       , rd_lhs  :: Located (HsExpr pass)
+       , rd_rhs  :: Located (HsExpr pass)
+       }
+
+-}
+
+  markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated ()
+markActivation _ act = do
+  case act of
+    GHC.ActiveBefore src phase -> do
+      mark GHC.AnnOpenS --  '['
+      mark GHC.AnnTilde -- ~
+      markSourceText src (show phase)
+      mark GHC.AnnCloseS -- ']'
+    GHC.ActiveAfter src phase -> do
+      mark GHC.AnnOpenS --  '['
+      markSourceText src (show phase)
+      mark GHC.AnnCloseS -- ']'
+    GHC.NeverActive -> do
+      inContext (Set.singleton ExplicitNeverActive) $ do
+        mark GHC.AnnOpenS --  '['
+        mark GHC.AnnTilde -- ~
+        mark GHC.AnnCloseS -- ']'
+    _ -> return ()
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RuleBndr GHC.GhcPs) where
+  markAST _ (GHC.RuleBndr _ ln) = markLocated ln
+  markAST _ (GHC.RuleBndrSig _ ln st) = do
+    mark GHC.AnnOpenP -- "("
+    markLocated ln
+    mark GHC.AnnDcolon
+    markLHsSigWcType st
+    mark GHC.AnnCloseP -- ")"
+  markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated ()
+markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do
+  markLocated ty
+markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit"
+markLHsSigWcType (GHC.XHsWildCardBndrs _)              = error "markLHsSigWcType extension hit"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.AnnDecl GHC.GhcPs) where
+   markAST _ (GHC.HsAnnotation _ src prov e) = do
+     markAnnOpen src "{-# ANN"
+     case prov of
+       (GHC.ValueAnnProvenance n) -> markLocated n
+       (GHC.TypeAnnProvenance n) -> do
+         mark GHC.AnnType
+         markLocated n
+       GHC.ModuleAnnProvenance -> mark GHC.AnnModule
+
+     markLocated e
+     markWithString GHC.AnnClose "#-}"
+     markTrailingSemi
+
+   markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.WarnDecls GHC.GhcPs) where
+   markAST _ (GHC.Warnings _ src warns) = do
+     markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED
+     mapM_ markLocated warns
+     markWithString GHC.AnnClose "#-}"
+
+   markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.WarnDecl GHC.GhcPs) where
+   markAST _ (GHC.Warning _ lns txt) = do
+     markListIntercalate lns
+     mark GHC.AnnOpenS -- "["
+     case txt of
+       GHC.WarningTxt    _src ls -> markListIntercalate ls
+       GHC.DeprecatedTxt _src ls -> markListIntercalate ls
+     mark GHC.AnnCloseS -- "]"
+
+   markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x
+
+instance Annotate GHC.FastString where
+  -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
+  markAST l fs = do
+    markExternal l GHC.AnnVal (show (GHC.unpackFS fs))
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ForeignDecl GHC.GhcPs) where
+  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
+
+  markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do
+    mark GHC.AnnForeign
+    mark GHC.AnnExport
+    markLocated spec
+    markExternal ls GHC.AnnVal (sourceTextToString src "")
+    setContext (Set.singleton PrefixOp) $ markLocated ln
+    mark GHC.AnnDcolon
+    markLocated typ
+
+
+  markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion"
+  markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion"
+  markAST _ (GHC.XForeignDecl _)                               = error "markAST ForeignDecl hit extenstion"
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate GHC.CExportSpec) where
+  markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate GHC.CCallConv) where
+  markAST l GHC.StdCallConv        =  markExternal l GHC.AnnVal "stdcall"
+  markAST l GHC.CCallConv          =  markExternal l GHC.AnnVal "ccall"
+  markAST l GHC.CApiConv           =  markExternal l GHC.AnnVal "capi"
+  markAST l GHC.PrimCallConv       =  markExternal l GHC.AnnVal "prim"
+  markAST l GHC.JavaScriptCallConv =  markExternal l GHC.AnnVal "javascript"
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate GHC.Safety) where
+  markAST l GHC.PlayRisky         = markExternal l GHC.AnnVal "unsafe"
+  markAST l GHC.PlaySafe          = markExternal l GHC.AnnVal "safe"
+  markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DerivDecl GHC.GhcPs) where
+
+  markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do
+    mark GHC.AnnDeriving
+    markMaybe ms
+    mark GHC.AnnInstance
+    markMaybe mov
+    markLocated typ
+    markTrailingSemi
+
+{-
+data DerivDecl pass = DerivDecl
+        { deriv_ext          :: XCDerivDecl pass
+        , deriv_type         :: LHsSigWcType pass
+          -- ^ The instance type to derive.
+          --
+          -- It uses an 'LHsSigWcType' because the context is allowed to be a
+          -- single wildcard:
+          --
+          -- > deriving instance _ => Eq (Foo a)
+          --
+          -- Which signifies that the context should be inferred.
+
+          -- See Note [Inferring the instance context] in TcDerivInfer.
+
+        , deriv_strategy     :: Maybe (LDerivStrategy pass)
+        , deriv_overlap_mode :: Maybe (Located OverlapMode)
+
+type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
+
+data HsWildCardBndrs pass thing
+    -- See Note [HsType binders]
+    -- See Note [The wildcard story for types]
+  = HsWC { hswc_ext :: XHsWC pass thing
+                -- after the renamer
+                -- Wild cards, both named and anonymous
+
+         , hswc_body :: thing
+                -- Main payload (type or list of types)
+                -- If there is an extra-constraints wildcard,
+                -- it's still there in the hsc_body.
+    }
+
+
+-}
+
+
+  markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension"
+  markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _)              = error "markAST DerivDecl hit extension"
+  markAST _ (GHC.XDerivDecl _)                                          = error "markAST DerivDecl hit extension"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DerivStrategy GHC.GhcPs) where
+
+  markAST _ GHC.StockStrategy    = mark GHC.AnnStock
+  markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass
+  markAST _ GHC.NewtypeStrategy  = mark GHC.AnnNewtype
+  markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do
+    mark GHC.AnnVia
+    markLocated ty
+  markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _))
+    = error $ "got XHsImplicitBndrs in AnnDerivStrategy"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DefaultDecl GHC.GhcPs) where
+
+  markAST _ (GHC.DefaultDecl _ typs) = do
+    mark GHC.AnnDefault
+    mark GHC.AnnOpenP -- '('
+    markListIntercalate typs
+    mark GHC.AnnCloseP -- ')'
+    markTrailingSemi
+
+  markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+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:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.OverlapMode where
+
+  -- NOTE: NoOverlap is only used in the typechecker
+  markAST _ (GHC.NoOverlap src) = do
+    markAnnOpen src "{-# NO_OVERLAP"
+    markWithString GHC.AnnClose "#-}"
+
+  markAST _ (GHC.Overlappable src) = do
+    markAnnOpen src "{-# OVERLAPPABLE"
+    markWithString GHC.AnnClose "#-}"
+
+  markAST _ (GHC.Overlapping src) = do
+    markAnnOpen src "{-# OVERLAPPING"
+    markWithString GHC.AnnClose "#-}"
+
+  markAST _ (GHC.Overlaps src) = do
+    markAnnOpen src "{-# OVERLAPS"
+    markWithString GHC.AnnClose "#-}"
+
+  markAST _ (GHC.Incoherent src) = do
+    markAnnOpen src "{-# INCOHERENT"
+    markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where
+
+  markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do
+    mark GHC.AnnInstance
+    markMaybe mov
+    markLocated poly
+    mark GHC.AnnWhere
+    markOptional GHC.AnnOpenC -- '{'
+    markInside GHC.AnnSemi
+
+    applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds)
+                             ++ prepareListAnnotation sigs
+                             ++ prepareListAnnotation tyfams
+                             ++ prepareListAnnotation datafams
+                               )
+
+    markOptional GHC.AnnCloseC -- '}'
+    markTrailingSemi
+
+  markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl"
+  markAST _ (GHC.XClsInstDecl _)                                   = error "extension hit for ClsInstDecl"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where
+{-
+newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
+
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
+
+type FamInstEqn pass rhs
+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+
+
+-}
+  markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do
+    mark GHC.AnnType
+    mark GHC.AnnInstance -- Note: this keyword is optional
+    markFamEqn eqn
+    markTrailingSemi
+
+  markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl"
+
+-- ---------------------------------------------------------------------
+
+-- markFamEqn :: (GHC.HasOccName (GHC.IdP pass),
+--                Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)
+--            => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2)
+--                     -> Annotated ()
+markFamEqn :: GHC.FamEqn GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs)
+           -> Annotated ()
+markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do
+  markTyClassArgs bndrs fixity ln pats
+  mark GHC.AnnEqual
+  markLocated rhs
+{-
+data FamEqn pass pats rhs
+  = FamEqn
+       { feqn_ext    :: XCFamEqn pass pats rhs
+       , feqn_tycon  :: Located (IdP pass)
+       , feqn_bndrs  :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars
+       , feqn_pats   :: pats
+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+       , feqn_rhs    :: rhs
+       }
+-}
+
+markFamEqn (GHC.XFamEqn _) = error "got XFamEqn"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where
+
+  markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs pats fixity
+             defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do
+    case GHC.dd_ND defn of
+      GHC.NewType  -> mark GHC.AnnNewtype
+      GHC.DataType -> mark GHC.AnnData
+    mark GHC.AnnInstance
+
+    markLocated ctx
+
+    markTyClassArgs bndrs fixity ln pats
+
+    case (GHC.dd_kindSig defn) of
+      Just s -> do
+        mark GHC.AnnDcolon
+        markLocated s
+      Nothing -> return ()
+    if isGadt $ GHC.dd_cons defn
+      then mark GHC.AnnWhere
+      else unless (null cons) $ mark GHC.AnnEqual
+    markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs)
+    markTrailingSemi
+
+  markAST _
+            (GHC.DataFamInstDecl
+             (GHC.HsIB _ (GHC.FamEqn _ _ _ _ _ (GHC.XHsDataDefn _))))
+    = error "extension hit for DataFamInstDecl"
+  markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _)))
+    = error "extension hit for DataFamInstDecl"
+  markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _))
+    = error "extension hit for DataFamInstDecl"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsBind GHC.GhcPs) where
+  markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do
+    -- Note: from a layout perspective a FunBind should not exist, so the
+    -- current context is passed through unchanged to the matches.
+    -- TODO: perhaps bring the edp from the first match up to the annotation for
+    -- the FunBind.
+    let
+      tlFun =
+        ifInContext (Set.fromList [CtxOnly,CtxFirst])
+          (markListWithContexts' listContexts matches)
+          (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches)
+    ifInContext (Set.singleton TopLevel)
+      (setContextLevel (Set.singleton TopLevel) 2 tlFun)
+      tlFun
+
+  -- -----------------------------------
+
+  markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do
+    markLocated lhs
+    case grhs of
+      (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards
+      _ -> return ()
+    markListIntercalateWithFunLevel markLocated 2 grhs
+
+    -- TODO: extract this common code
+    case lb of
+      GHC.EmptyLocalBinds{} -> return ()
+      _ -> do
+        mark GHC.AnnWhere
+        markOptional GHC.AnnOpenC -- '{'
+        markInside GHC.AnnSemi
+        markLocalBindsWithLayout lb
+        markOptional GHC.AnnCloseC -- '}'
+    markTrailingSemi
+
+  -- -----------------------------------
+
+  markAST _ (GHC.VarBind _ _n rhse _) =
+    -- Note: this bind is introduced by the typechecker
+    markLocated rhse
+
+  -- -----------------------------------
+
+  -- Introduced after renaming.
+  markAST _ (GHC.AbsBinds {}) =
+    traceM "warning: AbsBinds introduced after renaming"
+
+  -- -----------------------------------
+
+  markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do
+    mark GHC.AnnPattern
+    case args of
+      GHC.InfixCon la lb -> do
+        markLocated la
+        setContext (Set.singleton InfixOp) $ markLocated ln
+        markLocated lb
+      GHC.PrefixCon ns -> do
+        setContext (Set.singleton PrefixOp) $ markLocated ln
+        mapM_ markLocated ns
+      GHC.RecCon fs -> do
+        markLocated ln
+        mark GHC.AnnOpenC  -- '{'
+        markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs
+        mark GHC.AnnCloseC -- '}'
+    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
+
+  -- -----------------------------------
+
+  markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _)
+    = error "extension hit for HsBind"
+  markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _)
+    = error "extension hit for HsBind"
+  markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _))
+    = error "extension hit for HsBind"
+  markAST _ (GHC.XHsBindsLR _)
+    = error "extension hit for HsBind"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.IPBind GHC.GhcPs) where
+  markAST _ (GHC.IPBind _ en e) = do
+    case en of
+      Left n   -> markLocated n
+      Right _i -> return ()
+    mark GHC.AnnEqual
+    markLocated e
+    markTrailingSemi
+
+  -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x
+  markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.HsIPName where
+  markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+  => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where
+
+  markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do
+    let
+      get_infix (GHC.FunRhs _ f _) = f
+      get_infix _                  = GHC.Prefix
+
+      isFunBind GHC.FunRhs{} = True
+      isFunBind _            = False
+    case (get_infix mln,pats) of
+      (GHC.Infix, a:b:xs) -> do
+        if null xs
+          then markOptional GHC.AnnOpenP
+          else mark         GHC.AnnOpenP
+        markLocated a
+        case mln of
+          GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n
+          _              -> return ()
+        markLocated b
+        if null xs
+         then markOptional GHC.AnnCloseP
+         else mark         GHC.AnnCloseP
+        mapM_ markLocated xs
+      _ -> do
+        annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+        inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam
+        case mln of
+          GHC.FunRhs n _ s -> do
+            setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do
+              when (s == GHC.SrcStrict) $ mark GHC.AnnBang
+              markLocated n
+            mapM_ markLocated pats
+          _  -> markListNoPrecedingSpace False pats
+
+    -- TODO: The AnnEqual annotation actually belongs in the first GRHS value
+    case grhs of
+      (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards
+      _ -> return ()
+    inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam
+    mapM_ markLocated grhs
+
+    case lb of
+      GHC.EmptyLocalBinds{} -> return ()
+      _ -> do
+        mark GHC.AnnWhere
+        markOptional GHC.AnnOpenC -- '{'
+        markInside GHC.AnnSemi
+        markLocalBindsWithLayout lb
+        markOptional GHC.AnnCloseC -- '}'
+    markTrailingSemi
+
+  -- -----------------------------------
+
+  markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _))
+    = error "hit extension for Match"
+  markAST _ (GHC.XMatch _)
+    = error "hit extension for Match"
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+  => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where
+  markAST _ (GHC.GRHS _ guards expr) = do
+    case guards of
+      [] -> return ()
+      (_:_) -> do
+        mark GHC.AnnVbar
+        unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp])
+          $ markListIntercalate guards
+        ifInContext (Set.fromList [CaseAlt])
+          (return ())
+          (mark GHC.AnnEqual)
+
+    markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test
+
+    inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam
+    setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr
+
+  markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.Sig GHC.GhcPs) where
+
+  markAST _ (GHC.TypeSig _ lns st)  = do
+    setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns
+    mark GHC.AnnDcolon
+    markLHsSigWcType st
+    markTrailingSemi
+    tellContext (Set.singleton FollowingLine)
+
+  markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do
+    mark GHC.AnnPattern
+    setContext (Set.singleton PrefixOp) $ markListIntercalate lns
+    mark GHC.AnnDcolon
+    markLocated typ
+    markTrailingSemi
+
+  markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do
+    when isDefault $ mark GHC.AnnDefault
+    setContext (Set.singleton PrefixOp) $ markListIntercalate ns
+    mark GHC.AnnDcolon
+    markLocated typ
+    markTrailingSemi
+
+  markAST _ (GHC.IdSig {}) =
+    traceM "warning: Introduced after renaming"
+
+  markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do
+    let fixstr = case fdir of
+         GHC.InfixL -> "infixl"
+         GHC.InfixR -> "infixr"
+         GHC.InfixN -> "infix"
+    markWithString GHC.AnnInfix fixstr
+    markSourceText src (show v)
+    setContext (Set.singleton InfixOp) $ markListIntercalate lns
+    markTrailingSemi
+
+  markAST l (GHC.InlineSig _ ln inl) = do
+    markAnnOpen (GHC.inl_src inl) "{-# INLINE"
+    markActivation l (GHC.inl_act inl)
+    setContext (Set.singleton PrefixOp) $ markLocated ln
+    markWithString GHC.AnnClose "#-}" -- '#-}'
+    markTrailingSemi
+
+  markAST l (GHC.SpecSig _ ln typs inl) = do
+    markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+    markActivation l (GHC.inl_act inl)
+    markLocated ln
+    mark GHC.AnnDcolon -- '::'
+    markListIntercalateWithFunLevel markLHsSigType 2 typs
+    markWithString GHC.AnnClose "#-}" -- '#-}'
+    markTrailingSemi
+
+
+  markAST _ (GHC.SpecInstSig _ src typ) = do
+    markAnnOpen src "{-# SPECIALISE"
+    mark GHC.AnnInstance
+    markLHsSigType typ
+    markWithString GHC.AnnClose "#-}" -- '#-}'
+    markTrailingSemi
+
+
+  markAST _ (GHC.MinimalSig _ src formula) = do
+    markAnnOpen src "{-# MINIMAL"
+    markLocated formula
+    markWithString GHC.AnnClose "#-}"
+    markTrailingSemi
+
+  markAST _ (GHC.SCCFunSig _ src ln ml) = do
+    markAnnOpen src "{-# SCC"
+    markLocated ln
+    markMaybe ml
+    markWithString GHC.AnnClose "#-}"
+    markTrailingSemi
+
+  markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do
+    markAnnOpen src "{-# COMPLETE"
+    markListIntercalate ns
+    case mlns of
+      Nothing -> return ()
+      Just _ -> do
+        mark GHC.AnnDcolon
+        markMaybe mlns
+    markWithString GHC.AnnClose "#-}" -- '#-}'
+    markTrailingSemi
+
+  -- -----------------------------------
+  markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _))
+    = error "hit extension for Sig"
+  markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _))
+    = error "hit extension for Sig"
+  markAST _ (GHC.FixSig _ (GHC.XFixitySig _))
+    = error "hit extension for Sig"
+  markAST _ (GHC.XSig _)
+    = error "hit extension for Sig"
+
+-- --------------------------------------------------------------------
+
+markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated ()
+markLHsSigType (GHC.HsIB _ typ) = markLocated typ
+markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+instance Annotate [GHC.LHsSigType GHC.GhcPs] where
+  markAST _ ls = do
+    -- mark GHC.AnnDeriving
+    -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it
+    -- is a HsTyVar. So for round trip pretty printing we need to take this into
+    -- account.
+    let marker = case ls of
+          []  -> markManyOptional
+          [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t)
+                           then markMany
+                           else markManyOptional
+          _   -> markMany -- Need parens if more than one entry
+    marker GHC.AnnOpenP
+    markListIntercalateWithFun markLHsSigType ls
+    marker GHC.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 Annotate (GHC.HsTyVarBndr GHC.GhcPs) where
+  markAST _l (GHC.UserTyVar _ n) = do
+    markLocated n
+
+  markAST _ (GHC.KindedTyVar _ n ty) = do
+    mark GHC.AnnOpenP  -- '('
+    markLocated n
+    mark GHC.AnnDcolon -- '::'
+    markLocated ty
+    mark GHC.AnnCloseP -- '('
+
+  markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsType GHC.GhcPs) where
+  markAST loc ty = do
+    inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt
+    markType loc ty
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+    (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
+   where
+
+    -- markType :: GHC.SrcSpan -> ast -> Annotated ()
+    markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated ()
+    markType _ (GHC.HsForAllTy _ tvs typ) = do
+      mark GHC.AnnForall
+      mapM_ markLocated tvs
+      mark GHC.AnnDot
+      markLocated typ
+
+    markType _ (GHC.HsQualTy _ cxt typ) = do
+      markLocated cxt
+      markLocated typ
+
+    markType _ (GHC.HsTyVar _ promoted name) = do
+      when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote
+      unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name
+
+    markType _ (GHC.HsAppTy _ t1 t2) = do
+      setContext (Set.singleton PrefixOp) $ markLocated t1
+      markLocated t2
+
+    markType _ (GHC.HsAppKindTy l t k) = do
+      setContext (Set.singleton PrefixOp)  $ markLocated t
+      markTypeApp l
+      markLocated k
+
+    markType _ (GHC.HsFunTy _ t1 t2) = do
+      markLocated t1
+      mark GHC.AnnRarrow
+      markLocated t2
+      -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT
+
+    markType _ (GHC.HsListTy _ t) = do
+      mark GHC.AnnOpenS -- '['
+      markLocated t
+      mark GHC.AnnCloseS -- ']'
+
+    markType _ (GHC.HsTupleTy _ tt ts) = do
+      case tt  of
+        GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP  -- '('
+        _                            -> markWithString GHC.AnnOpen "(#" -- '(#'
+      markListIntercalateWithFunLevel markLocated 2 ts
+      case tt  of
+        GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP  -- ')'
+        _                            -> markWithString GHC.AnnClose "#)" -- '#)'
+
+    markType _ (GHC.HsSumTy _ tys) = do
+      markWithString GHC.AnnOpen "(#"
+      markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys
+      markWithString GHC.AnnClose "#)"
+
+    markType _ (GHC.HsOpTy _ t1 lo t2) = do
+      markLocated t1
+      if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo)
+        then do
+          markOptional GHC.AnnSimpleQuote
+        else do
+          mark GHC.AnnSimpleQuote
+      unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo
+      markLocated t2
+
+    markType _ (GHC.HsParTy _ t) = do
+      mark GHC.AnnOpenP  -- '('
+      markLocated t
+      mark GHC.AnnCloseP -- ')'
+
+    markType _ (GHC.HsIParamTy _ n t) = do
+      markLocated n
+      mark GHC.AnnDcolon
+      markLocated t
+
+    markType l (GHC.HsStarTy _ isUnicode) = do
+      if isUnicode
+        then markExternal l GHC.AnnVal "\x2605" -- Unicode star
+        else markExternal l GHC.AnnVal "*"
+
+    markType _ (GHC.HsKindSig _ t k) = do
+      markOptional GHC.AnnOpenP  -- '('
+      markLocated t
+      mark GHC.AnnDcolon -- '::'
+      markLocated k
+      markOptional GHC.AnnCloseP -- ')'
+
+    markType l (GHC.HsSpliceTy _ s) = do
+      markAST l s
+
+    markType _ (GHC.HsDocTy _ t ds) = do
+      markLocated t
+      markLocated ds
+
+    markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do
+      case mt of
+        GHC.NoSourceText -> return ()
+        GHC.SourceText src -> do
+          markWithString GHC.AnnOpen src
+          markWithString GHC.AnnClose "#-}"
+      case str of
+        GHC.SrcLazy     -> mark GHC.AnnTilde
+        GHC.SrcStrict   -> mark GHC.AnnBang
+        GHC.NoSrcStrict -> return ()
+
+      markLocated t
+
+    markType _ (GHC.HsRecTy _ cons) = do
+      mark GHC.AnnOpenC  -- '{'
+      markListIntercalate cons
+      mark GHC.AnnCloseC -- '}'
+
+    markType _ (GHC.HsExplicitListTy _ promoted ts) = do
+      when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote
+      mark GHC.AnnOpenS  -- "["
+      markListIntercalate ts
+      mark GHC.AnnCloseS -- ']'
+
+    markType _ (GHC.HsExplicitTupleTy _ ts) = do
+      mark GHC.AnnSimpleQuote
+      mark GHC.AnnOpenP
+      markListIntercalate ts
+      mark GHC.AnnCloseP
+
+    markType l (GHC.HsTyLit _ lit) = do
+      case lit of
+        (GHC.HsNumTy s v) ->
+          markExternalSourceText l s (show v)
+        (GHC.HsStrTy s v) ->
+          markExternalSourceText l s (show v)
+
+    markType l (GHC.HsWildCardTy _) = do
+      markExternal l GHC.AnnVal "_"
+
+    markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x
+
+
+-- ---------------------------------------------------------------------
+
+-- instance Annotate (GHC.HsAppType GHC.GhcPs) where
+--   markAST _ (GHC.HsAppInfix _ n)  = do
+--     when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote
+--     setContext (Set.singleton InfixOp) $ markLocated n
+--   markAST _ (GHC.HsAppPrefix _ t) = do
+--     markOptional GHC.AnnTilde
+--     setContext (Set.singleton PrefixOp) $ markLocated t
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsSplice GHC.GhcPs) where
+  markAST l c =
+    case c of
+      GHC.HsQuasiQuote _ _ n _pos fs -> do
+        markExternal l GHC.AnnVal
+              -- Note: Lexer.x does not provide unicode alternative. 2017-02-26
+              ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")
+
+      GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n)))  -> do
+        when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE
+        if (hasParens == GHC.HasDollar)
+          then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))
+          else markLocated b
+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+      GHC.HsTypedSplice _ hasParens _n b -> do
+        when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE
+        markLocated b
+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+      -- -------------------------------
+
+      GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n)))  -> do
+        when (hasParens == GHC.HasParens) $  mark GHC.AnnOpenPE
+        if (hasParens == GHC.HasDollar)
+          then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))
+          else markLocated b
+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+      GHC.HsUntypedSplice _ hasParens _n b  -> do
+        case hasParens of
+          GHC.HasParens -> mark GHC.AnnOpenPE
+          GHC.HasDollar -> mark GHC.AnnThIdSplice
+          GHC.NoParens  -> return ()
+        markLocated b
+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+      GHC.HsSpliced{}  -> error "HsSpliced only exists between renamer and typechecker in GHC"
+      GHC.HsSplicedT{} -> error "HsSplicedT only exists between renamer and typechecker in GHC"
+
+      -- -------------------------------
+
+      (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ConDeclField GHC.GhcPs) where
+  markAST _ (GHC.ConDeclField _ ns ty mdoc) = do
+    unsetContext Intercalate $ do
+      markListIntercalate ns
+      mark GHC.AnnDcolon
+      markLocated ty
+      markMaybe mdoc
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+  markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FieldOcc GHC.GhcPs) where
+  markAST _ (GHC.FieldOcc _ rn) = do
+    markLocated rn
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+  markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.HsDocString where
+  markAST l s = do
+    markExternal l GHC.AnnVal (GHC.unpackHDS s)
+
+-- ---------------------------------------------------------------------
+
+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 (showGhc 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:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+hsLit2String :: GHC.HsLit GHC.GhcPs -> String
+hsLit2String lit =
+  case lit of
+    GHC.HsChar       src v   -> toSourceTextWithSuffix src v ""
+    -- It should be included here
+    -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471
+    GHC.HsCharPrim   src p   -> toSourceTextWithSuffix src p "#"
+    GHC.HsString     src v   -> toSourceTextWithSuffix src v ""
+    GHC.HsStringPrim src v   -> toSourceTextWithSuffix src v ""
+    GHC.HsInt        _ (GHC.IL src _ v)   -> toSourceTextWithSuffix src v ""
+    GHC.HsIntPrim    src v   -> toSourceTextWithSuffix src v ""
+    GHC.HsWordPrim   src v   -> toSourceTextWithSuffix src v ""
+    GHC.HsInt64Prim  src v   -> toSourceTextWithSuffix src v ""
+    GHC.HsWord64Prim src v   -> toSourceTextWithSuffix src v ""
+    GHC.HsInteger    src v _ -> toSourceTextWithSuffix src v ""
+    GHC.HsRat        _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v ""
+    GHC.HsFloatPrim  _ (GHC.FL src _ v)   -> toSourceTextWithSuffix src v "#"
+    GHC.HsDoublePrim _ (GHC.FL src _ v)   -> toSourceTextWithSuffix src v "##"
+    (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x
+
+toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String
+toSourceTextWithSuffix (GHC.NoSourceText)    alt suffix = show alt ++ suffix
+toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix
+
+-- --------------------------------------------------------------------
+
+markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated ()
+markHsConPatDetails ln dets = do
+  case dets of
+    GHC.PrefixCon args -> do
+      setContext (Set.singleton PrefixOp) $ markLocated ln
+      mapM_ markLocated args
+    GHC.RecCon (GHC.HsRecFields fs dd) -> do
+      markLocated ln
+      mark GHC.AnnOpenC -- '{'
+      case dd of
+        Nothing ->  markListIntercalateWithFunLevel markLocated 2 fs
+        Just _ -> do
+          setContext (Set.singleton Intercalate) $ mapM_ markLocated fs
+          mark GHC.AnnDotdot
+      mark GHC.AnnCloseC -- '}'
+    GHC.InfixCon a1 a2 -> do
+      markLocated a1
+      unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln
+      markLocated a2
+
+markHsConDeclDetails ::
+  Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated ()
+
+markHsConDeclDetails isDeprecated inGadt lns dets = do
+  case dets of
+    GHC.PrefixCon args ->
+      setContext (Set.singleton PrefixOp) $ mapM_ markLocated args
+    -- GHC.RecCon fs -> markLocated fs
+    GHC.RecCon fs -> do
+      mark GHC.AnnOpenC
+      if inGadt
+        then do
+          if isDeprecated
+            then setContext (Set.fromList [InGadt]) $ markLocated fs
+            else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs
+        else do
+          if isDeprecated
+            then markLocated fs
+            else setContext (Set.fromList [InRecCon]) $ markLocated fs
+    GHC.InfixCon a1 a2 -> do
+      markLocated a1
+      setContext (Set.singleton InfixOp) $ mapM_ markLocated lns
+      markLocated a2
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LConDeclField GHC.GhcPs] where
+  markAST _ fs = do
+       markOptional GHC.AnnOpenC -- '{'
+       markListIntercalate fs
+       markOptional GHC.AnnDotdot
+       inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}'
+       inContext (Set.singleton InGadt) $ do
+         mark GHC.AnnRarrow
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsOverLit GHC.GhcPs) where
+  markAST l ol =
+    let str = case GHC.ol_val ol of
+                GHC.HsIntegral   (GHC.IL src _ _) -> src
+                GHC.HsFractional (GHC.FL src _ _) -> src
+                GHC.HsIsString src _ -> src
+    in
+    markExternalSourceText l str ""
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate arg)
+    => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where
+  markAST _ (GHC.HsIB _ thing) = do
+    markLocated thing
+  markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where
+
+  markAST _ (GHC.LastStmt _ body _ _)
+    = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
+
+  markAST _ (GHC.BindStmt _ pat body _ _) = do
+    unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat
+    mark GHC.AnnLarrow
+    unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
+
+    ifInContext (Set.singleton Intercalate)
+      (mark GHC.AnnComma)
+      (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
+    markTrailingSemi
+
+  markAST _ GHC.ApplicativeStmt{}
+    = error "ApplicativeStmt should not appear in ParsedSource"
+
+  markAST _ (GHC.BodyStmt _ body _ _) = do
+    unsetContext Intercalate $ markLocated body
+    inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar
+    inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
+    markTrailingSemi
+
+  markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do
+    mark GHC.AnnLet
+    markOptional GHC.AnnOpenC -- '{'
+    markInside GHC.AnnSemi
+    markLocalBindsWithLayout lb
+    markOptional GHC.AnnCloseC -- '}'
+    ifInContext (Set.singleton Intercalate)
+      (mark GHC.AnnComma)
+      (inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar)
+    markTrailingSemi
+
+  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
+
+  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
+
+  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
+
+  markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- Note: We never have a located ParStmtBlock, so have nothing to hang the
+-- annotation on. This means there is no pushing of context from the parent ParStmt.
+instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where
+  markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do
+    markListIntercalate stmts
+  markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where
+  markAST _ lb = markHsLocalBinds lb
+
+-- ---------------------------------------------------------------------
+
+markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()
+markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) =
+    applyListAnnotationsLayout
+       (prepareListAnnotation (GHC.bagToList binds)
+     ++ prepareListAnnotation sigs
+       )
+markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds
+markHsLocalBinds GHC.EmptyLocalBinds{}                   = return ()
+
+markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension"
+markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _))   = error "markHsLocalBinds:got extension"
+markHsLocalBinds (GHC.XHsLocalBindsLR _)                = error "markHsLocalBinds:got extension"
+
+-- ---------------------------------------------------------------------
+
+markMatchGroup :: (Annotate body)
+                   => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body)
+                   -> Annotated ()
+markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _)
+  = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches
+markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+  => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where
+  markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsExpr GHC.GhcPs) where
+  markAST loc expr = do
+    markExpr loc expr
+    inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+    -- TODO: If the AnnComma is not needed, revert to markAST
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+   where
+      markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do
+        ifInContext (Set.singleton PrefixOp)
+          (setContext (Set.singleton PrefixOp) $ markLocated n)
+          (ifInContext (Set.singleton InfixOp)
+            (setContext (Set.singleton InfixOp) $ markLocated n)
+            (markLocated n)
+            )
+
+      markExpr l (GHC.HsRecFld _ f) = markAST l f
+
+      markExpr l (GHC.HsOverLabel _ _ fs)
+        = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)
+
+
+      markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v))         =
+        markAST l n
+      markExpr l (GHC.HsOverLit _ ov)     = markAST l ov
+      markExpr l (GHC.HsLit _ lit)        = markAST l lit
+
+      markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.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 _ (GHC.HsLam _ _) = error $ "HsLam with other than one match"
+
+      markExpr l (GHC.HsLamCase _ match) = do
+        mark GHC.AnnLam
+        mark GHC.AnnCase
+        markOptional GHC.AnnSemi
+        markOptional GHC.AnnOpenC
+        setContext (Set.singleton CaseAlt) $ do
+          markMatchGroup l match
+        markOptional GHC.AnnCloseC
+
+      markExpr _ (GHC.HsApp _ e1 e2) = do
+        setContext (Set.singleton PrefixOp) $ markLocated e1
+        setContext (Set.singleton PrefixOp) $ markLocated e2
+
+      -- -------------------------------
+
+      markExpr _ (GHC.OpApp _ e1 e2 e3) = do
+        let
+          isInfix = case e2 of
+            -- TODO: generalise this. Is it a fixity thing?
+            GHC.L _ (GHC.HsVar{}) -> True
+            _                     -> False
+
+          normal =
+            -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context
+            ifInContext (Set.singleton LeftMost)
+              (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1)
+              (markLocated e1)
+
+        if isInfix
+            then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1
+            else normal
+
+        unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2
+
+        if isInfix
+          then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3
+          else markLocated e3
+
+      -- -------------------------------
+
+      markExpr _ (GHC.NegApp _ e _) = do
+        mark GHC.AnnMinus
+        markLocated e
+
+      markExpr _ (GHC.HsPar _ e) = do
+        mark GHC.AnnOpenP -- '('
+        markLocated e
+        mark GHC.AnnCloseP -- ')'
+
+      markExpr _ (GHC.SectionL _ e1 e2) = do
+        markLocated e1
+        setContext (Set.singleton InfixOp) $ markLocated e2
+
+      markExpr _ (GHC.SectionR _ e1 e2) = do
+        setContext (Set.singleton InfixOp) $ markLocated e1
+        markLocated e2
+
+      markExpr _ (GHC.ExplicitTuple _ args b) = do
+        if b == GHC.Boxed then mark GHC.AnnOpenP
+                          else markWithString GHC.AnnOpen "(#"
+
+        setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args
+
+        if b == GHC.Boxed then mark GHC.AnnCloseP
+                          else markWithString GHC.AnnClose "#)"
+
+      markExpr _ (GHC.ExplicitSum _ alt arity e) = do
+        markWithString GHC.AnnOpen "(#"
+        replicateM_ (alt - 1) $ mark GHC.AnnVbar
+        markLocated e
+        replicateM_ (arity - alt) $ mark GHC.AnnVbar
+        markWithString GHC.AnnClose "#)"
+
+      markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do
+        mark GHC.AnnCase
+        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1
+        mark GHC.AnnOf
+        markOptional GHC.AnnOpenC
+        markInside GHC.AnnSemi
+        setContext (Set.singleton CaseAlt) $ markMatchGroup l matches
+        markOptional GHC.AnnCloseC
+
+      -- We set the layout for HsIf even though it need not obey layout rules as
+      -- when moving these expressions it's useful that they maintain "internal
+      -- integrity", that is to say the subparts remain indented relative to each
+      -- other.
+      markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do
+      -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do
+        mark GHC.AnnIf
+        markLocated e1
+        markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen
+        mark GHC.AnnThen
+        setContextLevel (Set.singleton ListStart) 2 $ markLocated e2
+        markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse
+        mark GHC.AnnElse
+        setContextLevel (Set.singleton ListStart) 2 $ markLocated e3
+
+      markExpr _ (GHC.HsMultiIf _ rhs) = do
+        mark GHC.AnnIf
+        markOptional GHC.AnnOpenC
+        setContext (Set.singleton CaseAlt) $ do
+          -- mapM_ markLocated rhs
+          markListWithLayout rhs
+        markOptional GHC.AnnCloseC
+
+      markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do
+        setLayoutFlag (do -- Make sure the 'in' gets indented too
+          mark GHC.AnnLet
+          markOptional GHC.AnnOpenC
+          markInside GHC.AnnSemi
+          markLocalBindsWithLayout binds
+          markOptional GHC.AnnCloseC
+          mark GHC.AnnIn
+          markLocated e)
+
+      -- -------------------------------
+
+      markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do
+        case cts of
+          GHC.DoExpr  -> mark GHC.AnnDo
+          GHC.MDoExpr -> mark GHC.AnnMdo
+          _           -> return ()
+        let (ostr,cstr) =
+              if isListComp cts
+                then ("[", "]")
+                else ("{", "}")
+
+        when (isListComp cts) $ markWithString GHC.AnnOpen ostr
+        markOptional GHC.AnnOpenS
+        markOptional GHC.AnnOpenC
+        markInside GHC.AnnSemi
+        if isListComp cts
+          then do
+            markLocated (last es)
+            mark GHC.AnnVbar
+            setLayoutFlag (markListIntercalate (init es))
+          else do
+           markListWithLayout es
+        markOptional GHC.AnnCloseS
+        markOptional GHC.AnnCloseC
+        when (isListComp cts) $ markWithString GHC.AnnClose cstr
+
+      -- -------------------------------
+
+      markExpr _ (GHC.ExplicitList _ _ es) = do
+        mark GHC.AnnOpenS
+        setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es
+        mark GHC.AnnCloseS
+
+      markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do
+        markLocated n
+        mark GHC.AnnOpenC
+        case dd of
+          Nothing -> markListIntercalate fs
+          Just _ -> do
+            setContext (Set.singleton Intercalate) $ mapM_ markLocated fs
+            mark GHC.AnnDotdot
+        mark GHC.AnnCloseC
+
+      markExpr _ (GHC.RecordUpd _ e fs) = do
+        markLocated e
+        mark GHC.AnnOpenC
+        markListIntercalate fs
+        mark GHC.AnnCloseC
+
+      markExpr _ (GHC.ExprWithTySig _ e typ) = do
+        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e
+        mark GHC.AnnDcolon
+        markLHsSigWcType typ
+
+      markExpr _ (GHC.ArithSeq _ _ seqInfo) = do
+        mark GHC.AnnOpenS -- '['
+        case seqInfo of
+            GHC.From e -> do
+              markLocated e
+              mark GHC.AnnDotdot
+            GHC.FromTo e1 e2 -> do
+              markLocated e1
+              mark GHC.AnnDotdot
+              markLocated e2
+            GHC.FromThen e1 e2 -> do
+              markLocated e1
+              mark GHC.AnnComma
+              markLocated e2
+              mark GHC.AnnDotdot
+            GHC.FromThenTo e1 e2 e3 -> do
+              markLocated e1
+              mark GHC.AnnComma
+              markLocated e2
+              mark GHC.AnnDotdot
+              markLocated e3
+        mark GHC.AnnCloseS -- ']'
+
+      markExpr _ (GHC.HsSCC _ src csFStr e) = 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
+
+      markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do
+        -- markWithString GHC.AnnOpen src -- "{-# CORE"
+        markAnnOpen src "{-# CORE"
+        -- markWithString GHC.AnnVal (GHC.sl_st csFStr)
+        markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
+        markWithString GHC.AnnClose "#-}"
+        markLocated e
+      -- TODO: make monomorphic
+      markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do
+        mark GHC.AnnSimpleQuote
+        setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v)
+      markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do
+        mark GHC.AnnThTyQuote
+        markLocatedFromKw GHC.AnnName (GHC.L l v)
+      markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do
+        markWithString GHC.AnnOpen "[d|"
+        markOptional GHC.AnnOpenC
+        setContext (Set.singleton NoAdvanceLine)
+             $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds
+        markOptional GHC.AnnCloseC
+        mark GHC.AnnCloseQ -- "|]"
+      -- Introduced after the renamer
+      markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) =
+        traceM "warning: DecBrG introduced after renamer"
+      markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do
+        mark GHC.AnnOpenEQ -- "[|"
+        markOptional GHC.AnnOpenE  -- "[e|"
+        markLocated e
+        mark GHC.AnnCloseQ -- "|]"
+      markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do
+        markWithString GHC.AnnOpen  "[||"
+        markWithStringOptional GHC.AnnOpenE "[e||"
+        markLocated e
+        markWithString GHC.AnnClose "||]"
+      markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do
+        markWithString GHC.AnnOpen "[t|"
+        markLocated e
+        mark GHC.AnnCloseQ -- "|]"
+      markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do
+        markWithString GHC.AnnOpen  "[p|"
+        markLocated e
+        mark GHC.AnnCloseQ -- "|]"
+
+      markExpr _ (GHC.HsRnBracketOut {}) =
+        traceM "warning: HsRnBracketOut introduced after renamer"
+      markExpr _ (GHC.HsTcBracketOut {}) =
+        traceM "warning: HsTcBracketOut introduced after renamer"
+
+      markExpr l (GHC.HsSpliceE _ e) = markAST l e
+
+      markExpr _ (GHC.HsProc _ p c) = do
+        mark GHC.AnnProc
+        markLocated p
+        mark GHC.AnnRarrow
+        markLocated c
+
+      markExpr _ (GHC.HsStatic _ e) = do
+        mark GHC.AnnStatic
+        markLocated e
+
+      markExpr _ (GHC.HsArrApp _ 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
+
+      markExpr _ (GHC.HsArrForm _ e _ cs) = do
+        markWithString GHC.AnnOpenB "(|"
+        markLocated e
+        mapM_ markLocated cs
+        markWithString GHC.AnnCloseB "|)"
+
+      markExpr _ (GHC.HsTick {}) = return ()
+      markExpr _ (GHC.HsBinTick {}) = return ()
+
+      markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = 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
+
+      markExpr l (GHC.EWildPat _) = do
+        ifInContext (Set.fromList [InfixOp])
+          (do  mark GHC.AnnBackquote
+               markWithString GHC.AnnVal "_"
+               mark GHC.AnnBackquote)
+          (markExternal l GHC.AnnVal "_")
+
+      markExpr _ (GHC.EAsPat _ ln e) = do
+        markLocated ln
+        mark GHC.AnnAt
+        markLocated e
+
+      markExpr _ (GHC.EViewPat _ e1 e2) = do
+        markLocated e1
+        mark GHC.AnnRarrow
+        markLocated e2
+
+      markExpr _ (GHC.ELazyPat _ e) = do
+        mark GHC.AnnTilde
+        markLocated e
+
+      markExpr _ (GHC.HsAppType _ e ty) = do
+        markLocated e
+        markInstead GHC.AnnAt AnnTypeApp
+        markLHsWcType ty
+
+      markExpr _ (GHC.HsWrap {}) =
+        traceM "warning: HsWrap introduced after renaming"
+      markExpr _ (GHC.HsUnboundVar {}) =
+        traceM "warning: HsUnboundVar introduced after renaming"
+
+      markExpr _ (GHC.HsConLikeOut{}) =
+        traceM "warning: HsConLikeOut introduced after type checking"
+
+      markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension"
+      markExpr _ (GHC.XExpr _)                      = error "markExpr got extension"
+
+-- ---------------------------------------------------------------------
+
+markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated ()
+markLHsWcType (GHC.HsWC _ ty) = do
+  markLocated ty
+markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsLit GHC.GhcPs) where
+  markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where
+  markAST _ (GHC.HsRecField lbl expr punFlag) = do
+    unsetContext Intercalate $ markLocated lbl
+    when (punFlag == False) $ do
+      mark GHC.AnnEqual
+      unsetContext Intercalate $ markLocated expr
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where
+  markAST _ (GHC.Unambiguous _ n) = markLocated n
+  markAST _ (GHC.Ambiguous   _ n) = markLocated n
+  markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- |Used for declarations that need to be aligned together, e.g. in a
+-- do or let .. in statement/expr
+instance Annotate [GHC.ExprLStmt GHC.GhcPs] where
+  markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsTupArg GHC.GhcPs) where
+  markAST _ (GHC.Present _ (GHC.L l e)) = do
+    markLocated (GHC.L l e)
+    inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma)
+
+  markAST _ (GHC.Missing _) = do
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+  markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsCmdTop GHC.GhcPs) where
+  markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd
+  markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x
+
+instance Annotate (GHC.HsCmd GHC.GhcPs) where
+  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
+
+  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
+
+  markAST l (GHC.HsCmdLam _ match) = do
+    setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match
+
+  markAST _ (GHC.HsCmdPar _ e) = do
+    mark GHC.AnnOpenP
+    markLocated e
+    mark GHC.AnnCloseP -- ')'
+
+  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
+
+  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:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where
+  markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyClDecl GHC.GhcPs) where
+
+  markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi
+{-
+    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
+
+  markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity
+                (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do
+    if nd == GHC.DataType
+      then mark GHC.AnnData
+      else mark GHC.AnnNewtype
+    markMaybe mctyp
+    markLocated ctx
+    markTyClass Nothing fixity ln tyVars
+    case mk of
+      Nothing -> return ()
+      Just k -> do
+        mark GHC.AnnDcolon
+        markLocated k
+    if isGadt cons
+      then mark GHC.AnnWhere
+      else unless (null cons) $ mark GHC.AnnEqual
+    markOptional GHC.AnnWhere
+    markOptional GHC.AnnOpenC
+    setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace)
+                  $ markListWithContexts' listContexts cons
+    markOptional GHC.AnnCloseC
+    setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs
+    markTrailingSemi
+
+  -- -----------------------------------
+
+  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"
+
+-- ---------------------------------------------------------------------
+
+markTypeApp :: GHC.SrcSpan -> Annotated ()
+markTypeApp loc = do
+  let l = GHC.srcSpanFirstCharacter loc
+  markExternal l GHC.AnnVal "@"
+
+-- ---------------------------------------------------------------------
+
+markTyClassArgs :: (Annotate a, GHC.HasOccName a)
+            => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity
+            -- -> GHC.Located a -> [ast] -> Annotated ()
+            -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated ()
+markTyClassArgs mbndrs fixity ln tyVars = do
+  let
+    cvt (GHC.HsValArg  val) = markLocated val
+    cvt (GHC.HsTypeArg loc typ) = do
+      markTypeApp loc
+      -- let l = GHC.srcSpanFirstCharacter loc
+      -- markExternal l GHC.AnnVal "@"
+      markLocated typ
+    cvt (GHC.HsArgPar _ss) = undefined
+  markTyClassWorker cvt mbndrs fixity ln tyVars
+    {-
+type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
+
+data HsArg tm ty
+  = HsValArg tm   -- Argument is an ordinary expression     (f arg)
+  | HsTypeArg  ty -- Argument is a visible type application (f @ty)
+  | HsArgPar SrcSpan -- See Note [HsArgPar]
+-}
+
+-- TODO:AZ: simplify
+markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, GHC.HasOccName a, Annotate ast,GHC.HasSrcSpan ast)
+            => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity
+            -> GHC.Located a -> [ast] -> Annotated ()
+markTyClass = markTyClassWorker markLocated
+
+markTyClassWorker :: (Annotate a, GHC.HasOccName a)
+            => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity
+            -- -> GHC.Located a -> [ast] -> Annotated ()
+            -> GHC.Located a -> [b] -> Annotated ()
+markTyClassWorker markFn mbndrs fixity ln tyVars = do
+    let processBinders =
+          case mbndrs of
+            Nothing -> return ()
+            Just bndrs -> do
+              mark GHC.AnnForall
+              mapM_ markLocated bndrs
+              mark GHC.AnnDot
+
+    -- There may be arbitrary parens around parts of the constructor
+    -- Turn these into comments so that they feed into the right place automatically
+    annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+    let markParens = if fixity == GHC.Infix && length tyVars > 2
+          then markMany
+          else markManyOptional
+    if fixity == GHC.Prefix
+      then do
+        markManyOptional GHC.AnnOpenP
+        processBinders
+        setContext (Set.singleton PrefixOp) $ markLocated ln
+        -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars
+        setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars
+        when (length tyVars >= 2) $ do
+          markParens GHC.AnnCloseP
+          setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars
+        markManyOptional GHC.AnnCloseP
+      else do
+        case tyVars of
+          (x:y:xs) -> do
+            markParens GHC.AnnOpenP
+            processBinders
+            markFn x
+            setContext (Set.singleton InfixOp) $ markLocated ln
+            markFn y
+            markParens GHC.AnnCloseP
+            mapM_ markFn xs
+            markManyOptional GHC.AnnCloseP
+          _ -> error $ "markTyClass: Infix op without operands"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where
+  markAST _ ds = mapM_ markLocated ds
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where
+  markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do
+    mark GHC.AnnDeriving
+    case mstrategy of
+      Nothing -> return ()
+      Just (GHC.L _ (GHC.ViaStrategy{})) -> return ()
+      Just s -> markLocated s
+    markLocated typs
+    case mstrategy of
+      Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s
+      _ -> return ()
+
+  markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x
+
+{-
+  = HsDerivingClause
+    { deriv_clause_ext :: XCHsDerivingClause pass
+    , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
+      -- ^ The user-specified strategy (if any) to use when deriving
+      -- 'deriv_clause_tys'.
+    , deriv_clause_tys :: Located [LHsSigType pass]
+      -- ^ The types to derive.
+      --
+      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
+      -- we can mention type variables that aren't bound by the datatype, e.g.
+      --
+      -- > data T b = ... deriving (C [a])
+      --
+      -- should produce a derived instance for @C [a] (T b)@.
+    }
+
+-}
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FamilyDecl GHC.GhcPs) where
+  markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do
+    case info of
+      GHC.DataFamily -> mark GHC.AnnData
+      _              -> mark GHC.AnnType
+
+    mark GHC.AnnFamily
+
+    markTyClass Nothing fixity ln tyvars
+    case GHC.unLoc rsig of
+      GHC.NoSig _ -> return ()
+      GHC.KindSig _ _ -> do
+        mark GHC.AnnDcolon
+        markLocated rsig
+      GHC.TyVarSig _ _ -> do
+        mark GHC.AnnEqual
+        markLocated rsig
+      (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x
+    case minj of
+      Nothing -> return ()
+      Just inj -> do
+        mark GHC.AnnVbar
+        markLocated inj
+    case info of
+      GHC.ClosedTypeFamily (Just eqns) -> do
+        mark GHC.AnnWhere
+        markOptional GHC.AnnOpenC -- {
+        markListWithLayout eqns
+        markOptional GHC.AnnCloseC -- }
+      GHC.ClosedTypeFamily Nothing -> do
+        mark GHC.AnnWhere
+        mark GHC.AnnOpenC -- {
+        mark GHC.AnnDotdot
+        mark GHC.AnnCloseC -- }
+      _ -> return ()
+    markTrailingSemi
+
+  markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _)
+    = error "got extension for FamilyDecl"
+  markAST _ (GHC.XFamilyDecl _)
+    = error "got extension for FamilyDecl"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where
+  markAST _ (GHC.NoSig _)        = return ()
+  markAST _ (GHC.KindSig _ k)    = markLocated k
+  markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv
+  markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where
+  markAST _ (GHC.InjectivityAnn ln lns) = do
+    markLocated ln
+    mark GHC.AnnRarrow
+    mapM_ markLocated lns
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where
+{-
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
+
+type FamInstEqn pass rhs
+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+
+type HsTyPats pass = [LHsTypeArg pass]
+
+-}
+  markAST _ (GHC.HsIB _ eqn) = do
+    markFamEqn eqn
+    markTrailingSemi
+  markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where
+
+  markAST _ (GHC.FamEqn _ ln mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do
+    mark GHC.AnnType
+    mark GHC.AnnInstance
+    markTyClass mbndrs fixity ln bndrs
+    mark GHC.AnnEqual
+    markLocated typ
+{-
+type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
+
+data LHsQTyVars pass   -- See Note [HsType binders]
+  = HsQTvs { hsq_ext :: XHsQTvs pass
+
+           , hsq_explicit :: [LHsTyVarBndr pass]
+                -- Explicit variables, written by the user
+                -- See Note [HsForAllTy tyvar binders]
+    }
+
+
+data FamEqn pass pats rhs
+  = FamEqn
+       { feqn_ext    :: XCFamEqn pass pats rhs
+       , feqn_tycon  :: Located (IdP pass)
+       , feqn_bndrs  :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars
+       , feqn_pats   :: pats
+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+       , feqn_rhs    :: rhs
+       }
+-}
+
+  markAST _ (GHC.FamEqn _ _ _ (GHC.XLHsQTyVars _) _ _)
+    = error "TyFamDefltEqn hit extension point"
+  markAST _ (GHC.XFamEqn _)
+    = error "TyFamDefltEqn hit extension point"
+
+-- ---------------------------------------------------------------------
+
+-- TODO: modify lexer etc, in the meantime to not set haddock flag
+instance Annotate GHC.DocDecl where
+  markAST l v =
+    let str =
+          case v of
+            (GHC.DocCommentNext ds)     -> GHC.unpackHDS ds
+            (GHC.DocCommentPrev ds)     -> GHC.unpackHDS ds
+            (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds
+            (GHC.DocGroup _i ds)        -> GHC.unpackHDS ds
+    in
+      markExternal l GHC.AnnVal str >> markTrailingSemi
+{-
+data DocDecl
+  = DocCommentNext HsDocString
+  | DocCommentPrev HsDocString
+  | DocCommentNamed String HsDocString
+  | DocGroup Int HsDocString
+
+-}
+
+-- ---------------------------------------------------------------------
+
+markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated ()
+markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do
+  markLocated ctx
+  markMaybe typ
+  if isGadt cons
+    then markListWithLayout cons
+    else markListIntercalateWithFunLevel markLocated 2 cons
+  setContext (Set.singleton Deriving) $ markLocated derivs
+markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- Note: GHC.HsContext name aliases to here too
+instance Annotate [GHC.LHsType GHC.GhcPs] where
+  markAST l ts = do
+    -- Note: A single item in parens in a standalone deriving clause
+    -- is parsed as a HsSigType, which is always a HsForAllTy or
+    -- HsQualTy. Without parens it is always a HsVar. So for round
+    -- trip pretty printing we need to take this into account.
+    let
+      parenIfNeeded' pa =
+        case ts of
+          []  -> if l == GHC.noSrcSpan
+            then markManyOptional pa
+            else markMany pa
+          [GHC.L _ GHC.HsForAllTy{}] -> markMany pa
+          [GHC.L _ GHC.HsQualTy{}] -> markMany pa
+          [_] -> markManyOptional pa
+          _   -> markMany         pa
+
+      parenIfNeeded'' pa =
+        ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set?
+          (markMany pa)
+          (parenIfNeeded' pa)
+
+      parenIfNeeded pa =
+        case ts of
+          [GHC.L _ GHC.HsParTy{}] -> markOptional pa
+          _ -> parenIfNeeded'' pa
+
+    -- -------------
+
+    parenIfNeeded GHC.AnnOpenP
+
+    unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts
+
+    parenIfNeeded GHC.AnnCloseP
+
+    ifInContext (Set.singleton NoDarrow)
+      (return ())
+      (if null ts && (l == GHC.noSrcSpan)
+         then markOptional GHC.AnnDarrow
+         else mark         GHC.AnnDarrow)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ConDecl GHC.GhcPs) where
+  markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx
+                         dets _) = do
+    case mqtvs of
+      [] -> return ()
+      bndrs -> do
+        mark GHC.AnnForall
+        mapM_ markLocated bndrs
+        mark GHC.AnnDot
+
+    case mctx of
+      Just ctx -> do
+        setContext (Set.fromList [NoDarrow]) $ markLocated ctx
+        unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow
+      Nothing -> return ()
+
+    case dets of
+      GHC.InfixCon _ _ -> return ()
+      _ -> setContext (Set.singleton PrefixOp) $ markLocated ln
+
+    markHsConDeclDetails False False [ln] dets
+
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar
+    markTrailingSemi
+{-
+  | ConDeclH98
+      { con_ext     :: XConDeclH98 pass
+      , con_name    :: Located (IdP pass)
+
+      , con_forall  :: Bool   -- ^ True <=> explicit user-written forall
+                              --     e.g. data T a = forall b. MkT b (b->a)
+                              --     con_ex_tvs = {b}
+                              -- False => con_ex_tvs is empty
+      , con_ex_tvs :: [LHsTyVarBndr pass]      -- ^ Existentials only
+      , con_mb_cxt :: Maybe (LHsContext pass)  -- ^ User-written context (if any)
+      , con_args   :: HsConDeclDetails pass    -- ^ Arguments; can be InfixCon
+
+      , con_doc       :: Maybe LHsDocString
+          -- ^ A possible Haddock comment.
+      }
+
+-}
+  markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ 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
+{-
+  = ConDeclGADT
+      { con_g_ext   :: XConDeclGADT pass
+      , con_names   :: [Located (IdP pass)]
+
+      -- The next four fields describe the type after the '::'
+      -- See Note [GADT abstract syntax]
+      , con_forall  :: Located Bool      -- ^ True <=> explicit forall
+                                         --   False => hsq_explicit is empty
+      , con_qvars   :: LHsQTyVars pass
+                       -- Whether or not there is an /explicit/ forall, we still
+                       -- need to capture the implicitly-bound type/kind variables
+
+      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon
+      , con_res_ty  :: LHsType pass            -- ^ Result type
+
+      , con_doc     :: Maybe LHsDocString
+          -- ^ A possible Haddock comment.
+      }
+
+-}
+
+  markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _)
+    = error "hit extension point in ConDecl"
+  markAST _ (GHC.XConDecl _)
+    = error "hit extension point in ConDecl"
+
+-- ResTyGADT has a SrcSpan for the original sigtype, we need to create
+-- a type for exactPC and annotatePC
+data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs]
+                   deriving (Typeable)
+deriving instance Data (ResTyGADTHook)
+
+instance GHC.Outputable ResTyGADTHook where
+  ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs
+
+
+-- WildCardAnon exists because the GHC anonymous wildcard type is defined as
+--      = AnonWildCard (PostRn name Name)
+-- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but
+-- the instance doing this is parameterised on name, so we cannot put a value in
+-- for the (PostRn name Name) field. This is used instead.
+data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable)
+
+instance Annotate WildCardAnon where
+  markAST l WildCardAnon = do
+    markExternal l GHC.AnnVal "_"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate ResTyGADTHook where
+  markAST _ (ResTyGADTHook forall bndrs) = do
+    unless (null bndrs) $ do
+      when forall $ mark GHC.AnnForall
+      mapM_ markLocated bndrs
+      when forall $ mark GHC.AnnDot
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where
+  markAST _ (GHC.HsRecField n e punFlag) = do
+    unsetContext Intercalate $ markLocated n
+    unless punFlag $ do
+      mark GHC.AnnEqual
+      unsetContext Intercalate $ markLocated e
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+
+instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where
+  markAST _ (GHC.HsRecField n e punFlag) = do
+    unsetContext Intercalate $ markLocated n
+    unless punFlag $ do
+      mark GHC.AnnEqual
+      unsetContext Intercalate $ markLocated e
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where
+
+  markAST _ (ls,rs) = do
+    mapM_ markLocated ls
+    mark GHC.AnnRarrow
+    mapM_ markLocated rs
+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+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 "#-}"
+
+-- ---------------------------------------------------------------------
+
+stringLiteralToString :: GHC.StringLiteral -> String
+stringLiteralToString (GHC.StringLiteral st fs) =
+  case st of
+    GHC.NoSourceText   -> GHC.unpackFS fs
+    GHC.SourceText src -> src
diff --git a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs
--- a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs
@@ -10,6 +10,8 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook
+{-# LANGUAGE ViewPatterns      #-}
+
 -- | 'annotate' is a function which given a GHC AST fragment, constructs
 -- a syntax tree which indicates which annotations belong to each specific
 -- part of the fragment.
@@ -116,8 +118,13 @@
   MarkManyOptional :: GHC.AnnKeywordId                                     -> next -> AnnotationF next
   MarkOffsetPrim   :: GHC.AnnKeywordId -> Int -> Maybe String              -> next -> AnnotationF next
   MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String        -> next -> AnnotationF next
+#if __GLASGOW_HASKELL__ > 806
+  WithAST         :: (Data a,Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) =>
+                           a -> Annotated b                                -> next -> AnnotationF next
+#else
   WithAST          :: Data a => GHC.Located a
                              -> Annotated b                                -> next -> AnnotationF next
+#endif
   CountAnns        :: GHC.AnnKeywordId                        -> (Int     -> next) -> AnnotationF next
   WithSortKey      :: [(GHC.SrcSpan, Annotated ())]                        -> next -> AnnotationF next
 
@@ -211,7 +218,12 @@
 -- ---------------------------------------------------------------------
 
 -- |Main driver point for annotations.
+#if __GLASGOW_HASKELL__ > 806
+withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
+        => a -> Annotated () -> Annotated ()
+#else
 withAST :: Data a => GHC.Located a -> Annotated () -> Annotated ()
+#endif
 withAST lss action = liftF (WithAST lss action ())
 
 -- ---------------------------------------------------------------------
@@ -243,12 +255,21 @@
 
 -- ---------------------------------------------------------------------
 
+#if __GLASGOW_HASKELL__ > 806
+withLocated :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
+            => a
+            -> (GHC.SrcSpan -> a -> Annotated ())
+            -> Annotated ()
+withLocated a@(GHC.dL->GHC.L l _) action =
+  withAST a (action l a)
+#else
 withLocated :: Data a
             => GHC.Located a
             -> (GHC.SrcSpan -> a -> Annotated ())
             -> Annotated ()
-withLocated a@(GHC.L l ast) action =
-  withAST a (action l ast)
+withLocated a@(GHC.L l t) action =
+  withAST a (action l t)
+#endif
 
 -- ---------------------------------------------------------------------
 
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns #-}
+
 -- |  This module converts 'GHC.ApiAnns' into 'Anns' by traversing a
 -- structure created by the "Annotate" module.
 --
@@ -151,8 +154,13 @@
 -- ---------------------------------------------------------------------
 -- | Transform concrete annotations into relative annotations which are
 -- more useful when transforming an AST.
+#if __GLASGOW_HASKELL__ > 806
+relativiseApiAnns :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+                  => ast
+#else
 relativiseApiAnns :: Annotate ast
                   => GHC.Located ast
+#endif
                   -> GHC.ApiAnns
                   -> Anns
 relativiseApiAnns = relativiseApiAnnsWithComments []
@@ -162,19 +170,32 @@
 -- by e.g. CPP, and the parts stripped out of the original source are re-added
 -- as comments so they are not lost for round tripping.
 relativiseApiAnnsWithComments ::
+#if __GLASGOW_HASKELL__ > 806
+                     (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+                  => [Comment]
+                  -> ast
+#else
                      Annotate ast
                   => [Comment]
                   -> GHC.Located ast
+#endif
                   -> GHC.ApiAnns
                   -> Anns
 relativiseApiAnnsWithComments =
     relativiseApiAnnsWithOptions normalLayout
 
 relativiseApiAnnsWithOptions ::
+#if __GLASGOW_HASKELL__ > 806
+                     (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+                  => DeltaOptions
+                  -> [Comment]
+                  -> ast
+#else
                      Annotate ast
                   => DeltaOptions
                   -> [Comment]
                   -> GHC.Located ast
+#endif
                   -> GHC.ApiAnns
                   -> Anns
 relativiseApiAnnsWithOptions opts cs modu ghcAnns
@@ -427,8 +448,13 @@
 getSrcSpan :: Delta GHC.SrcSpan
 getSrcSpan = asks curSrcSpan
 
+#if __GLASGOW_HASKELL__ > 806
+withSrcSpanDelta :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b
+withSrcSpanDelta (GHC.dL->GHC.L l a) =
+#else
 withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b
 withSrcSpanDelta (GHC.L l a) =
+#endif
   local (\s -> s { curSrcSpan = l
                  , annConName = annGetConstr a
                  , drContext = pushAcs (drContext s)
@@ -561,10 +587,17 @@
 -- -------------------------------------
 
 -- | Enter a new AST element. Maintain SrcSpan stack
+#if __GLASGOW_HASKELL__ > 806
+withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
+        => a
+        -> Delta b -> Delta b
+withAST lss@(GHC.dL->GHC.L ss _) action = do
+#else
 withAST :: Data a
         => GHC.Located a
         -> Delta b -> Delta b
 withAST lss@(GHC.L ss _) action = do
+#endif
   -- Calculate offset required to get to the start of the SrcSPan
   off <- gets apLayoutStart
   (resetAnns .  withSrcSpanDelta lss) (do
@@ -827,7 +860,7 @@
 addEofAnnotation :: Delta ()
 addEofAnnotation = do
   pe <- getPriorEnd
-  (ma,_kw) <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)
+  (ma,_kw) <- withSrcSpanDelta (GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) (getAnnotationDelta GHC.AnnEofPos)
   case ma of
     [] -> return ()
     (pa:pss) -> do
diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
 -----------------------------------------------------------------------------
 -- |
@@ -49,6 +50,9 @@
 import Language.Haskell.GHC.ExactPrint.Types
 
 import Control.Monad.RWS
+#if __GLASGOW_HASKELL__ > 806
+import Data.Data (Data)
+#endif
 
 import GHC.Paths (libdir)
 
@@ -79,12 +83,21 @@
 
 -- | Wrapper function which returns Annotations along with the parsed
 -- element.
+#if __GLASGOW_HASKELL__ > 806
+parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w)
+          => GHC.DynFlags
+          -> FilePath
+          -> GHC.P w
+          -> String
+          -> Either (GHC.SrcSpan, String) (Anns, w)
+#else
 parseWith :: Annotate w
           => GHC.DynFlags
           -> FilePath
           -> GHC.P (GHC.Located w)
           -> String
           -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)
+#endif
 parseWith dflags fileName parser s =
   case runParser parser dflags fileName s of
 #if __GLASGOW_HASKELL__ >= 804
diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -226,6 +228,7 @@
            (G GHC.AnnDcolon)       -> tellKd (ann,DP (0,1))
            (G GHC.AnnDeriving)     -> tellKd (ann,DP (0,1))
            (G GHC.AnnDo)           -> tellKd (ann,DP (0,1))
+           (G GHC.AnnDotdot)       -> tellKd (ann,DP (0,1))
            (G GHC.AnnElse)         -> tellKd (ann,DP (1,2))
            (G GHC.AnnEqual)        -> tellKd (ann,DP (0,1))
            (G GHC.AnnExport)       -> tellKd (ann,DP (0,1))
@@ -238,6 +241,7 @@
            (G GHC.AnnIn)           -> tellKd (ann,DP (1,0))
            (G GHC.AnnInstance)     -> tellKd (ann,DP (0,1))
            (G GHC.AnnLam)          -> tellKd (ann,DP (0,1))
+           (G GHC.AnnLet)          -> tellKd (ann,DP (0,1))
            (G GHC.AnnMinus)        -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator
            (G GHC.AnnModule)       -> tellKd (ann,DP (0,1))
            (G GHC.AnnNewtype)      -> tellKd (ann,DP (0,1))
@@ -309,8 +313,13 @@
 
 -- ---------------------------------------------------------------------
 
+#if __GLASGOW_HASKELL__ > 806
+withSrcSpanPretty :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b
+withSrcSpanPretty (GHC.dL->GHC.L l a) action = do
+#else
 withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b
 withSrcSpanPretty (GHC.L l a) action = do
+#endif
   -- peek into the current state of the output, to extract the layout context
   -- flags passed up from subelements of the AST.
   (_,w) <- listen (return () :: Pretty ())
@@ -327,10 +336,17 @@
 -- ---------------------------------------------------------------------
 
 -- | Enter a new AST element. Maintain SrcSpan stack
+#if __GLASGOW_HASKELL__ > 806
+withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
+        => a
+        -> Pretty b -> Pretty b
+withAST lss@(GHC.dL->GHC.L ss t) action = do
+#else
 withAST :: Data a
         => GHC.Located a
         -> Pretty b -> Pretty b
 withAST lss@(GHC.L ss t) action = do
+#endif
   return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t)))
   -- Calculate offset required to get to the start of the SrcSPan
   -- off <- gets apLayoutStart
diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Print.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
@@ -73,7 +74,11 @@
 data PrintOptions m a = PrintOptions
             {
               epAnn :: !Annotation
+#if __GLASGOW_HASKELL__ > 806
+            , epAstPrint :: forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a
+#else
             , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a
+#endif
             , epTokenPrint :: String -> m a
             , epWhitespacePrint :: String -> m a
             , epRigidity :: Rigidity
@@ -82,7 +87,11 @@
 
 -- | Helper to create a 'PrintOptions'
 printOptions ::
+#if __GLASGOW_HASKELL__ > 806
+      (forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a)
+#else
       (forall ast . Data ast => GHC.Located ast -> a -> m a)
+#endif
       -> (String -> m a)
       -> (String -> m a)
       -> Rigidity
@@ -150,7 +159,8 @@
 
 -- ---------------------------------------------------------------------
 
-printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a
+printInterpret :: forall w m a . (Monad m, Monoid w)
+               => Annotated a -> EP w m a
 printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m)
   where
     go :: AnnotationF (EP w m a) -> EP w m a
@@ -278,7 +288,14 @@
 
 -------------------------------------------------------------------------
 -- |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)
+#if __GLASGOW_HASKELL__ > 806
+exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w)
+        => ast -> EP w m a -> EP w m a
+#else
 exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a
+#endif
 exactPC ast action =
     do
       return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))
@@ -311,7 +328,12 @@
   colOffset <- getLayoutOffset
   printWhitespace (undelta p cl colOffset)
 
+#if __GLASGOW_HASKELL__ > 806
+getAndRemoveAnnotation :: (Monad m, Monoid w, Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
+                       => a -> EP w m (Maybe Annotation)
+#else
 getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation)
+#endif
 getAndRemoveAnnotation a = gets (getAnnotationEP a . epAnns)
 
 markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -301,7 +301,12 @@
 
 -- |Create a simple 'Annotation' without comments, and attach it to the first
 -- parameter.
-addSimpleAnnT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
+addSimpleAnnT :: (Constraints a,Monad m)
+#if __GLASGOW_HASKELL__ >= 808
+              => a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
+#else
+              => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
+#endif
 addSimpleAnnT ast dp kds = do
   let ann = annNone { annEntryDelta = dp
                     , annsDP = kds
@@ -325,7 +330,11 @@
 -- ---------------------------------------------------------------------
 
 -- |'Transform' monad version of 'getEntryDP'
+#if __GLASGOW_HASKELL__ >= 808
+getEntryDPT :: (Constraints a,Monad m) => a -> TransformT m DeltaPos
+#else
 getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos
+#endif
 getEntryDPT ast = do
   anns <- getAnnsT
   return (getEntryDP anns ast)
@@ -333,7 +342,11 @@
 -- ---------------------------------------------------------------------
 
 -- |'Transform' monad version of 'getEntryDP'
+#if __GLASGOW_HASKELL__ >= 808
+setEntryDPT :: (Constraints a,Monad m) => a -> DeltaPos -> TransformT m ()
+#else
 setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m ()
+#endif
 setEntryDPT ast dp = do
   modifyAnnsT (setEntryDP ast dp)
 
@@ -387,7 +400,11 @@
 
 -- |Return the true entry 'DeltaPos' from the annotation for a given AST
 -- element. This is the 'DeltaPos' ignoring any comments.
+#if __GLASGOW_HASKELL__ >= 808
+getEntryDP :: (Constraints a) => Anns -> a -> DeltaPos
+#else
 getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos
+#endif
 getEntryDP anns ast =
   case Map.lookup (mkAnnKey ast) anns of
     Nothing  -> DP (0,0)
@@ -397,7 +414,11 @@
 
 -- |Set the true entry 'DeltaPos' from the annotation for a given AST
 -- element. This is the 'DeltaPos' ignoring any comments.
+#if __GLASGOW_HASKELL__ >= 808
+setEntryDP :: (Constraints a) => a -> DeltaPos -> Anns -> Anns
+#else
 setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns
+#endif
 setEntryDP ast dp anns =
   case Map.lookup (mkAnnKey ast) anns of
     Nothing  -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -7,6 +8,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 module Language.Haskell.GHC.ExactPrint.Types
   ( -- * Core Types
    Anns
@@ -33,6 +35,9 @@
   , ACS'(..)
   , ListContexts(..)
 
+  -- * For managing compatibility
+  , Constraints
+
   -- * GHC version compatibility
   , GhcPs
   , GhcRn
@@ -45,6 +50,7 @@
   ) where
 
 import Data.Data (Data, Typeable, toConstr,cast)
+-- import Data.Generics
 
 import qualified DynFlags      as GHC
 import qualified GHC
@@ -55,6 +61,14 @@
 
 -- ---------------------------------------------------------------------
 
+#if __GLASGOW_HASKELL__ >= 808
+type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)
+#else
+type Constraints a = (Data a)
+#endif
+
+-- ---------------------------------------------------------------------
+
 -- | 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
@@ -156,9 +170,15 @@
 instance Show AnnKey where
   show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn
 
+
+#if __GLASGOW_HASKELL__ > 806
+mkAnnKeyPrim :: (Constraints a)
+             => a -> AnnKey
+mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a)
+#else
 mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey
 mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a)
-
+#endif
 
 #if __GLASGOW_HASKELL__ <= 802
 type GhcPs = GHC.RdrName
@@ -171,7 +191,11 @@
 #endif
 
 -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.
+#if __GLASGOW_HASKELL__ > 806
+mkAnnKey :: (Constraints a) => a -> AnnKey
+#else
 mkAnnKey :: (Data a) => GHC.Located a -> AnnKey
+#endif
 mkAnnKey ld =
   case cast ld :: Maybe (GHC.LHsDecl GhcPs) of
     Just d -> declFun mkAnnKeyPrim d
@@ -330,6 +354,8 @@
                 | 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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -325,7 +326,12 @@
   -- cm has type :: Map SrcSpan [Located AnnotationComment]
   = map tokComment . GHC.sortLocated . concat $ Map.elems cm
 
+#if __GLASGOW_HASKELL__ > 806
+getAnnotationEP :: (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)
+                => a -> Anns -> Maybe Annotation
+#else
 getAnnotationEP :: (Data a) =>  GHC.Located a  -> Anns -> Maybe Annotation
+#endif
 getAnnotationEP  la as =
   Map.lookup (mkAnnKey la) as
 
diff --git a/tests/Test.hs b/tests/Test.hs
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -28,12 +28,14 @@
 
 -- ---------------------------------------------------------------------
 
-data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86
+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88
      deriving (Eq, Ord, Show)
 
 ghcVersion :: GHCVersion
 ghcVersion =
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 806
+  GHC88
+#elif __GLASGOW_HASKELL__ > 804
   GHC86
 #elif __GLASGOW_HASKELL__ > 802
   GHC84
@@ -54,10 +56,10 @@
     GHC82  -> ["pre-ghc86",  "ghc710", "ghc80", "ghc82", "vect"]
     GHC84  -> ["pre-ghc86",  "ghc710", "ghc80", "ghc82", "ghc84", "vect" ]
     GHC86  -> [              "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ]
+    GHC88  -> [              "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ]
 
-    -- GHC86  -> [             "ghc710", "ghc80", "ghc82", "ghc84"]
-    -- GHC86  -> ["ghc86-copied"]
-    -- GHC86  -> ["ghc86"]
+    -- GHC88  -> ["ghc88"]
+    -- GHC88  -> ["ghc88-copied"]
 
 -- ---------------------------------------------------------------------
 
@@ -198,11 +200,38 @@
 tt' = runTestText (putTextToHandle stdout True) $ TestList [
 
 
-      -- mkPrettyRoundtrip "ghc82" "TensorTests.hs"
+      -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"
+      -- mkPrettyRoundtrip "ghc86" "mdo.hs"
 
-      mkParserTest      "ghc710" "GADTContext.hs"
+      -- mkParserTest      "ghc88" "DumpParsedast.hs"
+      -- mkParserTest      "ghc88-copied" "T15365.hs"
+      -- mkPrettyRoundtrip  "ghc88-copied" "T15365.hs"
+      -- mkParserTest      "ghc88-copied" "T4437.hs"
 
+      -- mkParserTest      "ghc88-copied" "TH_recover_warns.hs"
+      -- mkPrettyRoundtrip  "ghc88-copied" "TH_recover_warns.hs"
+
+      -- mkParserTest      "ghc88-copied" "TH_recursiveDoImport.hs"
+      -- mkPrettyRoundtrip  "ghc88-copied" "TH_recursiveDoImport.hs"
+
+      -- mkParserTest      "ghc88-copied" "dsrun010.hs"
+      -- mkPrettyRoundtrip  "ghc88-copied" "dsrun010.hs"
+
+        -- mkParserTest      "ghc88" "Internal.hs"
+        -- mkParserTest      "ghc88" "Main.hs"
+        mkParserTest      "ghc88" "PersistUniqueTest.hs"
+
+      -- ---------------------------------------------------------------
+      -- mkParserTest "ghc710" "Roles.hs"
+      -- ---------------------------------------------------------------
+
+
+
+
       -- mkParserTest      "ghc86" "deriving-via-compile.hs"
+      -- mkParserTest      "ghc88" "ClassParens.hs"
+
+
     --   mkParserTest "pre-ghc86" "TensorTests.hs"
     -- , mkParserTest "pre-ghc86" "Webhook.hs"
     -- , mkParserTest "ghc710" "RdrNames.hs"
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
--- a/tests/Test/Transform.hs
+++ b/tests/Test/Transform.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 module Test.Transform where
 
 import Language.Haskell.GHC.ExactPrint
@@ -329,18 +330,43 @@
 #endif
     replaceHsVar x = x
 
-#if __GLASGOW_HASKELL__ > 802
+
+
+#if __GLASGOW_HASKELL__ > 806
     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
-#endif
+    replacePat (GHC.dL->GHC.L ln (GHC.VarPat {}))
+        | cond ln = GHC.cL ln (GHC.VarPat GHC.noExt (GHC.cL ln newName))
+#elif __GLASGOW_HASKELL__ > 804
+    replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
     replacePat (GHC.L ln (GHC.VarPat {}))
-#if __GLASGOW_HASKELL__ <= 710
-        | cond ln = GHC.L ln (GHC.VarPat newName)
-#elif __GLASGOW_HASKELL__ <= 804
+        | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))
+#elif __GLASGOW_HASKELL__ > 802
+    replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
+    replacePat (GHC.L ln (GHC.VarPat {}))
         | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))
+#elif __GLASGOW_HASKELL__ >= 800
+    replacePat (GHC.L ln (GHC.VarPat {}))
+        | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))
 #else
-        | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))
+    replacePat (GHC.L ln (GHC.VarPat {}))
+        | cond ln = GHC.L ln (GHC.VarPat newName)
 #endif
     replacePat x = x
+
+
+
+-- #if __GLASGOW_HASKELL__ > 802
+--     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
+-- #endif
+--     replacePat (GHC.L ln (GHC.VarPat {}))
+-- #if __GLASGOW_HASKELL__ <= 710
+--         | cond ln = GHC.L ln (GHC.VarPat newName)
+-- #elif __GLASGOW_HASKELL__ <= 804
+--         | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))
+-- #else
+--         | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))
+-- #endif
+--     replacePat x = x
 
 
 
diff --git a/tests/examples/failing/dsrun010.hs b/tests/examples/failing/dsrun010.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/failing/dsrun010.hs
@@ -0,0 +1,25 @@
+-- Check that pattern match failure in do-notation
+-- is reflected by calling the monadic 'fail', not by a
+-- runtime exception
+
+{-# LANGUAGE NoMonadFailDesugaring #-}
+{-# OPTIONS -Wno-missing-monadfail-instances #-}
+
+import Control.Monad
+import Data.Maybe
+
+test :: (MonadPlus m) => [a] -> m Bool
+test xs
+  =   do
+        (_:_) <- return xs
+                -- Should fail here
+        return True
+    `mplus`
+        -- Failure in LH arg should trigger RH arg
+      do
+        return False
+
+main :: IO ()
+main
+  = do  let x = fromJust (test [])
+        putStrLn (show x)
diff --git a/tests/examples/ghc88/ClassParens.hs b/tests/examples/ghc88/ClassParens.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/ClassParens.hs
@@ -0,0 +1,11 @@
+module ClassParens where
+
+class LiftingMonad  (trans :: MTrans) where
+  proof :: Monad m :- Monad (trans m)
+
+class LiftingMonad2  ((trans :: MTrans)) where
+  proof :: Monad m :- Monad (trans m)
+
+data Nat (t :: NatKind) where
+    ZeroNat :: Nat Zero
+    SuccNat :: Nat t -> Nat (Succ t)
diff --git a/tests/examples/ghc88/DumpParsedAst.hs b/tests/examples/ghc88/DumpParsedAst.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/DumpParsedAst.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies
+             , TypeApplications, TypeInType #-}
+
+module DumpParsedAst where
+import Data.Kind
+
+data Peano = Zero | Succ Peano
+
+type family Length (as :: [k]) :: Peano where
+  Length (a : as) = Succ (Length as)
+  Length '[]      = Zero
+
+-- vis kind app
+data T f (a :: k) = MkT (f a)
+
+type family F1 (a :: k) (f :: k -> Type) :: Type where
+  F1 @Peano a f = T @Peano f a
+
+main = putStrLn "hello"
+
diff --git a/tests/examples/ghc88/EmptyCase008.hs b/tests/examples/ghc88/EmptyCase008.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/EmptyCase008.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-}
+
+-- Check interaction between Newtypes and DataFamilies
+module EmptyCase008 where
+
+import Data.Kind (Type)
+
+data family DA a
+
+newtype Foo3 a = Foo3 (DA a)
+
+data instance DA Int = MkDA1 Char | MkDA2
+
+-- Non-exhaustive. Missing: MkDA1 Char, MkDA2
+f11 :: Foo3 Int -> ()
+f11 = \case
+
+-- Non-exhaustive. (no info about a)
+f12 :: Foo3 a -> ()
+f12 = \case
+
+data instance DA () -- Empty data type
+
+-- Exhaustive.
+f13 :: Foo3 () -> ()
+f13 = \case
+
+-- ----------------
+data family DB a :: Type -> Type
+
+data instance DB Int a where
+  MkDB1 :: DB Int ()
+  MkDB2 :: DB Int Bool
+
+newtype Foo4 a b = Foo4 (DB a b)
+
+-- Non-exhaustive. Missing: Foo4 MkDB1
+f14 :: Foo4 Int () -> ()
+f14 = \case
+
+-- Exhaustive
+f15 :: Foo4 Int [a] -> ()
+f15 = \case
+
+-- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b)
+f16 :: Foo4 a b -> ()
+f16 = \case
+
+data instance DB Char Bool -- Empty data type
+
+-- Exhaustive (empty data type)
+f17 :: Foo4 Char Bool -> ()
+f17 = \case
+
diff --git a/tests/examples/ghc88/Exp.hs b/tests/examples/ghc88/Exp.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/Exp.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Data.Array.Accelerate.Utility.Lift.Exp (
+   Unlift,
+   Unlifted,
+   Tuple,
+   unlift,
+   modify,
+   modify2,
+   modify3,
+   modify4,
+   Exp(Exp), expr, atom,
+   unliftPair,
+   unliftTriple,
+   unliftQuadruple,
+   asExp,
+   mapFst,
+   mapSnd,
+   fst3,
+   snd3,
+   thd3,
+   indexCons,
+   ) where
+
+import qualified Data.Array.Accelerate.Data.Complex as Complex
+import qualified Data.Array.Accelerate as A
+import Data.Complex (Complex((:+)))
+import Data.Array.Accelerate ((:.)((:.)))
+
+import qualified Data.Tuple.HT as Tuple
+import Data.Tuple.HT (mapTriple)
+
+
+{- |
+This class simplifies untupling of expressions.
+If you have a function
+
+> g :: ((Exp a, Exp b), Exp (c,d)) -> (Exp e, Exp f)
+
+you cannot apply it to an array @arr :: Array sh ((a,b),(c,d))@ using 'A.map'.
+Here, the 'modify' function helps:
+
+> modify ((expr,expr),expr) g :: Exp ((a,b),(c,d)) -> Exp (e,f)
+
+The 'expr'-pattern tells, how deep the tuple shall be unlifted.
+This way you can write:
+
+> A.map
+>    (Exp.modify ((expr,expr),expr) $ \((a,b), cd) -> g ((a,b), cd))
+>    arr
+
+'modify' is based on 'unlift'.
+In contrast to 'A.unlift' it does not only unlift one level of tupels,
+but is guided by an 'expr'-pattern.
+In the example I have demonstrated,
+how the pair @(a,b)@ is unlifted, but the pair @(c,d)@ is not.
+For the result tuple, 'modify' simply calls 'A.lift'.
+In contrast to 'A.unlift',
+'A.lift' lifts over all tupel levels until it obtains a single 'Exp'.
+-}
+class
+   (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) =>
+      Unlift pattern where
+   type Unlifted pattern
+   type Tuple pattern
+   unlift :: pattern -> A.Exp (Tuple pattern) -> Unlifted pattern
+
+modify ::
+   (A.Lift A.Exp a, Unlift pattern) =>
+   pattern ->
+   (Unlifted pattern -> a) ->
+   A.Exp (Tuple pattern) -> A.Exp (A.Plain a)
+modify p f = A.lift . f . unlift p
+
+modify2 ::
+   (A.Lift A.Exp a, Unlift patternA, Unlift patternB) =>
+   patternA ->
+   patternB ->
+   (Unlifted patternA -> Unlifted patternB -> a) ->
+   A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (A.Plain a)
+modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b)
+
+modify3 ::
+   (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC) =>
+   patternA ->
+   patternB ->
+   patternC ->
+   (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) ->
+   A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) ->
+   A.Exp (Tuple patternC) -> A.Exp (A.Plain a)
+modify3 pa pb pc f a b c =
+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c)
+
+modify4 ::
+   (A.Lift A.Exp a,
+    Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) =>
+   patternA ->
+   patternB ->
+   patternC ->
+   patternD ->
+   (Unlifted patternA -> Unlifted patternB ->
+    Unlifted patternC -> Unlifted patternD -> a) ->
+   A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) ->
+   A.Exp (Tuple patternC) -> A.Exp (Tuple patternD) -> A.Exp (A.Plain a)
+modify4 pa pb pc pd f a b c d =
+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d)
+
+
+instance (A.Elt a) => Unlift (Exp a) where
+   type Unlifted (Exp a) = A.Exp a
+   type Tuple (Exp a) = a
+   unlift _ = id
+
+data Exp e = Exp
+
+expr :: Exp e
+expr = Exp
+
+{-# DEPRECATED atom "use expr instead" #-}
+-- | for compatibility with accelerate-utility-0.0
+atom :: Exp e
+atom = expr
+
+
+instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where
+   type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb)
+   type Tuple (pa,pb) = (Tuple pa, Tuple pb)
+   unlift (pa,pb) ab =
+      (unlift pa $ A.fst ab, unlift pb $ A.snd ab)
+
+instance
+   (Unlift pa, Unlift pb, Unlift pc) =>
+      Unlift (pa,pb,pc) where
+   type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc)
+   type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc)
+   unlift (pa,pb,pc) =
+      mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift
+
+
+instance (Unlift pa, A.Slice (Tuple pa), int ~ Exp Int) => Unlift (pa :. int) where
+   type Unlifted (pa :. int) = Unlifted pa :. A.Exp Int
+   type Tuple (pa :. int) = Tuple pa :. Int
+   unlift (pa:.pb) ab =
+      (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab)
+
+
+instance (Unlift p) => Unlift (Complex p) where
+   type Unlifted (Complex p) = Complex (Unlifted p)
+   type Tuple (Complex p) = Complex (Tuple p)
+   unlift (preal:+pimag) z =
+      unlift preal (Complex.real z)
+      :+
+      unlift pimag (Complex.imag z)
+
+
+unliftPair :: (A.Elt a, A.Elt b) => A.Exp (a,b) -> (A.Exp a, A.Exp b)
+unliftPair = A.unlift
+
+unliftTriple ::
+   (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> (A.Exp a, A.Exp b, A.Exp c)
+unliftTriple = A.unlift
+
+unliftQuadruple ::
+   (A.Elt a, A.Elt b, A.Elt c, A.Elt d) =>
+   A.Exp (a,b,c,d) -> (A.Exp a, A.Exp b, A.Exp c, A.Exp d)
+unliftQuadruple = A.unlift
+
+asExp :: A.Exp a -> A.Exp a
+asExp = id
+
+mapFst ::
+   (A.Elt a, A.Elt b, A.Elt c) =>
+   (A.Exp a -> A.Exp b) -> A.Exp (a,c) -> A.Exp (b,c)
+mapFst f = modify (expr,expr) $ \(a,c) -> (f a, c)
+
+mapSnd ::
+   (A.Elt a, A.Elt b, A.Elt c) =>
+   (A.Exp b -> A.Exp c) -> A.Exp (a,b) -> A.Exp (a,c)
+mapSnd f = modify (expr,expr) $ \(a,b) -> (a, f b)
+
+
+fst3 ::
+   (A.Elt a, A.Elt b, A.Elt c) =>
+   A.Exp (a,b,c) -> A.Exp a
+fst3 = modify (expr,expr,expr) Tuple.fst3
+
+snd3 ::
+   (A.Elt a, A.Elt b, A.Elt c) =>
+   A.Exp (a,b,c) -> A.Exp b
+snd3 = modify (expr,expr,expr) Tuple.snd3
+
+thd3 ::
+   (A.Elt a, A.Elt b, A.Elt c) =>
+   A.Exp (a,b,c) -> A.Exp c
+thd3 = modify (expr,expr,expr) Tuple.thd3
+
+
+
+indexCons ::
+   (A.Slice ix) => A.Exp ix -> A.Exp Int -> A.Exp (ix :. Int)
+indexCons ix n = A.lift $ ix:.n
+
diff --git a/tests/examples/ghc88/ExplicitForAllRules1.hs b/tests/examples/ghc88/ExplicitForAllRules1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/ExplicitForAllRules1.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeApplications #-}
+
+module ExplicitForAllRules1 where
+
+import Data.Proxy
+import Data.Kind
+
+-- From Proposal 0007 (w/ fix to "example")
+
+{-# RULES
+"example"  forall a b. forall. map @a @b f = f
+"example2" forall a. forall (x :: a). id x = x
+  #-}
+
+{-# NOINLINE f #-}
+f :: a -> b
+f = undefined
+
+-- More tests
+
+{-# RULES
+"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = ()
+"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @()
+"example5" forall (a :: Type). forall. h @a = id @a
+"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x
+  #-}
+
+{-# NOINLINE g #-}
+g :: a -> b -> ()
+g _ _ = ()
+
+{-# NOINLINE h #-}
+h :: a -> a
+h x = x
+
+-- Should NOT have a parse error :(
+{-# RULES "example6" forall a forall. g a forall = () #-}
+
+-- Should generate a warning
+{-# RULES "example7" forall a b. forall (x :: a). id x = x #-}
+
diff --git a/tests/examples/ghc88/Internal.hs b/tests/examples/ghc88/Internal.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/Internal.hs
@@ -0,0 +1,342 @@
+{-# language GADTs, RankNTypes #-}
+{-# language FlexibleContexts, DefaultSignatures #-}
+{-# language TypeOperators #-}
+{-# language LambdaCase #-}
+{-# language EmptyCase #-}
+module Hedgehog.Function.Internal where
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Data.Bifunctor (first)
+import Data.Functor.Contravariant (Contravariant(..))
+import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..))
+import Data.Functor.Identity (Identity(..))
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Maybe (fromJust)
+import Data.Void (Void, absurd)
+import Data.Word (Word8, Word64)
+import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT)
+import Hedgehog.Internal.Seed (Seed(..))
+import Hedgehog.Internal.Tree (Tree(..), Node(..))
+import Hedgehog.Internal.Property (PropertyT, forAll)
+
+import GHC.Generics
+
+import qualified Hedgehog.Internal.Tree as Tree
+
+infixr 5 :->
+
+-- | Shrinkable, showable functions
+--
+-- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl).
+-- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM.
+data a :-> c where
+  Unit :: c -> () :-> c
+  Nil :: a :-> c
+  Pair :: a :-> b :-> c -> (a, b) :-> c
+  Sum :: a :-> c -> b :-> c -> Either a b :-> c
+  Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c
+
+instance Functor ((:->) r) where
+  fmap f (Unit c) = Unit $ f c
+  fmap _ Nil = Nil
+  fmap f (Pair a) = Pair $ fmap (fmap f) a
+  fmap f (Sum a b) = Sum (fmap f a) (fmap f b)
+  fmap f (Map a b c) = Map a b (fmap f c)
+
+-- | Tabulate the function
+table :: a :-> c -> [(a, c)]
+table (Unit c) = [((), c)]
+table Nil = []
+table (Pair f) = do
+  (a, bc) <- table f
+  (b, c) <- table bc
+  pure ((a, b), c)
+table (Sum a b) =
+  [(Left x, c) | (x, c) <- table a] ++
+  [(Right x, c) | (x, c) <- table b]
+table (Map _ g a) = first g <$> table a
+
+class GArg a where
+  gbuild' :: (a x -> c) -> a x :-> c
+
+-- | Reify a function whose domain has an instance of 'Generic'
+gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c
+gbuild = gvia from to
+
+-- | @instance Arg A where@ allows functions which take @A@s to be reified
+class Arg a where
+  build :: (a -> c) -> a :-> c
+  default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c
+  build = gbuild
+
+variant :: Word64 -> GenT m b -> GenT m b
+variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n})
+
+variant' :: Word64 -> CoGenT m b -> CoGenT m b
+variant' n (CoGenT f) =
+  CoGenT $ \a -> variant n . f a
+
+class GVary a where
+  gvary' :: CoGenT m (a x)
+
+instance GVary V1 where
+  gvary' = conquer
+
+instance GVary U1 where
+  gvary' = conquer
+
+instance (GVary a, GVary b) => GVary (a :+: b) where
+  gvary' =
+    choose
+      (\case; L1 a -> Left a; R1 a -> Right a)
+      (variant' 0 gvary')
+      (variant' 1 gvary')
+
+instance (GVary a, GVary b) => GVary (a :*: b) where
+  gvary' =
+    divide
+      (\(a :*: b) -> (a, b))
+      (variant' 0 gvary')
+      (variant' 1 gvary')
+
+instance GVary c => GVary (M1 a b c) where
+  gvary' = contramap unM1 gvary'
+
+instance Vary b => GVary (K1 a b) where
+  gvary' = contramap unK1 vary
+
+-- | Build a co-generator for a type which has a 'Generic' instance
+gvary :: (Generic a, GVary (Rep a)) => CoGenT m a
+gvary = CoGenT $ \a -> applyCoGenT gvary' (from a)
+
+-- | 'Vary' provides a canonical co-generator for a type.
+--
+-- While technically there are many possible co-generators for a given type, we don't get any
+-- benefit from caring.
+class Vary a where
+  vary :: CoGenT m a
+  default vary :: (Generic a, GVary (Rep a)) => CoGenT m a
+  vary = gvary
+
+-- | Build a co-generator for an 'Integral' type
+varyIntegral :: Integral a => CoGenT m a
+varyIntegral = CoGenT $ variant . fromIntegral
+
+-- |
+-- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way,
+-- the generated function will have a varying (but still deterministic) right hand side.
+--
+-- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to
+-- derive 'Generic' and use the default instance of the 'Vary' type class.
+--
+-- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@
+newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b }
+type CoGen = CoGenT Identity
+
+instance Contravariant (CoGenT m) where
+  contramap f (CoGenT g) = CoGenT (g . f)
+
+instance Divisible (CoGenT m) where
+  divide f (CoGenT gb) (CoGenT gc) =
+    CoGenT $ \a ->
+    let (b, c) = f a in gc c . gb b
+  conquer = CoGenT $ const id
+
+instance Decidable (CoGenT m) where
+  choose f (CoGenT gb) (CoGenT gc) =
+    CoGenT $ \a ->
+    case f a of
+      Left b -> gb b . variant 0
+      Right c -> gc c . variant 1
+  lose f = CoGenT $ \a -> absurd (f a)
+
+instance (Show a, Show b) => Show (a :-> b) where
+  show = show . table
+
+-- | Evaluate a possibly partial function
+apply' :: a :-> b -> a -> Maybe b
+apply' (Unit c) () = Just c
+apply' Nil _ = Nothing
+apply' (Pair f) (a, b) = do
+  f' <- apply' f a
+  apply' f' b
+apply' (Sum f _) (Left a) = apply' f a
+apply' (Sum _ g) (Right a) = apply' g a
+apply' (Map f _ g) a = apply' g (f a)
+
+-- | Evaluate a total function. Unsafe.
+unsafeApply :: a :-> b -> a -> b
+unsafeApply f = fromJust . apply' f
+
+-- | The type of randomly-generated functions
+data Fn a b = Fn b (a :-> Tree (MaybeT Identity) b)
+
+-- | Extract the root value from a 'Tree'. Unsafe.
+unsafeFromTree :: Functor m => Tree (MaybeT m) a -> m a
+unsafeFromTree =
+  fmap (maybe (error "empty generator in function") nodeValue) .
+  runMaybeT .
+  runTree
+
+instance (Show a, Show b) => Show (Fn a b) where
+  show (Fn b a) =
+    case table a of
+      [] -> "_ -> " ++ show b
+      ta -> showTable ta ++ "_ -> " ++ show b
+    where
+      showTable :: (Show a, Show b) => [(a, Tree (MaybeT Identity) b)] -> String
+      showTable [] = "<empty function>\n"
+      showTable (x : xs) = unlines (showCase <$> x : xs)
+        where
+          showCase (lhs, rhs) = show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs)
+
+-- | Shrink the function
+shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b]
+shrinkFn shr (Unit a) = Unit <$> shr a
+shrinkFn _ Nil = []
+shrinkFn shr (Pair f) =
+  (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f
+shrinkFn shr (Sum a b) =
+  fmap (\case; Sum Nil Nil -> Nil; x -> x) $
+  [ Sum a Nil | notNil b ] ++
+  [ Sum Nil b | notNil a ] ++
+  fmap (`Sum` b) (shrinkFn shr a) ++
+  fmap (a `Sum`) (shrinkFn shr b)
+  where
+    notNil Nil = False
+    notNil _ = True
+shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a
+
+shrinkTree :: Monad m => Tree (MaybeT m) a -> m [Tree (MaybeT m) a]
+shrinkTree (Tree m) = do
+  a <- runMaybeT m
+  case a of
+    Nothing -> pure []
+    Just (Node _ cs) -> pure cs
+
+-- | Evaluate an 'Fn'
+apply :: Fn a b -> a -> b
+apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f
+
+-- | Generate a function using the user-supplied co-generator
+fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b)
+fnWith cg gb =
+  Fn <$>
+  gb <*>
+  genFn (\a -> applyCoGenT cg a gb)
+  where
+    genFn :: Arg a => (a -> Gen b) -> Gen (a :-> Tree (MaybeT Identity) b)
+    genFn g =
+      GenT $ \sz sd ->
+      Tree.unfold (shrinkFn $ runIdentity . shrinkTree) .
+      fmap (runGenT sz sd) $ build g
+
+-- | Generate a function
+fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b)
+fn = fnWith vary
+
+-- | Run the function generator to retrieve a function
+forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b)
+forAllFn = fmap apply . forAll
+
+instance Vary ()
+instance (Vary a, Vary b) => Vary (Either a b)
+instance (Vary a, Vary b) => Vary (a, b)
+instance Vary Void
+instance Vary Bool
+instance Vary Ordering
+instance Vary a => Vary (Maybe a)
+instance Vary a => Vary [a]
+instance Vary Int8 where; vary = varyIntegral
+instance Vary Int16 where; vary = varyIntegral
+instance Vary Int32 where; vary = varyIntegral
+instance Vary Int64 where; vary = varyIntegral
+instance Vary Int where; vary = varyIntegral
+instance Vary Integer where; vary = varyIntegral
+instance Vary Word8 where; vary = varyIntegral
+
+-- | Reify a function via an isomorphism.
+--
+-- If your function's domain has no instance of 'Generic' then you can still reify it using
+-- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral'
+-- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element
+-- is the sign, and the second element is the bit-string.
+--
+-- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@
+via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
+via a b f = Map a b . build $ f . b
+
+instance Arg Void where
+  build _ = Nil
+
+instance Arg () where
+  build f = Unit $ f ()
+
+instance (Arg a, Arg b) => Arg (a, b) where
+  build f = Pair . build $ \a -> build $ \b -> f (a, b)
+
+instance (Arg a, Arg b) => Arg (Either a b) where
+  build f = Sum (build $ f . Left) (build $ f . Right)
+
+gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c
+gvia a b f = Map a b . gbuild' $ f . b
+
+instance GArg V1 where
+  gbuild' _ = Nil
+
+instance GArg U1 where
+  gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1)
+
+instance (GArg a, GArg b) => GArg (a :*: b) where
+  gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b)
+    where
+      fromPair (a :*: b) = (a, b)
+      toPair (a, b) = (a :*: b)
+
+instance (GArg a, GArg b) => GArg (a :+: b) where
+  gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1)
+    where
+      fromSum = \case; L1 a -> Left a; R1 a -> Right a
+      toSum = either L1 R1
+
+instance GArg c => GArg (M1 a b c) where
+  gbuild' = gvia unM1 M1
+
+instance Arg b => GArg (K1 a b) where
+  gbuild' f = Map unK1 K1 . build $ f . K1
+
+-- | Reify a function on 'Integral's
+buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c)
+buildIntegral = via toBits fromBits
+  where
+    toBits :: Integral a => a -> (Bool, [Bool])
+    toBits n
+      | n >= 0 = (True, go n)
+      | otherwise = (False, go $ -n - 1)
+      where
+        go 0 = []
+        go m =
+          let
+            (q, r) = quotRem m 2
+          in
+            (r == 1) : go q
+
+    fromBits :: Integral a => (Bool, [Bool]) -> a
+    fromBits (pos, bts)
+      | pos = go bts
+      | otherwise = negate $ go bts + 1
+      where
+        go [] = 0
+        go (x:xs) = (if x then 1 else 0) + 2 * go xs
+
+instance Arg Bool
+instance Arg Ordering
+instance Arg a => Arg (Maybe a)
+instance Arg a => Arg [a]
+instance Arg Int8 where; build = buildIntegral
+instance Arg Int16 where; build = buildIntegral
+instance Arg Int32 where; build = buildIntegral
+instance Arg Int64 where; build = buildIntegral
+instance Arg Int where; build = buildIntegral
+instance Arg Integer where; build = buildIntegral
+
diff --git a/tests/examples/ghc88/PersistUniqueTest.hs b/tests/examples/ghc88/PersistUniqueTest.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/PersistUniqueTest.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+module PersistUniqueTest where
+
+import Init
+
+-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs
+#if WITH_NOSQL
+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|
+#else
+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|
+#endif
+  Fo
+      foo Int
+      bar Int
+      Primary foo
+      UniqueBar bar
+      deriving Eq Show
+|]
+#ifdef WITH_NOSQL
+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m ()
+cleanDB = do
+  deleteWhere ([] :: [Filter Fo])
+
+db :: Action IO () -> Assertion
+db = db' cleanDB
+#endif
+
+specs :: Spec
+specs = describe "custom primary key" $ do
+#ifdef WITH_NOSQL
+  return ()
+#else
+  it "getBy" $ db $ do
+    let b = 5
+    k <- insert $ Fo 3 b
+    Just vk <- get k
+    Just vu <- getBy (UniqueBar b)
+    vu @== Entity k vk
+  it "insertUniqueEntity" $ db $ do
+    let fo = Fo 3 5
+    Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
+    Nothing <- insertUniqueEntity fo
+    fo @== insertedFoValue
+#endif
+
diff --git a/tests/examples/ghc88/StarBinder.hs b/tests/examples/ghc88/StarBinder.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/StarBinder.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeOperators, TypeFamilies #-}
+{-# OPTIONS -Wno-star-is-type #-}
+
+module X (type (X.*)) where
+
+type family (*) a b where { (*) a b = Either b a }
+
diff --git a/tests/examples/ghc88/T12045TH1.hs b/tests/examples/ghc88/T12045TH1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/T12045TH1.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds
+             , TypeInType, TypeApplications, TypeFamilies  #-}
+
+module T12045TH1 where
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+
+$([d| type family F (a :: k) :: Type where
+                     F @Type Int = Bool
+                     F @(Type->Type) Maybe = Char |])
+
+
+$([d| data family D (a :: k) |])
+
+$([d| data instance D @Type a = DBool |])
+
+$([d| data instance D @(Type -> Type) b = DChar |])
+
diff --git a/tests/examples/ghc88/T12045TH2.hs b/tests/examples/ghc88/T12045TH2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/T12045TH2.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds
+             , TypeFamilies, DataKinds #-}
+
+module T12045TH2 where
+
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+import System.IO
+
+type family Foo (a :: k) :: Type where
+  Foo @Type a = Bool
+
+type family Baz (a :: k)
+type instance Baz @(Type->Type->Type) a = Char
+
+$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1)
+                   [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1])
+              [] <- reify ''Foo
+      FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2))
+              [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz
+      runIO $ putStrLn $ pprint foo
+      runIO $ putStrLn $ pprint baz
+      runIO $ putStrLn $ pprint inst
+      runIO $ hFlush stdout
+      return [ ClosedTypeFamilyD
+                 (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1)
+                 [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1]
+             , OpenTypeFamilyD
+                 (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2)
+             , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] )
+
diff --git a/tests/examples/ghc88/T12045a.hs b/tests/examples/ghc88/T12045a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/T12045a.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds,
+    RankNTypes, ConstraintKinds, TypeFamilies #-}
+
+module T12045a where
+
+import Data.Kind
+import Data.Typeable
+
+data T (f :: k -> Type) a = MkT (f a)
+
+newtype TType f a= MkTType (T @Type f a)
+
+t1 :: TType Maybe Bool
+t1 = MkTType (MkT (Just True))
+
+t2 :: TType Maybe a
+t2 = MkTType (MkT Nothing)
+
+data Nat = O | S Nat
+
+data T1 :: forall k1 k2. k1 -> k2 -> Type where
+  MkT1 :: T1 a b
+
+x :: T1 @_ @Nat False n
+x = MkT1
+
+-- test from trac 12045
+type Cat k = k -> k -> Type
+
+data FreeCat :: Cat k -> Cat k where
+  Nil  :: FreeCat f a a
+  Cons :: f a b -> FreeCat f b c -> FreeCat f a c
+
+liftCat :: f a b -> FreeCat f a b
+liftCat x = Cons x Nil
+
+data Node = Unit | N
+
+data NatGraph :: Cat Node where
+  One  :: NatGraph Unit N
+  Succ :: NatGraph N    N
+
+one :: (FreeCat @Node NatGraph) Unit N
+one = liftCat One
+
+type Typeable1 = Typeable @(Type -> Type)
+type Typeable2 = Typeable @(Type -> Type -> Type)
+type Typeable3 = Typeable @(Cat Bool)
+
+type family F a where
+  F Type = Type -> Type
+  F (Type -> Type) = Type
+  F other = other
+
+data T2 :: F k -> Type
+
+foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type
+foo a b = undefined
+
+data family D (a :: k)
+data instance D @Type a = DBool
+data instance D @(Type -> Type) b = DChar
+
+class C a where
+  tc :: (D a) -> Int
+
+instance C Int where
+  tc DBool = 5
+
+instance C Bool where
+  tc DBool = 6
+
+instance C Maybe where
+  tc DChar = 7
+
+-- Tests from D5229
+data P a = MkP
+type MkPTrue = MkP @Bool
+
+type BoolEmpty = '[] @Bool
+
+type family F1 (a :: k) :: Type
+type G2 (a :: Bool) = F1 @Bool a
+
diff --git a/tests/examples/ghc88/T13087.hs b/tests/examples/ghc88/T13087.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/T13087.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE AlternativeLayoutRule #-}
+{-# LANGUAGE LambdaCase            #-}
+
+isOne :: Int -> Bool
+isOne = \case 1 -> True
+              _ -> False
+
+main = return ()
+
diff --git a/tests/examples/ghc88/T15365.hs b/tests/examples/ghc88/T15365.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/T15365.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module T15365 where
+
+$([d| type (|||) = Either
+
+      (&&&) :: Bool -> Bool -> Bool
+      (&&&) = (&&)
+
+      type role (***)
+      data (***)
+
+      class (???)
+      instance (???)
+
+      data family ($$$)
+      data instance ($$$)
+
+      type family (^^^)
+      type instance (^^^) = Int
+
+      type family (###) where
+        (###) = Int
+
+      pattern (:!!!) :: Bool
+      pattern (:!!!) = True
+    |])
+
diff --git a/tests/examples/ghc88/T4437.hs b/tests/examples/ghc88/T4437.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/T4437.hs
@@ -0,0 +1,57 @@
+-- | A test for ensuring that GHC's supporting language extensions remains in
+-- sync with Cabal's own extension list.
+--
+-- If you have ended up here due to a test failure, please see
+-- Note [Adding a language extension] in compiler/main/DynFlags.hs.
+
+module Main (main) where
+
+import Control.Monad
+import Data.List
+import DynFlags
+import Language.Haskell.Extension
+
+main :: IO ()
+main = do
+    let ghcExtensions = map flagSpecName xFlags
+        cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ]
+        ghcOnlyExtensions = ghcExtensions \\ cabalExtensions
+        cabalOnlyExtensions = cabalExtensions \\ ghcExtensions
+    check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions
+    check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions
+
+check :: String -> [String] -> [String] -> IO ()
+check title expected got
+    = do let unexpected = got \\ expected
+             missing = expected \\ got
+             showProblems problemType problems
+                 = unless (null problems) $
+                       do putStrLn (title ++ ": " ++ problemType)
+                          putStrLn "-----"
+                          mapM_ putStrLn problems
+                          putStrLn "-----"
+                          putStrLn ""
+         showProblems "Unexpected flags" unexpected
+         showProblems "Missing flags" missing
+
+-- See Note [Adding a language extension] in compiler/main/DynFlags.hs.
+expectedGhcOnlyExtensions :: [String]
+expectedGhcOnlyExtensions = ["RelaxedLayout",
+                             "AlternativeLayoutRule",
+                             "AlternativeLayoutRuleTransitional",
+                             "EmptyDataDeriving",
+                             "GeneralisedNewtypeDeriving"]
+
+expectedCabalOnlyExtensions :: [String]
+expectedCabalOnlyExtensions = ["Generics",
+                               "ExtensibleRecords",
+                               "RestrictedTypeSynonyms",
+                               "HereDocuments",
+                               "NewQualifiedOperators",
+                               "XmlSyntax",
+                               "RegularPatterns",
+                               "SafeImports",
+                               "Safe",
+                               "Unsafe",
+                               "Trustworthy"]
+
diff --git a/tests/examples/ghc88/TH_recover_warns.hs b/tests/examples/ghc88/TH_recover_warns.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/TH_recover_warns.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+module Bug where
+
+import Language.Haskell.TH
+
+-- Warnings should be preserved through recover
+main :: IO ()
+main = putStrLn $(recover (stringE "splice failed")
+                          [| let x = "a" in let x = "b" in x |])
+
diff --git a/tests/examples/ghc88/TH_recursiveDoImport.hs b/tests/examples/ghc88/TH_recursiveDoImport.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/TH_recursiveDoImport.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_recursiveDoImport where
+import Data.IORef
+import Language.Haskell.TH
+
+data SelfRef = SelfRef (IORef (IORef SelfRef))
+
+recIO :: ExpQ
+recIO = [e|
+    do rec r1 <- newIORef r2
+           r2 <- newIORef (SelfRef r1)
+       readIORef r2 |]
+
+mdoIO :: ExpQ
+mdoIO = [e|
+    mdo r1 <- return r2
+        r2 <- return (const 1 r1)
+        return r1 |]
+
+emptyRecIO :: ExpQ
+emptyRecIO = [e|
+   do rec {}
+      return () |]
+
diff --git a/tests/examples/ghc88/TH_reifyDecl1.hs b/tests/examples/ghc88/TH_reifyDecl1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/TH_reifyDecl1.hs
@@ -0,0 +1,94 @@
+-- test reification of data declarations
+
+{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_reifyDecl1 where
+
+import Data.Kind as K
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+infixl 3 `m1`
+
+-- simple
+data T = A | B
+
+-- parametric
+data R a = C a | D
+
+-- recursive
+data List a = Nil | Cons a (List a)
+
+-- infix operator
+data Tree a = Leaf | Tree a :+: Tree a
+
+-- type declaration
+type IntList = [Int]
+
+-- newtype declaration
+newtype Length = Length Int
+
+-- simple class
+class C1 a where
+  m1 :: a -> Int
+
+-- class with instances
+class C2 a where
+  m2 :: a -> Int
+instance C2 Int where
+  m2 x = x
+
+-- associated types
+class C3 a where
+  type AT1 a
+  data AT2 a
+
+instance C3 Int where
+  type AT1 Int = Bool
+  data AT2 Int = AT2Int
+
+-- type family
+type family TF1 a
+
+-- type family, with instances
+type family TF2 a
+type instance TF2 Bool = Bool
+
+-- data family
+data family DF1 a
+
+-- data family, with instances
+data family DF2 a
+data instance DF2 Bool = DBool
+
+data family DF3 (a :: k)
+data instance DF3 @K.Type a = DF3Bool
+data instance DF3 @(K.Type -> K.Type) b = DF3Char
+
+$(return [])
+
+test :: ()
+test = $(let
+      display :: Name -> Q ()
+      display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
+    in do { display ''T
+          ; display ''R
+          ; display ''List
+          ; display ''Tree
+          ; display ''IntList
+          ; display ''Length
+          ; display 'Leaf
+          ; display 'm1
+          ; display ''C1
+          ; display ''C2
+          ; display ''C3
+          ; display ''AT1
+          ; display ''AT2
+          ; display ''TF1
+          ; display ''TF2
+          ; display ''DF1
+          ; display ''DF2
+          ; display ''DF3
+          ; [| () |] })
+
diff --git a/tests/examples/ghc88/Utils.hs b/tests/examples/ghc88/Utils.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/Utils.hs
@@ -0,0 +1,1056 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Simple.Utils
+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
+--                portions Copyright (c) 2007, Galois Inc.
+--
+-- Maintainer  :  cabal-devel@haskell.org
+-- Portability :  portable
+--
+-- A large and somewhat miscellaneous collection of utility functions used
+-- throughout the rest of the Cabal lib and in other tools that use the Cabal
+-- lib like @cabal-install@. It has a very simple set of logging actions. It
+-- has low level functions for running programs, a bunch of wrappers for
+-- various directory and file functions that do extra logging.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Isaac Jones nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Simple.Utils (
+        -- * logging and errors
+        die,
+        dieWithLocation,
+        topHandler,
+        warn, notice, info, debug,
+        debugNoWrap, chattyTry,
+
+        -- * running programs
+        rawSystemExit,
+        rawSystemExitCode,
+        rawSystemExitWithEnv,
+        rawSystemStdout,
+        rawSystemStdInOut,
+        rawSystemIOWithEnv,
+        maybeExit,
+        xargs,
+        findProgramLocation,
+
+        -- * copying files
+        createDirectoryIfMissingVerbose,
+        copyFileVerbose,
+        copyDirectoryRecursiveVerbose,
+        copyFiles,
+
+        -- * installing files
+        installOrdinaryFile,
+        installExecutableFile,
+        installOrdinaryFiles,
+        installDirectoryContents,
+
+        -- * File permissions
+        setFileOrdinary,
+        setFileExecutable,
+
+        -- * file names
+        currentDir,
+
+        -- * finding files
+        findFile,
+        findFirstFile,
+        findFileWithExtension,
+        findFileWithExtension',
+
+        -- * environment variables
+        isInSearchPath,
+
+        -- * simple file globbing
+        matchFileGlob,
+        matchDirFileGlob,
+        parseFileGlob,
+        FileGlob(..),
+
+        -- * temp files and dirs
+        withTempFile,
+        withTempDirectory,
+
+        -- * .cabal and .buildinfo files
+        defaultPackageDesc,
+        findPackageDesc,
+        defaultHookedPackageDesc,
+        findHookedPackageDesc,
+
+        -- * reading and writing files safely
+        withFileContents,
+        writeFileAtomic,
+        rewriteFile,
+
+        -- * Unicode
+        fromUTF8,
+        toUTF8,
+        readUTF8File,
+        withUTF8FileContents,
+        writeUTF8File,
+        normaliseLineEndings,
+
+        -- * generic utils
+        equating,
+        comparing,
+        isInfixOf,
+        intercalate,
+        lowercase,
+        wrapText,
+        wrapLine,
+  ) where
+
+import Control.Monad
+    ( when, unless, filterM )
+import Control.Concurrent.MVar
+    ( newEmptyMVar, putMVar, takeMVar )
+import Data.List
+  ( nub, unfoldr, isPrefixOf, tails, intercalate )
+import Data.Char as Char
+    ( toLower, chr, ord )
+import Data.Bits
+    ( Bits((.|.), (.&.), shiftL, shiftR) )
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+
+import System.Directory
+    ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile
+    , findExecutable )
+import System.Environment
+    ( getProgName )
+import System.Cmd
+    ( rawSystem )
+import System.Exit
+    ( exitWith, ExitCode(..) )
+import System.FilePath
+    ( normalise, (</>), (<.>)
+    , getSearchPath, takeDirectory, splitFileName
+    , splitExtension, splitExtensions, splitDirectories )
+import System.Directory
+    ( createDirectory, renameFile, removeDirectoryRecursive )
+import System.IO
+    ( Handle, openFile, openBinaryFile, openBinaryTempFile
+    , IOMode(ReadMode), hSetBinaryMode
+    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
+import System.IO.Error as IO.Error
+    ( isDoesNotExistError, isAlreadyExistsError
+    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )
+import System.IO.Error
+    ( ioeSetLocation, ioeGetLocation )
+import System.IO.Unsafe
+    ( unsafeInterleaveIO )
+import qualified Control.Exception as Exception
+
+import Distribution.Text
+    ( display )
+
+import Control.Exception (evaluate)
+import System.Process (runProcess)
+
+import Control.Concurrent (forkIO)
+import System.Process (runInteractiveProcess, waitForProcess)
+#if __GLASGOW_HASKELL__ >= 702
+import System.Process (showCommandForUser)
+#endif
+
+import Distribution.Compat.CopyFile
+         ( copyFile, copyOrdinaryFile, copyExecutableFile
+         , setFileOrdinary, setFileExecutable, setDirOrdinary )
+import Distribution.Compat.TempFile
+         ( openTempFile, createTempDirectory )
+import Distribution.Compat.Exception
+         ( IOException, throwIOIO, tryIO, catchIO, catchExit )
+import Distribution.Verbosity
+
+-- ----------------------------------------------------------------------------
+-- Exception and logging utils
+
+dieWithLocation :: FilePath -> Maybe Int -> String -> IO a
+dieWithLocation filename lineno msg =
+  ioError . setLocation lineno
+          . flip ioeSetFileName (normalise filename)
+          $ userError msg
+  where
+    setLocation Nothing  err = err
+    setLocation (Just n) err = ioeSetLocation err (show n)
+
+die :: String -> IO a
+die msg = ioError (userError msg)
+
+topHandler :: IO a -> IO a
+topHandler prog = catchIO prog handle
+  where
+    handle ioe = do
+      hFlush stdout
+      pname <- getProgName
+      hPutStr stderr (mesage pname)
+      exitWith (ExitFailure 1)
+      where
+        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)
+        file         = case ioeGetFileName ioe of
+                         Nothing   -> ""
+                         Just path -> path ++ location ++ ": "
+        location     = case ioeGetLocation ioe of
+                         l@(n:_) | n >= '0' && n <= '9' -> ':' : l
+                         _                              -> ""
+        detail       = ioeGetErrorString ioe
+
+-- | Non fatal conditions that may be indicative of an error or problem.
+--
+-- We display these at the 'normal' verbosity level.
+--
+warn :: Verbosity -> String -> IO ()
+warn verbosity msg =
+  when (verbosity >= normal) $ do
+    hFlush stdout
+    hPutStr stderr (wrapText ("Warning: " ++ msg))
+
+-- | Useful status messages.
+--
+-- We display these at the 'normal' verbosity level.
+--
+-- This is for the ordinary helpful status messages that users see. Just
+-- enough information to know that things are working but not floods of detail.
+--
+notice :: Verbosity -> String -> IO ()
+notice verbosity msg =
+  when (verbosity >= normal) $
+    putStr (wrapText msg)
+
+-- | More detail on the operation of some action.
+--
+-- We display these messages when the verbosity level is 'verbose'
+--
+info :: Verbosity -> String -> IO ()
+info verbosity msg =
+  when (verbosity >= verbose) $
+    putStr (wrapText msg)
+
+-- | Detailed internal debugging information
+--
+-- We display these messages when the verbosity level is 'deafening'
+--
+debug :: Verbosity -> String -> IO ()
+debug verbosity msg =
+  when (verbosity >= deafening) $ do
+    putStr (wrapText msg)
+    hFlush stdout
+
+-- | A variant of 'debug' that doesn't perform the automatic line
+-- wrapping. Produces better output in some cases.
+debugNoWrap :: Verbosity -> String -> IO ()
+debugNoWrap verbosity msg =
+  when (verbosity >= deafening) $ do
+    putStrLn msg
+    hFlush stdout
+
+-- | Perform an IO action, catching any IO exceptions and printing an error
+--   if one occurs.
+chattyTry :: String  -- ^ a description of the action we were attempting
+          -> IO ()   -- ^ the action itself
+          -> IO ()
+chattyTry desc action =
+  catchIO action $ \exception ->
+    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
+
+-- -----------------------------------------------------------------------------
+-- Helper functions
+
+-- | Wraps text to the default line width. Existing newlines are preserved.
+wrapText :: String -> String
+wrapText = unlines
+         . map (intercalate "\n"
+              . map unwords
+              . wrapLine 79
+              . words)
+         . lines
+
+-- | Wraps a list of words to a list of lines of words of a particular width.
+wrapLine :: Int -> [String] -> [[String]]
+wrapLine width = wrap 0 []
+  where wrap :: Int -> [String] -> [String] -> [[String]]
+        wrap 0   []   (w:ws)
+          | length w + 1 > width
+          = wrap (length w) [w] ws
+        wrap col line (w:ws)
+          | col + length w + 1 > width
+          = reverse line : wrap 0 [] (w:ws)
+        wrap col line (w:ws)
+          = let col' = col + length w + 1
+             in wrap col' (w:line) ws
+        wrap _ []   [] = []
+        wrap _ line [] = [reverse line]
+
+-- -----------------------------------------------------------------------------
+-- rawSystem variants
+maybeExit :: IO ExitCode -> IO ()
+maybeExit cmd = do
+  res <- cmd
+  unless (res == ExitSuccess) $ exitWith res
+
+printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
+printRawCommandAndArgs verbosity path args
+ | verbosity >= deafening = print (path, args)
+ | verbosity >= verbose   =
+#if __GLASGOW_HASKELL__ >= 702
+                            putStrLn $ showCommandForUser path args
+#else
+                            putStrLn $ unwords (path : args)
+#endif
+ | otherwise              = return ()
+
+printRawCommandAndArgsAndEnv :: Verbosity
+                             -> FilePath
+                             -> [String]
+                             -> [(String, String)]
+                             -> IO ()
+printRawCommandAndArgsAndEnv verbosity path args env
+ | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)
+                               print (path, args)
+ | verbosity >= verbose   = putStrLn $ unwords (path : args)
+ | otherwise              = return ()
+
+-- Exit with the same exitcode if the subcommand fails
+rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
+rawSystemExit verbosity path args = do
+  printRawCommandAndArgs verbosity path args
+  hFlush stdout
+  exitcode <- rawSystem path args
+  unless (exitcode == ExitSuccess) $ do
+    debug verbosity $ path ++ " returned " ++ show exitcode
+    exitWith exitcode
+
+rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
+rawSystemExitCode verbosity path args = do
+  printRawCommandAndArgs verbosity path args
+  hFlush stdout
+  exitcode <- rawSystem path args
+  unless (exitcode == ExitSuccess) $ do
+    debug verbosity $ path ++ " returned " ++ show exitcode
+  return exitcode
+
+rawSystemExitWithEnv :: Verbosity
+                     -> FilePath
+                     -> [String]
+                     -> [(String, String)]
+                     -> IO ()
+rawSystemExitWithEnv verbosity path args env = do
+    printRawCommandAndArgsAndEnv verbosity path args env
+    hFlush stdout
+    ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing
+    exitcode <- waitForProcess ph
+    unless (exitcode == ExitSuccess) $ do
+        debug verbosity $ path ++ " returned " ++ show exitcode
+        exitWith exitcode
+
+-- Closes the passed in handles before returning.
+rawSystemIOWithEnv :: Verbosity
+                   -> FilePath
+                   -> [String]
+                   -> [(String, String)]
+                   -> Maybe Handle  -- ^ stdin
+                   -> Maybe Handle  -- ^ stdout
+                   -> Maybe Handle  -- ^ stderr
+                   -> IO ExitCode
+rawSystemIOWithEnv verbosity path args env inp out err = do
+    printRawCommandAndArgsAndEnv verbosity path args env
+    hFlush stdout
+    ph <- runProcess path args Nothing (Just env) inp out err
+    exitcode <- waitForProcess ph
+    unless (exitcode == ExitSuccess) $ do
+      debug verbosity $ path ++ " returned " ++ show exitcode
+    return exitcode
+
+-- | Run a command and return its output.
+--
+-- The output is assumed to be text in the locale encoding.
+--
+rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
+rawSystemStdout verbosity path args = do
+  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
+                                                  Nothing False
+  when (exitCode /= ExitSuccess) $
+    die errors
+  return output
+
+-- | Run a command and return its output, errors and exit status. Optionally
+-- also supply some input. Also provides control over whether the binary/text
+-- mode of the input and output.
+--
+rawSystemStdInOut :: Verbosity
+                  -> FilePath -> [String]
+                  -> Maybe (String, Bool) -- ^ input text and binary mode
+                  -> Bool                 -- ^ output in binary mode
+                  -> IO (String, String, ExitCode) -- ^ output, errors, exit
+rawSystemStdInOut verbosity path args input outputBinary = do
+  printRawCommandAndArgs verbosity path args
+
+  Exception.bracket
+     (runInteractiveProcess path args Nothing Nothing)
+     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
+    $ \(inh,outh,errh,pid) -> do
+
+      -- output mode depends on what the caller wants
+      hSetBinaryMode outh outputBinary
+      -- but the errors are always assumed to be text (in the current locale)
+      hSetBinaryMode errh False
+
+      -- fork off a couple threads to pull on the stderr and stdout
+      -- so if the process writes to stderr we do not block.
+
+      err <- hGetContents errh
+      out <- hGetContents outh
+
+      mv <- newEmptyMVar
+      let force str = (evaluate (length str) >> return ())
+            `Exception.finally` putMVar mv ()
+          --TODO: handle exceptions like text decoding.
+      _ <- forkIO $ force out
+      _ <- forkIO $ force err
+
+      -- push all the input, if any
+      case input of
+        Nothing -> return ()
+        Just (inputStr, inputBinary) -> do
+                -- input mode depends on what the caller wants
+          hSetBinaryMode inh inputBinary
+          hPutStr inh inputStr
+          hClose inh
+          --TODO: this probably fails if the process refuses to consume
+          -- or if it closes stdin (eg if it exits)
+
+      -- wait for both to finish, in either order
+      takeMVar mv
+      takeMVar mv
+
+      -- wait for the program to terminate
+      exitcode <- waitForProcess pid
+      unless (exitcode == ExitSuccess) $
+        debug verbosity $ path ++ " returned " ++ show exitcode
+                       ++ if null err then "" else
+                          " with error message:\n" ++ err
+                       ++ case input of
+                            Nothing       -> ""
+                            Just ("",  _) -> ""
+                            Just (inp, _) -> "\nstdin input:\n" ++ inp
+
+      return (out, err, exitcode)
+
+
+-- | Look for a program on the path.
+findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)
+findProgramLocation verbosity prog = do
+  debug verbosity $ "searching for " ++ prog ++ " in path."
+  res <- findExecutable prog
+  case res of
+      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
+      Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)
+  return res
+
+
+-- | Like the unix xargs program. Useful for when we've got very long command
+-- lines that might overflow an OS limit on command line length and so you
+-- need to invoke a command multiple times to get all the args in.
+--
+-- Use it with either of the rawSystem variants above. For example:
+--
+-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
+--
+xargs :: Int -> ([String] -> IO ())
+      -> [String] -> [String] -> IO ()
+xargs maxSize rawSystemFun fixedArgs bigArgs =
+  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
+      chunkSize = maxSize - fixedArgSize
+   in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
+
+  where chunks len = unfoldr $ \s ->
+          if null s then Nothing
+                    else Just (chunk [] len s)
+
+        chunk acc _   []     = (reverse acc,[])
+        chunk acc len (s:ss)
+          | len' < len = chunk (s:acc) (len-len'-1) ss
+          | otherwise  = (reverse acc, s:ss)
+          where len' = length s
+
+-- ------------------------------------------------------------
+-- * File Utilities
+-- ------------------------------------------------------------
+
+----------------
+-- Finding files
+
+-- | Find a file by looking in a search path. The file path must match exactly.
+--
+findFile :: [FilePath]    -- ^search locations
+         -> FilePath      -- ^File Name
+         -> IO FilePath
+findFile searchPath fileName =
+  findFirstFile id
+    [ path </> fileName
+    | path <- nub searchPath]
+  >>= maybe (die $ fileName ++ " doesn't exist") return
+
+-- | Find a file by looking in a search path with one of a list of possible
+-- file extensions. The file base name should be given and it will be tried
+-- with each of the extensions in each element of the search path.
+--
+findFileWithExtension :: [String]
+                      -> [FilePath]
+                      -> FilePath
+                      -> IO (Maybe FilePath)
+findFileWithExtension extensions searchPath baseName =
+  findFirstFile id
+    [ path </> baseName <.> ext
+    | path <- nub searchPath
+    , ext <- nub extensions ]
+
+-- | Like 'findFileWithExtension' but returns which element of the search path
+-- the file was found in, and the file path relative to that base directory.
+--
+findFileWithExtension' :: [String]
+                       -> [FilePath]
+                       -> FilePath
+                       -> IO (Maybe (FilePath, FilePath))
+findFileWithExtension' extensions searchPath baseName =
+  findFirstFile (uncurry (</>))
+    [ (path, baseName <.> ext)
+    | path <- nub searchPath
+    , ext <- nub extensions ]
+
+findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
+findFirstFile file = findFirst
+  where findFirst []     = return Nothing
+        findFirst (x:xs) = do exists <- doesFileExist (file x)
+                              if exists
+                                then return (Just x)
+                                else findFirst xs
+
+
+-- | List all the files in a directory and all subdirectories.
+--
+-- The order places files in sub-directories after all the files in their
+-- parent directories. The list is generated lazily so is not well defined if
+-- the source directory structure changes before the list is used.
+--
+getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
+getDirectoryContentsRecursive topdir = recurseDirectories [""]
+  where
+    recurseDirectories :: [FilePath] -> IO [FilePath]
+    recurseDirectories []         = return []
+    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
+      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
+      files' <- recurseDirectories (dirs' ++ dirs)
+      return (files ++ files')
+
+      where
+        collect files dirs' []              = return (reverse files, reverse dirs')
+        collect files dirs' (entry:entries) | ignore entry
+                                            = collect files dirs' entries
+        collect files dirs' (entry:entries) = do
+          let dirEntry = dir </> entry
+          isDirectory <- doesDirectoryExist (topdir </> dirEntry)
+          if isDirectory
+            then collect files (dirEntry:dirs') entries
+            else collect (dirEntry:files) dirs' entries
+
+        ignore ['.']      = True
+        ignore ['.', '.'] = True
+        ignore _          = False
+
+------------------------
+-- Environment variables
+
+-- | Is this directory in the system search path?
+isInSearchPath :: FilePath -> IO Bool
+isInSearchPath path = fmap (elem path) getSearchPath
+
+----------------
+-- File globbing
+
+data FileGlob
+   -- | No glob at all, just an ordinary file
+   = NoGlob FilePath
+
+   -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to
+   --    @FileGlob \"foo\/bar\" \".baz\"@
+   | FileGlob FilePath String
+
+parseFileGlob :: FilePath -> Maybe FileGlob
+parseFileGlob filepath = case splitExtensions filepath of
+  (filepath', ext) -> case splitFileName filepath' of
+    (dir, "*") | '*' `elem` dir
+              || '*' `elem` ext
+              || null ext            -> Nothing
+               | null dir            -> Just (FileGlob "." ext)
+               | otherwise           -> Just (FileGlob dir ext)
+    _          | '*' `elem` filepath -> Nothing
+               | otherwise           -> Just (NoGlob filepath)
+
+matchFileGlob :: FilePath -> IO [FilePath]
+matchFileGlob = matchDirFileGlob "."
+
+matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]
+matchDirFileGlob dir filepath = case parseFileGlob filepath of
+  Nothing -> die $ "invalid file glob '" ++ filepath
+                ++ "'. Wildcards '*' are only allowed in place of the file"
+                ++ " name, not in the directory name or file extension."
+                ++ " If a wildcard is used it must be with an file extension."
+  Just (NoGlob filepath') -> return [filepath']
+  Just (FileGlob dir' ext) -> do
+    files <- getDirectoryContents (dir </> dir')
+    case   [ dir' </> file
+           | file <- files
+           , let (name, ext') = splitExtensions file
+           , not (null name) && ext' == ext ] of
+      []      -> die $ "filepath wildcard '" ++ filepath
+                    ++ "' does not match any files."
+      matches -> return matches
+
+----------------------------------------
+-- Copying and installing files and dirs
+
+-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
+--
+createDirectoryIfMissingVerbose :: Verbosity
+                                -> Bool     -- ^ Create its parents too?
+                                -> FilePath
+                                -> IO ()
+createDirectoryIfMissingVerbose verbosity create_parents path0
+  | create_parents = createDirs (parents path0)
+  | otherwise      = createDirs (take 1 (parents path0))
+  where
+    parents = reverse . scanl1 (</>) . splitDirectories . normalise
+
+    createDirs []         = return ()
+    createDirs (dir:[])   = createDir dir throwIOIO
+    createDirs (dir:dirs) =
+      createDir dir $ \_ -> do
+        createDirs dirs
+        createDir dir throwIOIO
+
+    createDir :: FilePath -> (IOException -> IO ()) -> IO ()
+    createDir dir notExistHandler = do
+      r <- tryIO $ createDirectoryVerbose verbosity dir
+      case (r :: Either IOException ()) of
+        Right ()                   -> return ()
+        Left  e
+          | isDoesNotExistError  e -> notExistHandler e
+          -- createDirectory (and indeed POSIX mkdir) does not distinguish
+          -- between a dir already existing and a file already existing. So we
+          -- check for it here. Unfortunately there is a slight race condition
+          -- here, but we think it is benign. It could report an exeption in
+          -- the case that the dir did exist but another process deletes the
+          -- directory and creates a file in its place before we can check
+          -- that the directory did indeed exist.
+          | isAlreadyExistsError e -> (do
+              isDir <- doesDirectoryExist dir
+              if isDir then return ()
+                       else throwIOIO e
+              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())
+          | otherwise              -> throwIOIO e
+
+createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
+createDirectoryVerbose verbosity dir = do
+  info verbosity $ "creating " ++ dir
+  createDirectory dir
+  setDirOrdinary dir
+
+-- | Copies a file without copying file permissions. The target file is created
+-- with default permissions. Any existing target file is replaced.
+--
+-- At higher verbosity levels it logs an info message.
+--
+copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
+copyFileVerbose verbosity src dest = do
+  info verbosity ("copy " ++ src ++ " to " ++ dest)
+  copyFile src dest
+
+-- | Install an ordinary file. This is like a file copy but the permissions
+-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"
+-- while on Windows it uses the default permissions for the target directory.
+--
+installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
+installOrdinaryFile verbosity src dest = do
+  info verbosity ("Installing " ++ src ++ " to " ++ dest)
+  copyOrdinaryFile src dest
+
+-- | Install an executable file. This is like a file copy but the permissions
+-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"
+-- while on Windows it uses the default permissions for the target directory.
+--
+installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
+installExecutableFile verbosity src dest = do
+  info verbosity ("Installing executable " ++ src ++ " to " ++ dest)
+  copyExecutableFile src dest
+
+-- | Copies a bunch of files to a target directory, preserving the directory
+-- structure in the target location. The target directories are created if they
+-- do not exist.
+--
+-- The files are identified by a pair of base directory and a path relative to
+-- that base. It is only the relative part that is preserved in the
+-- destination.
+--
+-- For example:
+--
+-- > copyFiles normal "dist/src"
+-- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]
+--
+-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and
+-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".
+--
+-- This operation is not atomic. Any IO failure during the copy (including any
+-- missing source files) leaves the target in an unknown state so it is best to
+-- use it with a freshly created directory so that it can be simply deleted if
+-- anything goes wrong.
+--
+copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
+copyFiles verbosity targetDir srcFiles = do
+
+  -- Create parent directories for everything
+  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
+  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs
+
+  -- Copy all the files
+  sequence_ [ let src  = srcBase   </> srcFile
+                  dest = targetDir </> srcFile
+               in copyFileVerbose verbosity src dest
+            | (srcBase, srcFile) <- srcFiles ]
+
+-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
+--
+installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
+installOrdinaryFiles verbosity targetDir srcFiles = do
+
+  -- Create parent directories for everything
+  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
+  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs
+
+  -- Copy all the files
+  sequence_ [ let src  = srcBase   </> srcFile
+                  dest = targetDir </> srcFile
+               in installOrdinaryFile verbosity src dest
+            | (srcBase, srcFile) <- srcFiles ]
+
+-- | This installs all the files in a directory to a target location,
+-- preserving the directory layout. All the files are assumed to be ordinary
+-- rather than executable files.
+--
+installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
+installDirectoryContents verbosity srcDir destDir = do
+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
+  srcFiles <- getDirectoryContentsRecursive srcDir
+  installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]
+
+---------------------------------
+-- Deprecated file copy functions
+
+{-# DEPRECATED copyDirectoryRecursiveVerbose
+      "You probably want installDirectoryContents instead" #-}
+copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
+copyDirectoryRecursiveVerbose verbosity srcDir destDir = do
+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
+  srcFiles <- getDirectoryContentsRecursive srcDir
+  copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]
+
+---------------------------
+-- Temporary files and dirs
+
+-- | Use a temporary filename that doesn't already exist.
+--
+withTempFile :: Bool     -- ^ Keep temporary files?
+             -> FilePath -- ^ Temp dir to create the file in
+             -> String   -- ^ File name template. See 'openTempFile'.
+             -> (FilePath -> Handle -> IO a) -> IO a
+withTempFile keepTempFiles tmpDir template action =
+  Exception.bracket
+    (openTempFile tmpDir template)
+    (\(name, handle) -> do hClose handle
+                           unless keepTempFiles $ removeFile name)
+    (uncurry action)
+
+-- | Create and use a temporary directory.
+--
+-- Creates a new temporary directory inside the given directory, making use
+-- of the template. The temp directory is deleted after use. For example:
+--
+-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...
+--
+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
+-- @src/sdist.342@.
+--
+withTempDirectory :: Verbosity
+                  -> Bool     -- ^ Keep temporary files?
+                  -> FilePath -> String -> (FilePath -> IO a) -> IO a
+withTempDirectory _verbosity keepTempFiles targetDir template =
+  Exception.bracket
+    (createTempDirectory targetDir template)
+    (unless keepTempFiles . removeDirectoryRecursive)
+
+-----------------------------------
+-- Safely reading and writing files
+
+-- | Gets the contents of a file, but guarantee that it gets closed.
+--
+-- The file is read lazily but if it is not fully consumed by the action then
+-- the remaining input is truncated and the file is closed.
+--
+withFileContents :: FilePath -> (String -> IO a) -> IO a
+withFileContents name action =
+  Exception.bracket (openFile name ReadMode) hClose
+                    (\hnd -> hGetContents hnd >>= action)
+
+-- | Writes a file atomically.
+--
+-- The file is either written sucessfully or an IO exception is raised and
+-- the original file is left unchanged.
+--
+-- On windows it is not possible to delete a file that is open by a process.
+-- This case will give an IO exception but the atomic property is not affected.
+--
+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
+writeFileAtomic targetPath content = do
+  let (targetDir, targetFile) = splitFileName targetPath
+  Exception.bracketOnError
+    (openBinaryTempFile targetDir $ targetFile <.> "tmp")
+    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
+    (\(tmpPath, handle) -> do
+        BS.hPut handle content
+        hClose handle
+        renameFile tmpPath targetPath)
+
+-- | Write a file but only if it would have new content. If we would be writing
+-- the same as the existing content then leave the file as is so that we do not
+-- update the file's modification time.
+--
+rewriteFile :: FilePath -> String -> IO ()
+rewriteFile path newContent =
+  flip catchIO mightNotExist $ do
+    existingContent <- readFile path
+    _ <- evaluate (length existingContent)
+    unless (existingContent == newContent) $
+      writeFileAtomic path (BS.Char8.pack newContent)
+  where
+    mightNotExist e | isDoesNotExistError e = writeFileAtomic path
+                                              (BS.Char8.pack newContent)
+                    | otherwise             = ioError e
+
+-- | The path name that represents the current directory.
+-- In Unix, it's @\".\"@, but this is system-specific.
+-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)
+currentDir :: FilePath
+currentDir = "."
+
+-- ------------------------------------------------------------
+-- * Finding the description file
+-- ------------------------------------------------------------
+
+-- |Package description file (/pkgname/@.cabal@)
+defaultPackageDesc :: Verbosity -> IO FilePath
+defaultPackageDesc _verbosity = findPackageDesc currentDir
+
+-- |Find a package description file in the given directory.  Looks for
+-- @.cabal@ files.
+findPackageDesc :: FilePath    -- ^Where to look
+                -> IO FilePath -- ^<pkgname>.cabal
+findPackageDesc dir
+ = do files <- getDirectoryContents dir
+      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
+      -- file we filter to exclude dirs and null base file names:
+      cabalFiles <- filterM doesFileExist
+                       [ dir </> file
+                       | file <- files
+                       , let (name, ext) = splitExtension file
+                       , not (null name) && ext == ".cabal" ]
+      case cabalFiles of
+        []          -> noDesc
+        [cabalFile] -> return cabalFile
+        multiple    -> multiDesc multiple
+
+  where
+    noDesc :: IO a
+    noDesc = die $ "No cabal file found.\n"
+                ++ "Please create a package description file <pkgname>.cabal"
+
+    multiDesc :: [String] -> IO a
+    multiDesc l = die $ "Multiple cabal files found.\n"
+                    ++ "Please use only one of: "
+                    ++ intercalate ", " l
+
+-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)
+defaultHookedPackageDesc :: IO (Maybe FilePath)
+defaultHookedPackageDesc = findHookedPackageDesc currentDir
+
+-- |Find auxiliary package information in the given directory.
+-- Looks for @.buildinfo@ files.
+findHookedPackageDesc
+    :: FilePath                 -- ^Directory to search
+    -> IO (Maybe FilePath)      -- ^/dir/@\/@/pkgname/@.buildinfo@, if present
+findHookedPackageDesc dir = do
+    files <- getDirectoryContents dir
+    buildInfoFiles <- filterM doesFileExist
+                        [ dir </> file
+                        | file <- files
+                        , let (name, ext) = splitExtension file
+                        , not (null name) && ext == buildInfoExt ]
+    case buildInfoFiles of
+        [] -> return Nothing
+        [f] -> return (Just f)
+        _ -> die ("Multiple files with extension " ++ buildInfoExt)
+
+buildInfoExt  :: String
+buildInfoExt = ".buildinfo"
+
+-- ------------------------------------------------------------
+-- * Unicode stuff
+-- ------------------------------------------------------------
+
+-- This is a modification of the UTF8 code from gtk2hs and the
+-- utf8-string package.
+
+fromUTF8 :: String -> String
+fromUTF8 []     = []
+fromUTF8 (c:cs)
+  | c <= '\x7F' = c : fromUTF8 cs
+  | c <= '\xBF' = replacementChar : fromUTF8 cs
+  | c <= '\xDF' = twoBytes c cs
+  | c <= '\xEF' = moreBytes 3 0x800     cs (ord c .&. 0xF)
+  | c <= '\xF7' = moreBytes 4 0x10000   cs (ord c .&. 0x7)
+  | c <= '\xFB' = moreBytes 5 0x200000  cs (ord c .&. 0x3)
+  | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)
+  | otherwise   = replacementChar : fromUTF8 cs
+  where
+    twoBytes c0 (c1:cs')
+      | ord c1 .&. 0xC0 == 0x80
+      = let d = ((ord c0 .&. 0x1F) `shiftL` 6)
+             .|. (ord c1 .&. 0x3F)
+         in if d >= 0x80
+               then  chr d           : fromUTF8 cs'
+               else  replacementChar : fromUTF8 cs'
+    twoBytes _ cs' = replacementChar : fromUTF8 cs'
+
+    moreBytes :: Int -> Int -> [Char] -> Int -> [Char]
+    moreBytes 1 overlong cs' acc
+      | overlong <= acc && acc <= 0x10FFFF
+     && (acc < 0xD800 || 0xDFFF < acc)
+     && (acc < 0xFFFE || 0xFFFF < acc)
+      = chr acc : fromUTF8 cs'
+
+      | otherwise
+      = replacementChar : fromUTF8 cs'
+
+    moreBytes byteCount overlong (cn:cs') acc
+      | ord cn .&. 0xC0 == 0x80
+      = moreBytes (byteCount-1) overlong cs'
+          ((acc `shiftL` 6) .|. ord cn .&. 0x3F)
+
+    moreBytes _ _ cs' _
+      = replacementChar : fromUTF8 cs'
+
+    replacementChar = '\xfffd'
+
+toUTF8 :: String -> String
+toUTF8 []        = []
+toUTF8 (c:cs)
+  | c <= '\x07F' = c
+                 : toUTF8 cs
+  | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))
+                 : chr (0x80 .|. (w .&. 0x3F))
+                 : toUTF8 cs
+  | c <= '\xFFFF'= chr (0xE0 .|.  (w `shiftR` 12))
+                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))
+                 : chr (0x80 .|.  (w .&. 0x3F))
+                 : toUTF8 cs
+  | otherwise    = chr (0xf0 .|.  (w `shiftR` 18))
+                 : chr (0x80 .|. ((w `shiftR` 12)  .&. 0x3F))
+                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))
+                 : chr (0x80 .|.  (w .&. 0x3F))
+                 : toUTF8 cs
+  where w = ord c
+
+-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input
+--
+ignoreBOM :: String -> String
+ignoreBOM ('\xFEFF':string) = string
+ignoreBOM string            = string
+
+-- | Reads a UTF8 encoded text file as a Unicode String
+--
+-- Reads lazily using ordinary 'readFile'.
+--
+readUTF8File :: FilePath -> IO String
+readUTF8File f = fmap (ignoreBOM . fromUTF8)
+               . hGetContents =<< openBinaryFile f ReadMode
+
+-- | Reads a UTF8 encoded text file as a Unicode String
+--
+-- Same behaviour as 'withFileContents'.
+--
+withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
+withUTF8FileContents name action =
+  Exception.bracket
+    (openBinaryFile name ReadMode)
+    hClose
+    (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8)
+
+-- | Writes a Unicode String as a UTF8 encoded text file.
+--
+-- Uses 'writeFileAtomic', so provides the same guarantees.
+--
+writeUTF8File :: FilePath -> String -> IO ()
+writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8
+
+-- | Fix different systems silly line ending conventions
+normaliseLineEndings :: String -> String
+normaliseLineEndings [] = []
+normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows
+normaliseLineEndings ('\r':s)      = '\n' : normaliseLineEndings s -- old osx
+normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s
+
+-- ------------------------------------------------------------
+-- * Common utils
+-- ------------------------------------------------------------
+
+equating :: Eq a => (b -> a) -> b -> b -> Bool
+equating p x y = p x == p y
+
+comparing :: Ord a => (b -> a) -> b -> b -> Ordering
+comparing p x y = p x `compare` p y
+
+isInfixOf :: String -> String -> Bool
+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+
+lowercase :: String -> String
+lowercase = map Char.toLower
+
diff --git a/tests/examples/ghc88/hie010.hs b/tests/examples/ghc88/hie010.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc88/hie010.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+module MoreExplicitForalls where
+
+import Data.Proxy
+
+data family F1 a
+data instance forall (x :: Bool). F1 (Proxy x) = MkF
+
+class C a where
+  type F2 a b
+
+instance forall a. C [a] where
+  type forall b. F2 [a] b = Int
+
+
+type family G a b where
+  forall x y. G [x] (Proxy y) = Double
+  forall z.   G z   z         = Bool
+