ghc-exactprint 0.6.2 → 0.6.3

raw patch · 27 files changed

+3630/−169 lines, 27 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog +2/−0
• ghc-exactprint.cabal +60/−33
• src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs +2952/−0
• src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs +3/−4
• src/Language/Haskell/GHC/ExactPrint/Delta.hs +1/−1
• src/Language/Haskell/GHC/ExactPrint/Parsers.hs +61/−19
• src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +36/−3
• src/Language/Haskell/GHC/ExactPrint/Pretty.hs +1/−1
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +21/−7
• src/Language/Haskell/GHC/ExactPrint/Types.hs +16/−0
• tests/PrepareHackage.hs +11/−11
• tests/Roundtrip.hs +1/−1
• tests/Test.hs +19/−47
• tests/Test/Common.hs +20/−8
• tests/Test/NoAnnotations.hs +12/−4
• tests/Test/Transform.hs +22/−20
• tests/examples/ghc810/T16326_Compile1.hs +43/−0
• tests/examples/ghc810/T17296.hs +38/−0
• tests/examples/ghc810/T3391.hs +15/−0
• tests/examples/ghc810/TH_scope.hs +10/−0
• tests/examples/ghc810/TH_unresolvedInfix.hs +137/−0
• tests/examples/ghc810/TH_unresolvedInfix_Lib.hs +94/−0
• tests/examples/ghc810/mod181.hs +9/−0
• tests/examples/ghc810/saks029.hs +14/−0
• tests/examples/ghc810/saks032.hs +22/−0
• tests/examples/ghc84/arrowfail003.hs +0/−10
• tests/examples/pre-ghc810/arrowfail003.hs +10/−0

@@ -1,3 +1,5 @@+2020-03-26 v0.6.3+        * Support GHC 8.8.1, 8.8.2, 8.8.3, 8.10.1 2019-08-28 v0.6.2         * Support GHC 8.8.1 (release candidate) 2019-05-27 v0.6.1

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             0.6.2+version:             0.6.3 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@@ -40,16 +40,22 @@                    , GHC == 8.6.2                    , GHC == 8.6.4                    , GHC == 8.6.5+                   , GHC == 8.8.1+                   , GHC == 8.8.2+                   , GHC == 8.8.3+                   , GHC == 8.10.1 extra-source-files:  ChangeLog                      src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs                      tests/examples/failing/*.hs-                     tests/examples/ghc710/*.hs                      tests/examples/ghc710-only/*.hs+                     tests/examples/ghc710/*.hs                      tests/examples/ghc80/*.hs+                     tests/examples/ghc810/*.hs                      tests/examples/ghc82/*.hs                      tests/examples/ghc84/*.hs                      tests/examples/ghc86/*.hs                      tests/examples/ghc88/*.hs+                     tests/examples/pre-ghc810/*.hs                      tests/examples/pre-ghc86/*.hs                      tests/examples/vect/*.hs                      tests/examples/transform/*.hs@@ -93,8 +99,12 @@    -- other-modules:   -- other-extensions:-  GHC-Options:         -Wall-  build-depends:       base >=4.8 && <4.14+  if impl (ghc >= 8.0.1)+    GHC-Options:         -Wall -Wredundant-constraints+  else+    GHC-Options:         -Wall+  -- GHC-Options:         -Weverything+  build-depends:       base >=4.8 && <4.16                      , bytestring >= 0.10.6                      , containers >= 0.5                      , directory >= 1.2@@ -113,22 +123,25 @@       build-depends: ghc-boot   hs-source-dirs:      src -  if impl (ghc > 8.6.5)-      hs-source-dirs: src-ghc88+  if impl (ghc > 8.8.3)+      hs-source-dirs: src-ghc810   else-    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)@@ -142,34 +155,41 @@   else     hs-source-dirs:      tests -  if impl (ghc > 8.6.5)-      hs-source-dirs: src-ghc88+  if impl (ghc > 8.8.3)+      hs-source-dirs: src-ghc810   else-    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+                     , Test.CommonUtils                      , Test.Consistency                      , Test.NoAnnotations                      , Test.Transform-  GHC-Options:         -threaded -Wall+  if impl (ghc >= 8.0.1)+    GHC-Options:         -threaded -Wall -Wredundant-constraints+  else+    GHC-Options:         -threaded -Wall   Default-language:    Haskell2010   if impl (ghc < 7.10.2)       buildable: False   Build-depends:       HUnit >= 1.2-                     , base < 4.14+                     , base < 4.16                      , bytestring                      , containers >= 0.5                      , Diff@@ -219,8 +239,10 @@     buildable: True   else     buildable: False-  ghc-options:-    -threaded -Wall+  if impl (ghc >= 8.0.1)+    GHC-Options:         -threaded -Wall -Wredundant-constraints+  else+    GHC-Options:         -threaded -Wall  executable static   main-is: Static.hs@@ -238,8 +260,10 @@         build-depends: ghc-boot   else     buildable: False-  ghc-options:-    -threaded -Wall+  if impl (ghc >= 8.0.1)+    GHC-Options:         -threaded -Wall -Wredundant-constraints+  else+    GHC-Options:         -threaded -Wall  executable prepare-hackage   main-is: PrepareHackage.hs@@ -261,4 +285,7 @@         build-depends: ghc-boot   else     buildable: False-  GHC-Options:         -threaded+  if impl (ghc >= 8.0.1)+    GHC-Options:         -threaded -Wall -Wredundant-constraints+  else+    GHC-Options:         -threaded -Wall

@@ -0,0 +1,2952 @@+{-# 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)+   case qualFlag of+     GHC.QualifiedPre  -- 'qualified' appears in prepositive position.+       -> (unsetContext TopLevel $ mark GHC.AnnQualified)+     _ -> return ()+   case mpkg of+    Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) ->+      markWithString GHC.AnnPackageName srcPkg+    _ -> return ()++   markLocated modname++   case qualFlag of+     GHC.QualifiedPost -- 'qualified' appears in postpositive position.+       -> (unsetContext TopLevel $ mark GHC.AnnQualified)+     _ -> return ()++   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.KindSigD _ 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)+markFamEqn :: GHC.FamEqn 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.NoExtField nd (GHC.noLoc []) typ _mk cons mderivs)+    markOptional GHC.AnnWhere+    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"++-- ---------------------------------------------------------------------++instance Annotate (GHC.StandaloneKindSig GHC.GhcPs) where++  markAST _ (GHC.StandaloneKindSig _ ln st)  = do+    mark GHC.AnnType+    setContext (Set.singleton PrefixOp) $ markLocated ln+    mark GHC.AnnDcolon+    markLHsSigType st+    markTrailingSemi+    tellContext (Set.singleton FollowingLine)++  markAST _ (GHC.XStandaloneKindSig _)+    = error "hit extension for StandaloneKindSig"++-- --------------------------------------------------------------------++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 _ fvf tvs typ) = do+      mark GHC.AnnForall+      mapM_ markLocated tvs+      case fvf of+        GHC.ForallInvis -> mark GHC.AnnDot+        GHC.ForallVis   -> mark GHC.AnnRarrow+      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.HsUnboundVar {}) = do+        ifInContext (Set.fromList [InfixOp])+          (do  mark GHC.AnnBackquote+               markWithString GHC.AnnVal "_"+               mark GHC.AnnBackquote)+          (markExternal l GHC.AnnVal "_")++      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 _ (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.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)+            => 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, Annotate ast,GHC.HasSrcSpan ast)+            => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity+            -> GHC.Located a -> [ast] -> Annotated ()+markTyClass = markTyClassWorker markLocated++markTyClassWorker :: (Annotate 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++  -- 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.Located (GHC.Pat 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.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

@@ -819,8 +819,7 @@  -- --------------------------------------------------------------------- -markFamEqn :: (GHC.HasOccName (GHC.IdP pass),-               Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)+markFamEqn :: (Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)            => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2)                     -> Annotated () markFamEqn (GHC.FamEqn _ ln pats fixity rhs) = do@@ -2398,10 +2397,10 @@     = error "extension hit for TyClDecl"   markAST _ (GHC.XTyClDecl _)     = error "extension hit for TyClDecl"-  + -- --------------------------------------------------------------------- -markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)+markTyClass :: (Annotate a, Annotate ast)                 => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass fixity ln tyVars = do     -- There may be arbitrary parens around parts of the constructor

@@ -449,7 +449,7 @@ getSrcSpan = asks curSrcSpan  #if __GLASGOW_HASKELL__ > 806-withSrcSpanDelta :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b+withSrcSpanDelta :: (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

@@ -12,6 +12,7 @@ module Language.Haskell.GHC.ExactPrint.Parsers (         -- * Utility           Parser+        , ParseResult         , withDynFlags         , CppOptions(..)         , defaultCppOptions@@ -58,13 +59,21 @@  import qualified ApiAnnotation as GHC import qualified DynFlags      as GHC+#if __GLASGOW_HASKELL__ > 808+import qualified ErrUtils      as GHC+#endif import qualified FastString    as GHC import qualified GHC           as GHC hiding (parseModule) import qualified HeaderInfo    as GHC import qualified Lexer         as GHC import qualified MonadUtils    as GHC+#if __GLASGOW_HASKELL__ <= 808 import qualified Outputable    as GHC+#endif import qualified Parser        as GHC+#if __GLASGOW_HASKELL__ > 808+import qualified RdrHsSyn      as GHC+#endif import qualified SrcLoc        as GHC import qualified StringBuffer  as GHC @@ -89,18 +98,20 @@           -> FilePath           -> GHC.P w           -> String-          -> Either (GHC.SrcSpan, String) (Anns, w)+          -> ParseResult w #else parseWith :: Annotate w           => GHC.DynFlags           -> FilePath           -> GHC.P (GHC.Located w)           -> String-          -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)+          -> ParseResult (GHC.Located w) #endif parseWith dflags fileName parser s =   case runParser parser dflags fileName s of-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 808+    GHC.PFailed pst                       -> Left (GHC.getErrorMessages pst dflags)+#elif __GLASGOW_HASKELL__ >= 804     GHC.PFailed _ ss m                    -> Left (ss, GHC.showSDoc dflags m) #else     GHC.PFailed ss m                    -> Left (ss, GHC.showSDoc dflags m)@@ -108,6 +119,22 @@     GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod)       where as = relativiseApiAnns pmod apianns ++#if __GLASGOW_HASKELL__ > 808+parseWithECP :: (GHC.DisambECP w, Annotate (GHC.Body w GHC.GhcPs))+          => GHC.DynFlags+          -> FilePath+          -> GHC.P GHC.ECP+          -> String+          -> ParseResult (GHC.Located w)+parseWithECP dflags fileName parser s =+    -- case runParser ff dflags fileName s of+    case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of+      GHC.PFailed pst                      -> Left (GHC.getErrorMessages pst dflags)+      GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod)+        where as = relativiseApiAnns pmod apianns+#endif+ -- ---------------------------------------------------------------------  runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a@@ -138,12 +165,21 @@  -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 808+type ParseResult a = Either GHC.ErrorMessages (Anns, a)+#else+type ParseResult a = Either (GHC.SrcSpan, String) (Anns, a)+#endif+ type Parser a = GHC.DynFlags -> FilePath -> String-                -> Either (GHC.SrcSpan, String)-                          (Anns, a)+                -> ParseResult a  parseExpr :: Parser (GHC.LHsExpr GhcPs)+#if __GLASGOW_HASKELL__ > 808+parseExpr df fp = parseWithECP df fp GHC.parseExpression+#else parseExpr df fp = parseWith df fp GHC.parseExpression+#endif  parseImport :: Parser (GHC.LImportDecl GhcPs) parseImport df fp = parseWith df fp GHC.parseImport@@ -176,8 +212,7 @@ -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs')-parseModule-  :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))+parseModule :: FilePath -> IO (ParseResult GHC.ParsedSource) parseModule = parseModuleWithCpp defaultCppOptions normalLayout  @@ -189,32 +224,29 @@ parseModuleFromString   :: FilePath   -> String-  -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))+  -> IO (ParseResult GHC.ParsedSource) parseModuleFromString fp s = ghcWrapper $ do   dflags <- initDynFlagsPure fp s   return $ parseModuleFromStringInternal dflags fp s  -- | Internal part of 'parseModuleFromString'.-parseModuleFromStringInternal-  :: GHC.DynFlags-  -> FilePath-  -> String-  -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)+parseModuleFromStringInternal :: Parser GHC.ParsedSource parseModuleFromStringInternal dflags fileName str =   let (str1, lp) = stripLinePragmas str       res        = case runParser GHC.parseModule dflags fileName str1 of-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 808+        GHC.PFailed pst     -> Left (GHC.getErrorMessages pst dflags)+#elif __GLASGOW_HASKELL__ >= 804         GHC.PFailed _ ss m  -> Left (ss, GHC.showSDoc dflags m) #else         GHC.PFailed ss m    -> Left (ss, GHC.showSDoc dflags m) #endif-        GHC.POk     x  pmod -> Right $ (mkApiAnns x, lp, dflags, pmod)+        GHC.POk     x  pmod -> Right (mkApiAnns x, lp, dflags, pmod)   in  postParseTransform res normalLayout  parseModuleWithOptions :: DeltaOptions                        -> FilePath-                       -> IO (Either (GHC.SrcSpan, String)-                                     (Anns, GHC.ParsedSource))+                       -> IO (ParseResult GHC.ParsedSource) parseModuleWithOptions opts fp =   parseModuleWithCpp defaultCppOptions opts fp @@ -224,7 +256,7 @@   :: CppOptions   -> DeltaOptions   -> FilePath-  -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))+  -> IO (ParseResult GHC.ParsedSource) parseModuleWithCpp cpp opts fp = do   res <- parseModuleApiAnnsWithCpp cpp fp   return $ postParseTransform res opts@@ -239,7 +271,11 @@   -> FilePath   -> IO        ( Either+#if __GLASGOW_HASKELL__ > 808+           GHC.ErrorMessages+#else            (GHC.SrcSpan, String)+#endif            (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)        ) parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do@@ -261,7 +297,11 @@   -> FilePath   -> m        ( Either+#if __GLASGOW_HASKELL__ > 808+           GHC.ErrorMessages+#else            (GHC.SrcSpan, String)+#endif            (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)        ) parseModuleApiAnnsWithCppInternal cppOptions dflags file = do@@ -282,7 +322,9 @@         return (contents1,lp,dflags)   return $     case parseFile dflags' file fileContents of-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 808+      GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags)+#elif __GLASGOW_HASKELL__ >= 804       GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m)) #else       GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m))

@@ -26,11 +26,18 @@ import qualified MonadUtils     as GHC import qualified SrcLoc         as GHC import qualified StringBuffer   as GHC+#if __GLASGOW_HASKELL__ > 808+import qualified Fingerprint    as GHC+import qualified ToolSettings   as GHC+#endif  import SrcLoc (mkSrcSpan, mkSrcLoc) import FastString (mkFastString) +#if __GLASGOW_HASKELL__ > 808+#else import Control.Exception+#endif import Data.List hiding (find) import Data.Maybe #if __GLASGOW_HASKELL__ <= 800@@ -121,7 +128,9 @@ #else                          $  map (tokComment . commentToAnnotation . fst) cppCommentToks #endif-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 808+        GHC.PFailed pst -> parseError flags2 pst+#elif __GLASGOW_HASKELL__ >= 804         GHC.PFailed _ sspan err -> parseError flags2 sspan err #else         GHC.PFailed sspan err -> parseError flags2 sspan err@@ -180,7 +189,9 @@   let src = stripPreprocessorDirectives buf   case GHC.lexTokenStream src startLoc flags of     GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 808+    GHC.PFailed pst -> parseError flags pst+#elif __GLASGOW_HASKELL__ >= 804     GHC.PFailed _ sspan err -> parseError flags sspan err #else     GHC.PFailed sspan err -> parseError flags sspan err@@ -249,12 +260,25 @@     mkInclude = ("-include" ++)  +#if __GLASGOW_HASKELL__ > 808 addOptP :: String -> GHC.DynFlags -> GHC.DynFlags+addOptP   f = alterToolSettings $ \s -> s+          { GHC.toolSettings_opt_P   = f : GHC.toolSettings_opt_P s+          , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s)+          }+alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags+alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) }++fingerprintStrings :: [String] -> GHC.Fingerprint+fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss++#else+addOptP :: String -> GHC.DynFlags -> GHC.DynFlags addOptP   f = alterSettings (\s -> s { GHC.sOpt_P   = f : GHC.sOpt_P s})  alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) }-+#endif -- ---------------------------------------------------------------------  -- | Get the preprocessor directives as comment tokens from the@@ -276,9 +300,18 @@  -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 808+parseError :: (GHC.MonadIO m) => GHC.DynFlags -> GHC.PState -> m b+parseError dflags pst = do+     let+       -- (warns,errs) = GHC.getMessages pst dflags+     -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)+     GHC.throwErrors (GHC.getErrorMessages pst dflags)+#else parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b parseError dflags sspan err = do      throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)+#endif  -- --------------------------------------------------------------------- 

@@ -314,7 +314,7 @@ -- ---------------------------------------------------------------------  #if __GLASGOW_HASKELL__ > 806-withSrcSpanPretty :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b+withSrcSpanPretty :: (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

@@ -281,7 +281,9 @@  -- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl' wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808+wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.NoExtField s)+#elif __GLASGOW_HASKELL__ > 804 wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s) #else wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)@@ -291,7 +293,9 @@  -- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl' wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808+wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.NoExtField s)+#elif __GLASGOW_HASKELL__ > 804 wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s) #else wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)@@ -543,8 +547,10 @@ -- 'GHC.FunBind', these need to be pushed down from the top level to the last -- 'GHC.Match' if that 'GHC.Match' needs to be manipulated. balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m ()-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808 balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do+#elif __GLASGOW_HASKELL__ > 804+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do #elif __GLASGOW_HASKELL__ > 710 balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do #else@@ -1145,8 +1151,10 @@     -- ---------------------------------      lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808     lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do+#elif __GLASGOW_HASKELL__ > 804+    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do #elif __GLASGOW_HASKELL__ > 710     lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do #else@@ -1230,7 +1238,9 @@                      => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]                      -> TransformT m (GHC.HsLocalBinds GhcPs) replaceDeclsValbinds _ [] = do-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808+  return (GHC.EmptyLocalBinds GHC.NoExtField)+#elif __GLASGOW_HASKELL__ > 804   return (GHC.EmptyLocalBinds GHC.noExt) #else   return (GHC.EmptyLocalBinds)@@ -1244,7 +1254,9 @@         logTr "replaceDecls HsLocalBinds"         let decs = GHC.listToBag $ concatMap decl2Bind new         let sigs = concatMap decl2Sig new-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808+        return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs))+#elif __GLASGOW_HASKELL__ > 804         return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) #else         return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))@@ -1261,7 +1273,9 @@             newSigs  = map decl2Sig  new         let decs = GHC.listToBag $ concat newBinds         let sigs = concat newSigs-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 808+        return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs))+#elif __GLASGOW_HASKELL__ > 804         return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) #else         return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))

@@ -43,6 +43,10 @@   , GhcRn   , GhcTc +#if __GLASGOW_HASKELL__ > 804+  , noExt+#endif+   -- * Internal Types   , LayoutStartCol(..)   , declFun@@ -190,6 +194,15 @@ type GhcTc = GHC.GhcTc #endif ++#if __GLASGOW_HASKELL__ > 808+noExt :: GHC.NoExtField+noExt = GHC.NoExtField+#elif __GLASGOW_HASKELL__ > 804+noExt :: GHC.NoExt+noExt = GHC.noExt+#endif+ -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. #if __GLASGOW_HASKELL__ > 806 mkAnnKey :: (Constraints a) => a -> AnnKey@@ -390,6 +403,9 @@       GHC.DerivD _ d      -> f (GHC.L l d)       GHC.ValD _ d        -> f (GHC.L l d)       GHC.SigD _ d        -> f (GHC.L l d)+#if __GLASGOW_HASKELL__ > 808+      GHC.KindSigD _ d    -> f (GHC.L l d)+#endif       GHC.DefD _ d        -> f (GHC.L l d)       GHC.ForD _ d        -> f (GHC.L l d)       GHC.WarningD _ d    -> f (GHC.L l d)

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  --  import Data.Char-import Data.Monoid+-- import Data.Monoid import System.Directory import System.FilePath.Posix-import System.IO+-- import System.IO import Test.CommonUtils import Turtle hiding (FilePath,(<.>)) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified GHC.IO.Handle.Text as GHC+-- import qualified GHC.IO.Handle.Text as GHC  import Test.HUnit @@ -75,15 +75,15 @@ -- --------------------------------------------------------------------- -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@.-writeFileUtf8 :: FilePath -> String -> IO ()-writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt)+-- writeFileUtf8 :: FilePath -> String -> IO ()+-- writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt)  -- --------------------------------------------------------------------- -allCabalPackagesTest :: IO [Text]-allCabalPackagesTest-  = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"]-  -- = return ["airship"]+-- allCabalPackagesTest :: IO [Text]+-- allCabalPackagesTest+--   = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"]+--   -- = return ["airship"]   allCabalPackages :: IO [Text]@@ -107,8 +107,8 @@ tabWidth :: Int tabWidth = 8 -nonBreakingSpace :: Char-nonBreakingSpace = '\xa0'+-- nonBreakingSpace :: Char+-- nonBreakingSpace = '\xa0'  cleanupOneLine :: String -> String cleanupOneLine str = str'

@@ -143,7 +143,7 @@                    writeError fp                    throwIO e                  case r1 of-                   Left (ParseFailure _ s) -> do+                   Left (ParseFailure s) -> do                      writeParseFail fp s                      exitFailure                    Right r -> do

@@ -28,12 +28,14 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810      deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion ghcVersion =-#if __GLASGOW_HASKELL__ > 806+#if __GLASGOW_HASKELL__ > 808+  GHC810+#elif __GLASGOW_HASKELL__ > 806   GHC88 #elif __GLASGOW_HASKELL__ > 804   GHC86@@ -54,12 +56,13 @@     GHC710 -> ["ghc710-only","ghc710", "vect"]     GHC80  -> [              "ghc710", "ghc80", "vect"]     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" ]+    GHC84  -> ["pre-ghc86", "pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ]+    GHC86  -> ["pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ]+    GHC88  -> ["pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ]+    GHC810 -> [              "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810" ] -    -- GHC88  -> ["ghc88"]-    -- GHC88  -> ["ghc88-copied"]+    -- GHC810  -> ["ghc810"]+    -- GHC810  -> ["ghc810-copied"]  -- --------------------------------------------------------------------- @@ -199,48 +202,17 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ --      -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"-      -- mkPrettyRoundtrip "ghc86" "mdo.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"+      -- mkParserTest      "ghc80" "C.hs"+    --   mkParserTest      "ghc80" "T10267.hs"+    -- , mkParserTest      "ghc80" "T10946.hs"+      -- mkParserTest      "ghc82" "T13050.hs"+      -- mkParserTest      "ghc84" "arrowfail003.hs"+      -- mkParserTest      "ghc810" "T17296.hs" -    --   mkPrettyRoundtrip "ghc86" "BinDU.hs"-    -- , mkPrettyRoundtrip "ghc86" "Dial.hs"+      mkPrettyRoundtrip "ghc810" "T16326_Compile1.hs"+      -- mkPrettyRoundtrip "ghc810" "saks029.hs" -      -- mkParserTest      "ghc84" "Types.hs"-    -- , mkPrettyRoundtrip "ghc80" "export-type.hs"+      -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"     -- Needs GHC changes         -- mkParserTest "failing" "CtorOp.hs"

@@ -21,6 +21,9 @@               , genTest               , noChange               , mkDebugOutput+#if __GLASGOW_HASKELL__ > 808+              , showErrorMessages+#endif               ) where  @@ -34,13 +37,12 @@  import qualified ApiAnnotation as GHC import qualified DynFlags      as GHC--- import qualified FastString    as GHC+#if __GLASGOW_HASKELL__ > 808+import qualified Bag           as GHC+import qualified ErrUtils      as GHC+#endif import qualified GHC           as GHC hiding (parseModule)--- import qualified Lexer         as GHC import qualified MonadUtils    as GHC--- import qualified Parser        as GHC--- import qualified SrcLoc        as GHC--- import qualified StringBuffer  as GHC  #if __GLASGOW_HASKELL__ <= 710 #else@@ -79,7 +81,7 @@    , inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))]    } -data ParseFailure = ParseFailure GHC.SrcSpan String+data ParseFailure = ParseFailure String  data ReportType =    Success@@ -115,7 +117,7 @@       writeHsPP      = writeFile (basename <.> "hspp")       writeIncons s  = writeFile (basename <.> "incons") (showGhc s)   in-    TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id+    TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id                         <$> tester basename                  writeFailure (debugTxt r)                  forM_ (inconsistent r) writeIncons@@ -137,7 +139,11 @@       let pristine = expected        case res of-        Left (ss, m) -> return . Left $ ParseFailure ss m+#if __GLASGOW_HASKELL__ > 808+        Left m -> return . Left $ ParseFailure (showErrorMessages m)+#else+        Left (_ss, m) -> return . Left $ ParseFailure m+#endif         Right (apianns, injectedComments, dflags, pmod)  -> do           (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments) #if __GLASGOW_HASKELL__ <= 710@@ -221,3 +227,9 @@    [] -> return Nothing    fs -> return (Just (snd $ head fs)) +-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 808+showErrorMessages :: GHC.ErrorMessages -> String+showErrorMessages m = show $ GHC.bagToList m+#endif

@@ -82,11 +82,19 @@ prettyRoundtripTest origFile = do       res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile       case res of-        Left (ss, m) -> return . Left $ ParseFailure ss m+#if __GLASGOW_HASKELL__ > 808+        Left m -> return . Left $ ParseFailure (showErrorMessages m)+#else+        Left (_ss, m) -> return . Left $ ParseFailure m+#endif         Right (apianns, injectedComments, _dflags, parsed)  -> do           res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments)           case res2 of-            Left (ss, m) -> return . Left $ ParseFailure ss m+#if __GLASGOW_HASKELL__ > 808+            Left m -> return . Left $ ParseFailure (showErrorMessages m)+#else+            Left (_ss, m) -> return . Left $ ParseFailure m+#endif             Right (_anns', parsed') -> do               let                 originalStructure  = astStructure parsed []@@ -110,7 +118,7 @@  runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource                    -> [Comment]-                   -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))+                   -> IO (ParseResult GHC.ParsedSource) runPrettyRoundTrip origFile !anns !parsedOrig _cs = do   let !newAnns = addAnnotationsForPretty [] parsedOrig mempty   let comments = case Map.lookup GHC.noSrcSpan (snd anns) of@@ -126,7 +134,7 @@   parseString :: FilePath -> String -> Anns -> GHC.ParsedSource-            -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))+            -> IO (ParseResult GHC.ParsedSource) parseString origFile src newAnns origParsed = do   tmpDir <- getTemporaryDirectory   let workDir = tmpDir </> "ghc-exactprint" </> "noannotations"

@@ -72,7 +72,7 @@       expected       = basename <.> suffix       writeFailure   = writeFile (basename <.> "out")   in-    TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id+    TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id                         <$> genTest f basename expected                  writeFailure (debugTxt r)                  assertBool fp (status r == Success))@@ -141,7 +141,7 @@         -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)         modifyAnnsT (captureOrderAnnKey newAnnKey decls) #if __GLASGOW_HASKELL__ > 804-        let binds = (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt (GHC.listToBag $ [GHC.L ld decl])+        let binds = (GHC.HsValBinds noExt (GHC.ValBinds noExt (GHC.listToBag $ [GHC.L ld decl])                                     [GHC.L ls sig])) #else         let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])@@ -157,7 +157,7 @@         return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds)))) #else         bindSpan <- uniqueSrcSpanT-        return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L bindSpan binds))))+        return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L bindSpan binds)))) #endif       replaceLocalBinds x = return x   -- putStrLn $ "log:" ++ intercalate "\n" w@@ -205,8 +205,8 @@         -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)         modifyAnnsT (captureOrder m decls) #if __GLASGOW_HASKELL__ > 804-        let binds' = (GHC.HsValBinds GHC.noExt-                          (GHC.ValBinds GHC.noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)+        let binds' = (GHC.HsValBinds noExt+                          (GHC.ValBinds noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)                                           (GHC.L ls sig:sigs))) #else         let binds' = (GHC.HsValBinds@@ -220,7 +220,7 @@ #elif __GLASGOW_HASKELL__ <= 804         return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds')))) #else-        return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L lb binds'))))+        return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L lb binds')))) #endif       replaceLocalBinds x = return x   -- putStrLn $ "log:" ++ intercalate "\n" w@@ -326,7 +326,7 @@ #elif __GLASGOW_HASKELL__ <= 804         | cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName)) #else-        | cond ln = GHC.L ln (GHC.HsVar GHC.noExt (GHC.L ln newName))+        | cond ln = GHC.L ln (GHC.HsVar noExt (GHC.L ln newName)) #endif     replaceHsVar x = x @@ -335,11 +335,11 @@ #if __GLASGOW_HASKELL__ > 806     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs     replacePat (GHC.dL->GHC.L ln (GHC.VarPat {}))-        | cond ln = GHC.cL ln (GHC.VarPat GHC.noExt (GHC.cL ln newName))+        | cond ln = GHC.cL ln (GHC.VarPat noExt (GHC.cL ln newName)) #elif __GLASGOW_HASKELL__ > 804     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs     replacePat (GHC.L ln (GHC.VarPat {}))-        | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))+        | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName)) #elif __GLASGOW_HASKELL__ > 802     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs     replacePat (GHC.L ln (GHC.VarPat {}))@@ -364,7 +364,7 @@ -- #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))+--         | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName)) -- #endif --     replacePat x = x @@ -414,7 +414,7 @@ #elif __GLASGOW_HASKELL__ <= 804          in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) #else-         in (GHC.HsLet GHC.noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr)+         in (GHC.HsLet noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) #endif      replace x = x@@ -563,12 +563,14 @@         [d1,d2] <- hsDecls lp         balanceComments d1 d2 -#if __GLASGOW_HASKELL__ <= 710-        let GHC.L _ (GHC.ValD (GHC.FunBind  _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1-#elif __GLASGOW_HASKELL__ <= 804+#if __GLASGOW_HASKELL__ > 808+        let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1+#elif __GLASGOW_HASKELL__ > 804+        let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1+#elif __GLASGOW_HASKELL__ > 710         let GHC.L _ (GHC.ValD (GHC.FunBind  _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1 #else-        let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1+        let GHC.L _ (GHC.ValD (GHC.FunBind  _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1 #endif         balanceComments m1 m2 @@ -688,7 +690,7 @@ #elif __GLASGOW_HASKELL__ <= 804             return (GHC.HsLet (GHC.L l lb') expr) #else-            return (GHC.HsLet GHC.noExt (GHC.L l lb') expr)+            return (GHC.HsLet noExt (GHC.L l lb') expr) #endif           go x = return x @@ -790,8 +792,8 @@           n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))           n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) #if __GLASGOW_HASKELL__ > 804-          v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1)))-          v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2)))+          v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1)))+          v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) #elif __GLASGOW_HASKELL__ > 800           v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1)))           v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2)))@@ -824,8 +826,8 @@           n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))           n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) #if __GLASGOW_HASKELL__ > 804-          v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1)))-          v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2)))+          v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1)))+          v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) #elif __GLASGOW_HASKELL__ > 800           v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1)))           v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2)))

@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+module T16326_Compile1 where++import Data.Kind++type DApply a (b :: a -> Type) (f :: forall (x :: a) -> b x) (x :: a) =+  f x++type DComp a+           (b :: a -> Type)+           (c :: forall (x :: a). b x -> Type)+           (f :: forall (x :: a). forall (y :: b x) -> c y)+           (g :: forall (x :: a) -> b x)+           (x :: a) =+  f (g x)++-- Ensure that ElimList has a CUSK, beuas it is+-- is used polymorphically its RHS (c.f. #16344)+type family ElimList (a :: Type)+                     (p :: [a] -> Type)+                     (s :: [a])+                     (pNil :: p '[])+                     (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs))+                  :: p s where+  forall a p pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)).+    ElimList a p '[] pNil pCons =+      pNil+  forall a p x xs pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)).+    ElimList a p (x:xs) pNil pCons =+      pCons x xs (ElimList a p xs pNil pCons)++data Proxy' :: forall k -> k -> Type where+  MkProxy' :: forall k (a :: k). Proxy' k a++type family Proxy2' ∷ ∀ k → k → Type where+  Proxy2' = Proxy'+

@@ -0,0 +1,38 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module T17296 where++import Data.Foldable+import Data.Kind+import Language.Haskell.TH hiding (Type)+import System.IO++data family   Foo1 :: Type -> Type+data instance Foo1 Bool = Foo1Bool+data instance Foo1 (Maybe a)++data family   Foo2 :: k -> Type+data instance Foo2 Bool = Foo2Bool+data instance Foo2 (Maybe a)+data instance Foo2 :: Char -> Type+data instance Foo2 :: (Char -> Char) -> Type where++data family   Foo3 :: k+data instance Foo3+data instance Foo3 Bool = Foo3Bool+data instance Foo3 (Maybe a)+data instance Foo3 :: Char -> Type+data instance Foo3 :: (Char -> Char) -> Type where++$(do let test :: Name -> Q ()+         test n = do i <- reify n+                     runIO $ do hPutStrLn stderr $ pprint i+                                hPutStrLn stderr ""+                                hFlush stderr++     traverse_ test [''Foo1, ''Foo2, ''Foo3]+     pure [])+

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -v0 #-}++-- We should only generate one set of generic to/from functions+-- for T, despite the multiple chunks caused by the TH splices+-- See #3391++module T3391 where++data T = MkT++$(return [])++$(return [])+

@@ -0,0 +1,10 @@+-- Test for #2188+{-# LANGUAGE TemplateHaskellQuotes #-}++module TH_scope where++f g = [d| f :: Int+          f = g+          g :: Int+          g = 4 |]+

@@ -0,0 +1,137 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import TH_unresolvedInfix_Lib+import Language.Haskell.TH++--------------------------------------------------------------------------------+--                                Expressions                                 --+--------------------------------------------------------------------------------+exprs = [+-------------- Completely-unresolved bindings+  $( n +? (n *? n) ),+  $( (n +? n) *? n ),+  $( n +? (n +? n) ),+  $( (n +? n) +? n ),+  -- VarE version+  $( uInfixE n plus2 (uInfixE n plus2 n) ),+  $( uInfixE (uInfixE n plus2 n) plus2 n ),+  $( uInfixE n plus3 (uInfixE n plus3 n) ),+  $( uInfixE (uInfixE n plus3 n) plus3 n ),++--------------- Completely-resolved bindings+  $( n +! (n *! n) ),+  $( (n +! n) *! n ),+  $( n +! (n +! n) ),+  $( (n +! n) +! n ),++-------------- Mixed resolved/unresolved+  $( (n +! n) *? (n +? n) ),+  $( (n +? n) *? (n +! n) ),+  $( (n +? n) *! (n +! n) ),+  $( (n +? n) *! (n +? n) ),++-------------- Parens+  $( ((parensE ((n +? n) *? n)) +? n) *? n ),+  $( (parensE (n +? n)) *? (parensE (n +? n)) ),+  $( parensE ((n +? n) *? (n +? n)) ),++-------------- Sections+  $( infixE (Just $ n +? n) plus Nothing ) N,+  -- see B.hs for the (non-compiling) other version of the above+  $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N+  ]++--------------------------------------------------------------------------------+--                                  Patterns                                  --+--------------------------------------------------------------------------------+patterns = [+-------------- Completely-unresolved patterns+  case N :+ (N :* N) of+    [p1|unused|] -> True,+  case N :+ (N :* N) of+    [p2|unused|] -> True,+  case (N :+ N) :+ N of+    [p3|unused|] -> True,+  case (N :+ N) :+ N of+    [p4|unused|] -> True,+-------------- Completely-resolved patterns+  case N :+ (N :* N) of+    [p5|unused|] -> True,+  case (N :+ N) :* N of+    [p6|unused|] -> True,+  case N :+ (N :+ N) of+    [p7|unused|] -> True,+  case (N :+ N) :+ N of+    [p8|unused|] -> True,+-------------- Mixed resolved/unresolved+  case ((N :+ N) :* N) :+ N of+    [p9|unused|] -> True,+  case N :+ (N :* (N :+ N)) of+    [p10|unused|] -> True,+  case (N :+ N) :* (N :+ N) of+    [p11|unused|] -> True,+  case (N :+ N) :* (N :+ N) of+    [p12|unused|] -> True,+-------------- Parens+  case (N :+ (N :* N)) :+ (N :* N) of+    [p13|unused|] -> True,+  case (N :+ N) :* (N :+ N) of+    [p14|unused|] -> True,+  case (N :+ (N :* N)) :+ N of+    [p15|unused|] -> True+ ]++--------------------------------------------------------------------------------+--                                  Types                                     --+--------------------------------------------------------------------------------++-------------- Completely-unresolved types+_t1  = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) )+_t2  = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int )+_t3  = (1 `Plus` 1) `Plus` 1  :: $( int $+? (int $+? int) )+_t4  = (1 `Plus` 1) `Plus` 1  :: $( (int $+? int) $+? int )+-------------- Completely-resolved types+_t5  = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) )+_t6  = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int )+_t7  = 1 `Plus` (1 `Plus` 1)  :: $( int $+! (int $+! int) )+_t8  = (1 `Plus` 1) `Plus` 1  :: $( (int $+! int) $+! int )+-------------- Mixed resolved/unresolved+_t9  = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) )+_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) )+_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) )+_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) )+-------------- Parens+_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int )+_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1)             :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) )+_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1             :: $( parensT ((int $+? int) $*? (int $+? int)) )++main = do+  mapM_ print exprs+  mapM_ print patterns+  -- check that there are no Parens or UInfixes in the output+  runQ [|N :* N :+ N|] >>= print+  runQ [|(N :* N) :+ N|] >>= print+  runQ [p|N :* N :+ N|] >>= print+  runQ [p|(N :* N) :+ N|] >>= print+  runQ [t|Int * Int + Int|] >>= print+  runQ [t|(Int * Int) + Int|] >>= print++  -- pretty-printing of unresolved infix expressions+  let ne = ConE $ mkName "N"+      np = ConP (mkName "N") []+      nt = ConT (mkName "Int")+      plusE = ConE (mkName ":+")+      plusP = (mkName ":+")+      plusT = (mkName "+")+  putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne)))+  putStrLn $ pprint (ParensE ne)+  putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np)))+  putStrLn $ pprint (ParensP np)+  putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt)))+  putStrLn $ pprint (ParensT nt)+

@@ -0,0 +1,94 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++module TH_unresolvedInfix_Lib where++import Language.Haskell.TH+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote++infixl 6 :++infixl 7 :*++data Tree = N+  | Tree :+ Tree+  | Tree :* Tree++-- custom instance, including redundant parentheses+instance Show Tree where+  show N = "N"+  show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")"+  show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")"++-- VarE versions+infixl 6 +:+infixl 7 *:+(+:) = (:+)+(*:) = (:*)++n = conE (mkName "N")+plus = conE (mkName ":+")+times = conE (mkName ":*")++a +? b = uInfixE a plus b+a *? b = uInfixE a times b+a +! b = infixApp a plus b+a *! b = infixApp a times b++plus2 = varE (mkName "+:")+times2 = varE (mkName "*:")+plus3 = conE ('(:+))+++--------------------------------------------------------------------------------+--                                  Patterns                                  --+--------------------------------------------------------------------------------+-- The only way to test pattern splices is using QuasiQuotation+mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined+p = conP (mkName "N") []+plus' = mkName ":+"+times' = mkName ":*"++a ^+? b = uInfixP a plus' b+a ^*? b = uInfixP a times' b+a ^+! b = infixP a plus' b+a ^*! b = infixP a times' b++-------------- Completely-unresolved patterns+p1 = mkQQ ( p ^+? (p ^*? p) )+p2 = mkQQ ( (p ^+? p) ^*? p )+p3 = mkQQ ( p ^+? (p ^+? p) )+p4 = mkQQ ( (p ^+? p) ^+? p )+-------------- Completely-resolved patterns+p5 = mkQQ ( p ^+! (p ^*! p) )+p6 = mkQQ ( (p ^+! p) ^*! p )+p7 = mkQQ ( p ^+! (p ^+! p) )+p8 = mkQQ ( (p ^+! p) ^+! p )+-------------- Mixed resolved/unresolved+p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) )+p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) )+p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) )+p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) )+-------------- Parens+p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p )+p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )+p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )++--------------------------------------------------------------------------------+--                                  Types                                     --+--------------------------------------------------------------------------------++infixl 6 ++infixl 7 *+data (+) a b = Plus a b+data (*) a b = Times a b++int = conT (mkName "Int")+tyPlus = mkName "+"+tyTimes = mkName "*"++a $+? b = uInfixT a tyPlus b+a $*? b = uInfixT a tyTimes b+a $+! b = infixT a tyPlus b+a $*! b = infixT a tyTimes b+

@@ -0,0 +1,9 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- If 'ImportQualifiedPost' is enabled 'qualified' can appear in+-- postpositive position.++import Prelude qualified++main = Prelude.undefined+

@@ -0,0 +1,14 @@+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE PolyKinds, DataKinds, RankNTypes, TypeFamilies #-}++module SAKS_029 where++import Data.Kind+import Data.Proxy+import Data.Type.Bool++type IfK :: forall j m n. forall (e :: Proxy (j :: Bool)) -> m -> n -> If j m n+type family IfK e f g where+   IfK (_ :: Proxy True)  f _ = f+   IfK (_ :: Proxy False) _ g = g+

@@ -0,0 +1,22 @@+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, RankNTypes #-}++module SAKS_032 where++import Data.Kind+import Data.Proxy++type Const :: Type -> forall k. k -> Type+data Const a b = Const a++type F :: Type -> Type -> forall k. k -> Type+type family F a b :: forall k. k -> Type where+  F () () = Proxy+  F a b = Const (a,b)++type F1 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+type family F1 a b++type F2 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+type family F2 a b :: forall r2. (r1, r2) -> Type+

@@ -1,10 +0,0 @@-{-# LANGUAGE Arrows #-}--- Arrow commands where an expression is expected--module ShouldFail where--import Control.Arrow--foo = returnA -< []-bar = (|zeroArrow|)-

@@ -0,0 +1,10 @@+{-# LANGUAGE Arrows #-}+-- Arrow commands where an expression is expected++module ShouldFail where++import Control.Arrow++foo = returnA -< []+bar = (|zeroArrow|)+