ghc-exactprint 0.5.5.0 → 0.5.6.0

raw patch · 37 files changed

+4275/−220 lines, 37 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 +4/−0
• ghc-exactprint.cabal +21/−13
• src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs +1/−1
• src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs +1/−1
• src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs +2607/−0
• src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs +6/−12
• src/Language/Haskell/GHC/ExactPrint/Delta.hs +27/−8
• src/Language/Haskell/GHC/ExactPrint/Lookup.hs +3/−0
• src/Language/Haskell/GHC/ExactPrint/Parsers.hs +31/−9
• src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +8/−0
• src/Language/Haskell/GHC/ExactPrint/Pretty.hs +65/−46
• src/Language/Haskell/GHC/ExactPrint/Print.hs +9/−1
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +66/−46
• src/Language/Haskell/GHC/ExactPrint/Types.hs +31/−4
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +3/−3
• tests/Static.hs +1/−1
• tests/Test.hs +41/−10
• tests/Test/Common.hs +7/−2
• tests/Test/NoAnnotations.hs +8/−7
• tests/Test/Transform.hs +25/−12
• tests/examples/ghc82/Completesig03A.hs +6/−0
• tests/examples/ghc82/Lib.hs +17/−0
• tests/examples/ghc82/List2.hs +40/−0
• tests/examples/ghc82/Ppr048.hs +10/−0
• tests/examples/ghc82/T11727.hs +8/−0
• tests/examples/ghc82/T13050.hs +7/−0
• tests/examples/ghc82/T13594.hs +9/−0
• tests/examples/ghc82/TensorTests.hs +41/−0
• tests/examples/ghc82/brackets.hs +44/−0
• tests/examples/ghc82/completesig01.hs +21/−0
• tests/examples/ghc84/Functors.hs +530/−0
• tests/examples/ghc84/Main.hs +150/−0
• tests/examples/ghc84/T13747.hs +25/−0
• tests/examples/ghc84/Types.hs +392/−0
• tests/examples/ghc84/arrowfail003.hs +10/−0
• tests/examples/transform/Brittany1.hs +0/−22
• tests/examples/transform/Brittany1.hs.expected +0/−22

@@ -1,3 +1,7 @@+2018-00-27 v0.5.6.0+	* Support GHC 8.4 slpha2+	* Include test examples for GHC 8.2+	* Fix parseModuleFromString to correctly handle the sheband case (@lspitzner) 2017-07-23 v0.5.5.0 	* Support GHC 8.2.1 2017-05-17 v0.5.4.0

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             0.5.5.0+version:             0.5.6.0 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@@ -29,13 +29,15 @@ maintainer:          alan.zimm@gmail.com category:            Development build-type:          Simple-tested-with:    GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1+tested-with:    GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2 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/ghc80/*.hs+                     tests/examples/ghc82/*.hs+                     tests/examples/ghc84/*.hs                      tests/examples/transform/*.hs                      tests/examples/failing/*.hs.bad                      tests/examples/transform/*.hs.expected@@ -78,7 +80,7 @@   -- other-modules:   -- other-extensions:   GHC-Options:         -Wall-  build-depends:       base >=4.7 && <4.11+  build-depends:       base >=4.7 && <4.12                      , bytestring >= 0.10.6                      , containers >= 0.5                      , directory >= 1.2@@ -92,13 +94,16 @@       build-depends: ghc-boot   hs-source-dirs:      src -  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)@@ -112,13 +117,16 @@   else     hs-source-dirs:      tests -  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

@@ -2152,7 +2152,7 @@        markExpr _ (GHC.HsAppType e ty) = do         markLocated e-        mark GHC.AnnAt+        markInstead GHC.AnnAt AnnTypeApp         markLHsWcType ty       markExpr _ (GHC.HsAppTypeOut _ _) =         traceM "warning: HsAppTypeOut introduced after renaming"

@@ -2133,7 +2133,7 @@        markExpr _ (GHC.HsAppType e ty) = do         markLocated e-        mark GHC.AnnAt+        markInstead GHC.AnnAt AnnTypeApp         markLHsWcType ty       markExpr _ (GHC.HsAppTypeOut _ _) =         traceM "warning: HsAppTypeOut introduced after renaming"

@@ -0,0 +1,2607 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook+-- | '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 Name           as GHC+import qualified RdrName        as GHC+import qualified Outputable     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) => GHC.Located ast -> Annotated ()+annotate = markLocated++-- ---------------------------------------------------------------------++-- | Constructs a syntax tree which contains information about which+-- annotations are required by each element.+markLocated :: (Annotate ast) => GHC.Located 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 :: Annotate ast => Bool -> [GHC.Located 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 :: Annotate ast => [GHC.Located 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 ()+    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+      canParen = isSym+      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 canParen+              then ifInContext (Set.singleton PrefixOp)+                                       (mark         pa) -- '('+                                       (markOptional pa)+              else if isSym+                then ifInContext (Set.singleton PrefixOpDollar)+                       (mark pa)+                       (markOptional pa)+                else markOptional pa++        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+                        else markExternal l GHC.AnnVal 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+           markExternal l GHC.AnnVal str+         "★"  -> do -- Note: unicode star+           markExternal l GHC.AnnVal str+         ":"  -> do+           -- Note: The OccName for ":" has the following attributes (via occAttributes)+           -- (d, Data DataSym Sym Val )+           -- consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon+           doNormalRdrName+           -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName+         ('(':',':_) -> do+           mark GHC.AnnOpenP+           let cnt = length $ filter (==',') str+           replicateM_ cnt (mark GHC.AnnCommaTuple)+           mark GHC.AnnCloseP -- ')'+         _ -> do+            let isSym' = isSymRdr  (GHC.nameRdrName n')+            when isSym' $ mark GHC.AnnOpenP -- '('+            markWithString GHC.AnnVal str+            when isSym $ mark GHC.AnnCloseP -- ')'+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")++-- ---------------------------------------------------------------------++instance Annotate (GHC.ImportDecl GHC.GhcPs) where+ markAST _ imp@(GHC.ImportDecl msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do++   -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec+   mark GHC.AnnImport++   -- "{-# SOURCE" and "#-}"+   case msrc of+     GHC.SourceText _txt -> do+       markAnnOpen msrc "{-# SOURCE"+       markWithString GHC.AnnClose "#-}"+     GHC.NoSourceText -> return ()+   when safeflag (mark GHC.AnnSafe)+   when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)+   case mpkg of+    Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) ->+      markWithString GHC.AnnPackageName srcPkg+    _ -> return ()++   markLocated modname++   case GHC.ideclAs imp of+      Nothing -> return ()+      Just mn -> do+          mark GHC.AnnAs+          markLocated mn++   case hiding of+     Nothing -> return ()+     Just (isHiding,lie) -> do+       if isHiding+         then setContext (Set.singleton HasHiding) $+                markLocated lie+         else markLocated lie+   markTrailingSemi++-- ---------------------------------------------------------------------++instance Annotate GHC.ModuleName where+   markAST l mname =+    markExternal l GHC.AnnVal (GHC.moduleNameString mname)++-- ---------------------------------------------------------------------++markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated ()+markLHsDecl (GHC.L l decl) =+    case decl of+      GHC.TyClD d       -> markLocated (GHC.L l d)+      GHC.InstD d       -> markLocated (GHC.L l d)+      GHC.DerivD d      -> markLocated (GHC.L l d)+      GHC.ValD d        -> markLocated (GHC.L l d)+      GHC.SigD d        -> markLocated (GHC.L l d)+      GHC.DefD d        -> markLocated (GHC.L l d)+      GHC.ForD d        -> markLocated (GHC.L l d)+      GHC.WarningD d    -> markLocated (GHC.L l d)+      GHC.AnnD d        -> markLocated (GHC.L l d)+      GHC.RuleD d       -> markLocated (GHC.L l d)+      GHC.VectD 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)++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+    markLocated ln+    mapM_ markLocated mr++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++-- ---------------------------------------------------------------------++instance Annotate (GHC.VectDecl GHC.GhcPs) where+  markAST _ (GHC.HsVect src ln e) = do+    markAnnOpen src "{-# VECTORISE"+    markLocated ln+    mark GHC.AnnEqual+    markLocated e+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ (GHC.HsNoVect src ln) = do+    markAnnOpen src "{-# NOVECTORISE"+    markLocated ln+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ (GHC.HsVectTypeIn src _b ln mln) = do+    markAnnOpen src  "{-# VECTORISE"  -- or "{-# VECTORISE SCALAR"+    mark GHC.AnnType+    markLocated ln+    case mln of+      Nothing -> return ()+      Just lnn -> do+        mark GHC.AnnEqual+        markLocated lnn+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ GHC.HsVectTypeOut {} =+    traceM "warning: HsVectTypeOut appears after renaming"++  markAST _ (GHC.HsVectClassIn src ln) = do+    markAnnOpen src "{-# VECTORISE"+    mark GHC.AnnClass+    markLocated ln+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ GHC.HsVectClassOut {} =+    traceM "warning: HsVecClassOut appears after renaming"+  markAST _ GHC.HsVectInstIn {}   =+    traceM "warning: HsVecInstsIn appears after renaming"+  markAST _ GHC.HsVectInstOut {}   =+    traceM "warning: HsVecInstOut appears after renaming"++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++instance Annotate (GHC.RuleDecl GHC.GhcPs) where+  markAST l (GHC.HsRule ln act bndrs lhs _ rhs _) = do+    markLocated ln+    setContext (Set.singleton ExplicitNeverActive) $ markActivation l act++    unless (null bndrs) $ do+      mark GHC.AnnForall+      mapM_ markLocated bndrs+      mark GHC.AnnDot++    markLocated lhs+    mark GHC.AnnEqual+    markLocated rhs+    inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi+    markTrailingSemi++-- ---------------------------------------------------------------------++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 -- ")"++-- ---------------------------------------------------------------------++markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated ()+markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do+  markLocated ty++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++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 "#-}"++-- ---------------------------------------------------------------------++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 -- "]"++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+++-- ---------------------------------------------------------------------++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 typ ms mov) = do+    mark GHC.AnnDeriving+    markMaybe ms+    mark GHC.AnnInstance+    markMaybe mov+    markLHsSigType typ+    markTrailingSemi++-- ---------------------------------------------------------------------++instance Annotate GHC.DerivStrategy where++  markAST _ GHC.StockStrategy    = mark GHC.AnnStock+  markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass+  markAST _ GHC.NewtypeStrategy  = mark GHC.AnnNewtype++-- ---------------------------------------------------------------------++instance Annotate (GHC.DefaultDecl GHC.GhcPs) where++  markAST _ (GHC.DefaultDecl typs) = do+    mark GHC.AnnDefault+    mark GHC.AnnOpenP -- '('+    markListIntercalate typs+    mark GHC.AnnCloseP -- ')'+    markTrailingSemi++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where++  markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn _)) = do+    mark GHC.AnnType+    mark GHC.AnnInstance -- Note: this keyword is optional+    markFamEqn eqn+    markTrailingSemi++-- ---------------------------------------------------------------------++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 ln pats fixity rhs) = do+  markTyClass fixity ln pats+  mark GHC.AnnEqual+  markLocated rhs++-- ---------------------------------------------------------------------++instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where++  markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn ln 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++    markTyClass 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 mark GHC.AnnEqual+    markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs)+    markTrailingSemi++-- ---------------------------------------------------------------------++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)) _typ _fvs _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 _fvs 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+        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++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++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+    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++-- --------------------------------------------------------------------++markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated ()+markLHsSigType (GHC.HsIB _ typ _) = markLocated typ++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.+    case ls of+      []  -> markManyOptional GHC.AnnOpenP+      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnOpenP+      [_] -> markManyOptional GHC.AnnOpenP+      _   -> markMany         GHC.AnnOpenP+    markListIntercalateWithFun markLHsSigType ls+    case ls of+      []  -> markManyOptional GHC.AnnCloseP+      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnCloseP+      [_] -> markManyOptional GHC.AnnCloseP+      _   -> markMany         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 -- '('++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsType GHC.GhcPs) where+  markAST loc ty = do+    markType loc ty+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+   where++    -- markType :: GHC.SrcSpan -> ast -> Annotated ()+    markType _ (GHC.HsForAllTy tvs typ) = do+      mark GHC.AnnForall+      mapM_ markLocated tvs+      mark GHC.AnnDot+      markLocated typ++    markType _ (GHC.HsQualTy cxt typ) = do+      markLocated cxt+      markLocated typ++    markType _ (GHC.HsTyVar promoted name) = do+      when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote+      markLocated name++    markType _ (GHC.HsAppsTy ts) = do+      mapM_ markLocated ts+      inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar++    markType _ (GHC.HsAppTy t1 t2) = do+      setContext (Set.singleton PrefixOp) $ markLocated t1+      markLocated t2++    markType _ (GHC.HsFunTy t1 t2) = do+      markLocated t1+      mark GHC.AnnRarrow+      markLocated t2++    markType _ (GHC.HsListTy t) = do+      mark GHC.AnnOpenS -- '['+      markLocated t+      mark GHC.AnnCloseS -- ']'++    markType _ (GHC.HsPArrTy t) = do+      markWithString GHC.AnnOpen "[:" -- '[:'+      markLocated t+      markWithString GHC.AnnClose ":]" -- ':]'++    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 _ (GHC.HsEqTy t1 t2) = do+      markLocated t1+      mark GHC.AnnTilde+      markLocated t2++    markType _ (GHC.HsKindSig t k) = do+      mark GHC.AnnOpenP  -- '('+      markLocated t+      mark GHC.AnnDcolon -- '::'+      markLocated k+      mark 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.HsCoreTy _t) =+      traceM "warning: HsCoreTy Introduced after renaming"++    markType _ (GHC.HsExplicitListTy promoted _ ts) = do+      when (promoted == GHC.Promoted) $ 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 (GHC.AnonWildCard _)) = do+      markExternal l GHC.AnnVal "_"+++-- ---------------------------------------------------------------------++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"++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++instance (GHC.DataId name)+      => Annotate (GHC.FieldOcc name) where+  markAST _ (GHC.FieldOcc rn _) = do+    markLocated rn+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate GHC.HsDocString where+  markAST l (GHC.HsDocString s) = do+    markExternal l GHC.AnnVal (GHC.unpackFS 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)+      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.PArrPat ps _) = do+        markWithString GHC.AnnOpen "[:"+        mapM_ markLocated ps+        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.SigPatIn pat ty) = do+        markLocated pat+        mark GHC.AnnDcolon+        markLHsSigWcType ty++      markPat _ GHC.SigPatOut {} =+        traceM "warning: SigPatOut introduced after renaming"++      markPat _ GHC.CoPat {} =+        traceM "warning: CoPat introduced after renaming"++-- ---------------------------------------------------------------------++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 "##"++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 -> 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 (GHC.DataId name,Annotate arg)+    => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where+  markAST _ (GHC.HsIB _ thing _) = do+    markLocated thing++-- ---------------------------------------------------------------------++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+    mapM_ markLocated stmts+    markOptional GHC.AnnCloseC+    inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar+    inContext (Set.singleton Intercalate) $ mark GHC.AnnComma+    markTrailingSemi++-- ---------------------------------------------------------------------++-- 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++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where+  markAST _ lb = markHsLocalBinds lb++-- ---------------------------------------------------------------------++markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()+markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =+    applyListAnnotationsLayout+       (prepareListAnnotation (GHC.bagToList binds)+     ++ prepareListAnnotation sigs+       )+markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {})+   = traceM "warning: ValBindsOut introduced after renaming"++markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout binds+markHsLocalBinds GHC.EmptyLocalBinds                   = return ()++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++instance (Annotate body)+  => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsExpr GHC.GhcPs) where+  markAST loc expr = do+    markExpr loc expr+    inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar+    -- TODO: If the AnnComma is not needed, revert to markAST+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+   where+      markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do+        ifInContext (Set.singleton PrefixOp)+          (setContext (Set.singleton PrefixOp) $ markLocated n)+          (ifInContext (Set.singleton InfixOp)+            (setContext (Set.singleton InfixOp) $ markLocated n)+            (markLocated n)+            )++      markExpr l (GHC.HsRecFld f) = markAST l f++      markExpr l (GHC.HsOverLabel _ fs)+        = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)+++      markExpr l (GHC.HsIPVar n@(GHC.HsIPName _v))         =+        markAST l n+      markExpr l (GHC.HsOverLit ov)     = markAST l ov+      markExpr l (GHC.HsLit lit)        = markAST l lit++      markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do+        setContext (Set.singleton LambdaExpr) $ do+        -- TODO: Change this, HsLam binds do not need obey layout rules.+        --       And will only ever have a single match+          markLocated match+      markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match"++      markExpr l (GHC.HsLamCase match) = do+        mark GHC.AnnLam+        mark GHC.AnnCase+        markOptional GHC.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 case cts of+                       GHC.PArrComp -> ("[:",":]")+                       _            -> ("[",  "]")+                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.ExplicitPArr _ es)   = do+        markWithString GHC.AnnOpen "[:"+        markListIntercalateWithFunLevel markLocated 2 es+        markWithString GHC.AnnClose ":]"++      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 _cons _ _ _) = 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.ExprWithTySigOut _e _typ)+        = error "ExprWithTySigOut only occurs after renamer"++      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.PArrSeq _ seqInfo) = do+        markWithString GHC.AnnOpen "[:" -- '[:'+        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+        markWithString GHC.AnnClose ":]" -- ':]'++      markExpr _ (GHC.HsSCC src csFStr e) = do+        markAnnOpen src "{-# SCC"+        let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)+        markWithStringOptional GHC.AnnVal    txt+        markWithString         GHC.AnnValStr txt+        markWithString GHC.AnnClose "#-}"+        markLocated e++      markExpr _ (GHC.HsCoreAnn src csFStr e) = do+        -- markWithString GHC.AnnOpen src -- "{-# CORE"+        markAnnOpen src "{-# CORE"+        -- markWithString GHC.AnnVal (GHC.sl_st csFStr)+        markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)+        markWithString GHC.AnnClose "#-}"+        markLocated e+      -- TODO: make monomorphic+      markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do+        mark GHC.AnnSimpleQuote+        setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v)+      markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do+        mark GHC.AnnThTyQuote+        markLocatedFromKw GHC.AnnName (GHC.L l v)+      markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do+        markWithString GHC.AnnOpen "[d|"+        markOptional GHC.AnnOpenC+        setContext (Set.singleton NoAdvanceLine)+             $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds+        markOptional GHC.AnnCloseC+        mark GHC.AnnCloseQ -- "|]"+      -- Introduced after the renamer+      markExpr _ (GHC.HsBracket (GHC.DecBrG _)) =+        traceM "warning: DecBrG introduced after renamer"+      markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do+        mark GHC.AnnOpenEQ -- "[|"+        markOptional GHC.AnnOpenE  -- "[e|"+        markLocated e+        mark GHC.AnnCloseQ -- "|]"+      markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do+        markWithString GHC.AnnOpen  "[||"+        markWithStringOptional GHC.AnnOpenE "[e||"+        markLocated e+        markWithString GHC.AnnClose "||]"+      markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do+        markWithString GHC.AnnOpen "[t|"+        markLocated e+        mark GHC.AnnCloseQ -- "|]"+      markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do+        markWithString GHC.AnnOpen  "[p|"+        markLocated e+        mark GHC.AnnCloseQ -- "|]"++      markExpr _ (GHC.HsRnBracketOut _ _) =+        traceM "warning: HsRnBracketOut introduced after renamer"+      markExpr _ (GHC.HsTcBracketOut _ _) =+        traceM "warning: HsTcBracketOut introduced after renamer"++      markExpr l (GHC.HsSpliceE e) = markAST l e++      markExpr _ (GHC.HsProc p c) = do+        mark GHC.AnnProc+        markLocated p+        mark GHC.AnnRarrow+        markLocated c++      markExpr _ (GHC.HsStatic _ e) = do+        mark GHC.AnnStatic+        markLocated e++      markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do+            -- isRightToLeft True  => right-to-left (f -< arg)+            --               False => left-to-right (arg >- f)+        if isRightToLeft+          then do+            markLocated e1+            case o of+              GHC.HsFirstOrderApp  -> mark GHC.Annlarrowtail+              GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail+          else do+            markLocated e2+            case o of+              GHC.HsFirstOrderApp  -> mark GHC.Annrarrowtail+              GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail++        if isRightToLeft+          then markLocated e2+          else markLocated e1++      markExpr _ (GHC.HsArrForm e _ cs) = do+        markWithString GHC.AnnOpenB "(|"+        markLocated e+        mapM_ markLocated cs+        markWithString GHC.AnnCloseB "|)"++      markExpr _ (GHC.HsTick _ _) = return ()+      markExpr _ (GHC.HsBinTick _ _ _) = return ()++      markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do+        -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'+        markAnnOpen src  "{-# GENERATED"+        markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING++        let+          markOne n  v GHC.NoSourceText   = markOffsetWithString GHC.AnnVal n (show v)+          markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s++        markOne  1 v1 s1 -- INTEGER+        markOffset GHC.AnnColon 0 -- ':'+        markOne  2 v2 s2 -- INTEGER+        mark   GHC.AnnMinus   -- '-'+        markOne  3 v3 s3 -- INTEGER+        markOffset GHC.AnnColon 1 -- ':'+        markOne  4 v4 s4 -- INTEGER+        markWithString   GHC.AnnClose  "#-}"+        markLocated e++      markExpr l GHC.EWildPat = do+        ifInContext (Set.fromList [InfixOp])+          (do  mark GHC.AnnBackquote+               markWithString GHC.AnnVal "_"+               mark GHC.AnnBackquote)+          (markExternal l GHC.AnnVal "_")++      markExpr _ (GHC.EAsPat ln e) = do+        markLocated ln+        mark GHC.AnnAt+        markLocated e++      markExpr _ (GHC.EViewPat e1 e2) = do+        markLocated e1+        mark GHC.AnnRarrow+        markLocated e2++      markExpr _ (GHC.ELazyPat e) = do+        mark GHC.AnnTilde+        markLocated e++      markExpr _ (GHC.HsAppType e ty) = do+        markLocated e+        markInstead GHC.AnnAt AnnTypeApp+        markLHsWcType ty+      markExpr _ (GHC.HsAppTypeOut _ _) =+        traceM "warning: HsAppTypeOut introduced after renaming"++      markExpr _ (GHC.HsWrap _ _) =+        traceM "warning: HsWrap introduced after renaming"+      markExpr _ (GHC.HsUnboundVar _) =+        traceM "warning: HsUnboundVar introduced after renaming"++      markExpr _ (GHC.HsConLikeOut{}) =+        traceM "warning: HsConLikeOut introduced after type checking"+++-- ---------------------------------------------------------------------++markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated ()+markLHsWcType (GHC.HsWC _ ty) = do+  markLocated ty++-- ---------------------------------------------------------------------++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 (GHC.DataId name)+  => Annotate (GHC.AmbiguousFieldOcc name) where+  markAST _ (GHC.Unambiguous n _) = markLocated n+  markAST _ (GHC.Ambiguous   n _) = markLocated n++-- ---------------------------------------------------------------------++-- |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++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsCmdTop GHC.GhcPs) where+  markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd++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"++-- ---------------------------------------------------------------------++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++  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 fixity ln tyvars+    mark GHC.AnnEqual+    markLocated typ+    markTrailingSemi++  markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns 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 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 _ns tyVars _) fixity fds+                          sigs meths ats atdefs docs _) = do+    mark GHC.AnnClass+    markLocated ctx++    markTyClass 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++-- ---------------------------------------------------------------------++markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)+                => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated ()+markTyClass fixity ln tyVars = do+    -- 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+        setContext (Set.singleton PrefixOp) $ markLocated ln+        -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars+        setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars+        when (length tyVars >= 2) $ do+          markParens GHC.AnnCloseP+          setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars+        markManyOptional GHC.AnnCloseP+      else do+        case tyVars of+          (x:y:xs) -> do+            markParens GHC.AnnOpenP+            markLocated x+            setContext (Set.singleton InfixOp) $ markLocated ln+            markLocated y+            markParens GHC.AnnCloseP+            mapM_ markLocated 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 (GHC.L _ typs)) = do+    let needsParens = case typs of+          [(GHC.HsIB _ (GHC.L _ (GHC.HsTyVar _ _)) _)] -> False+          _                           -> True+    mark GHC.AnnDeriving+    markMaybe mstrategy+    if needsParens then mark         GHC.AnnOpenP+                   else markOptional GHC.AnnOpenP+    markListIntercalateWithFunLevel markLHsSigType 2 typs+    if needsParens then mark         GHC.AnnCloseP+                   else markOptional GHC.AnnCloseP++-- ---------------------------------------------------------------------++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 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+    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++-- ---------------------------------------------------------------------++instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where+  markAST _ (GHC.NoSig)        = return ()+  markAST _ (GHC.KindSig k)    = markLocated k+  markAST _ (GHC.TyVarSig ltv) = markLocated ltv++-- ---------------------------------------------------------------------++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++  markAST _ (GHC.HsIB _ eqn _) = do+    markFamEqn eqn+    markTrailingSemi++-- ---------------------------------------------------------------------++instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where++  markAST _ (GHC.FamEqn ln (GHC.HsQTvs _ns bndrs _) fixity typ) = do+    mark GHC.AnnType+    mark GHC.AnnInstance+    markTyClass fixity ln bndrs+    mark GHC.AnnEqual+    markLocated typ++-- ---------------------------------------------------------------------++-- 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 (GHC.HsDocString fs))     -> GHC.unpackFS fs+            (GHC.DocCommentPrev (GHC.HsDocString fs))     -> GHC.unpackFS fs+            (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs+            (GHC.DocGroup _i (GHC.HsDocString fs))        -> GHC.unpackFS fs+    in+      markExternal l GHC.AnnVal str >> markTrailingSemi++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++-- Note: GHC.HsContext name aliases to here too+instance Annotate [GHC.LHsType GHC.GhcPs] where+  markAST l ts = do+    -- Mote: A single item in parens in a deriving clause is parsed as a+    -- HsSigType, which is always a HsForAllTy. 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+          [_] -> markManyOptional pa+          _   -> markMany         pa++      parenIfNeeded'' pa =+        ifInContext (Set.singleton Parens)+          (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 mqtvs mctx+                         dets _ ) = do+    case mqtvs of+      Nothing -> return ()+      Just (GHC.HsQTvs _ns 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+  markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ _) _) = do+    setContext (Set.singleton PrefixOp) $ markListIntercalate lns+    mark GHC.AnnDcolon+    markLocated typ+    markTrailingSemi++-- ResTyGADT has a SrcSpan for the original sigtype, we need to create+-- a type for exactPC and annotatePC+data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]+                   deriving (Typeable)+deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)+deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)++instance GHC.Outputable (ResTyGADTHook GHC.GhcPs) where+  ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" 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 GHC.GhcPs) where+  markAST _ (ResTyGADTHook bndrs) = do+    unless (null bndrs) $ do+      mark GHC.AnnForall+      mapM_ markLocated bndrs+      mark GHC.AnnDot++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where+  markAST _ (GHC.HsRecField n e punFlag) = do+    unsetContext Intercalate $ markLocated n+    unless punFlag $ do+      mark GHC.AnnEqual+      unsetContext Intercalate $ markLocated e+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+++instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where+  markAST _ (GHC.HsRecField n e punFlag) = do+    unsetContext Intercalate $ markLocated n+    unless punFlag $ do+      mark GHC.AnnEqual+      unsetContext Intercalate $ markLocated e+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where++  markAST _ (ls,rs) = do+    mapM_ markLocated ls+    mark GHC.AnnRarrow+    mapM_ markLocated rs+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate GHC.CType where+  markAST _ (GHC.CType src mh f) = do+    -- markWithString GHC.AnnOpen src+    markAnnOpen src ""+    case mh of+      Nothing -> return ()+      Just (GHC.Header srcH _h) ->+         -- markWithString GHC.AnnHeader srcH+         markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "")+    -- markWithString GHC.AnnVal (fst f)+    markSourceText  (fst f) (GHC.unpackFS $ snd f)+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++stringLiteralToString :: GHC.StringLiteral -> String+stringLiteralToString (GHC.StringLiteral st fs) =+  case st of+    GHC.NoSourceText   -> GHC.unpackFS fs+    GHC.SourceText src -> src

@@ -37,22 +37,11 @@ #endif  import Language.Haskell.GHC.ExactPrint.Types--- import Language.Haskell.GHC.ExactPrint.Utils --- import qualified Bag            as GHC #if __GLASGOW_HASKELL__ > 800 import qualified BasicTypes     as GHC #endif--- 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-#if __GLASGOW_HASKELL__ > 710--- import qualified Lexeme         as GHC-#endif--- import qualified Name           as GHC--- import qualified RdrName        as GHC #if __GLASGOW_HASKELL__ <= 710 import qualified BooleanFormula as GHC import qualified Outputable     as GHC@@ -62,7 +51,6 @@ import Control.Monad.Free.TH (makeFreeCon) import Control.Monad.Identity import Data.Data--- import Data.Maybe  import qualified Data.Set as Set @@ -119,6 +107,9 @@   MarkPPOptional   :: GHC.AnnKeywordId -> Maybe String                     -> next -> AnnotationF next   MarkEOF          ::                                                         next -> AnnotationF next   MarkExternal     :: GHC.SrcSpan -> GHC.AnnKeywordId -> String            -> next -> AnnotationF next+#if __GLASGOW_HASKELL__ >= 800+  MarkInstead      :: GHC.AnnKeywordId -> KeywordId                        -> next -> AnnotationF next+#endif   MarkOutside      :: GHC.AnnKeywordId -> KeywordId                        -> next -> AnnotationF next   MarkInside       :: GHC.AnnKeywordId                                     -> next -> AnnotationF next   MarkMany         :: GHC.AnnKeywordId                                     -> next -> AnnotationF next@@ -165,6 +156,9 @@ makeFreeCon  'MarkEOF makeFreeCon  'MarkPrim makeFreeCon  'MarkPPOptional+#if __GLASGOW_HASKELL__ >= 800+makeFreeCon  'MarkInstead+#endif makeFreeCon  'MarkOutside makeFreeCon  'MarkInside makeFreeCon  'MarkExternal

@@ -287,6 +287,11 @@ tellKd :: (KeywordId, DeltaPos) -> Delta () tellKd kd = tell (mempty { annKds = [kd] }) +#if __GLASGOW_HASKELL__ >= 804+instance Semigroup DeltaWriter where+  (<>) = mappend+#endif+ instance Monoid DeltaWriter where   mempty = DeltaWriter mempty mempty mempty mempty   (DeltaWriter a b e g) `mappend` (DeltaWriter c d f h)@@ -302,6 +307,9 @@     go (MarkEOF next)                   = addEofAnnotation >> next     go (MarkPrim kwid _ next)           = addDeltaAnnotation kwid >> next     go (MarkPPOptional kwid _ next)     = addDeltaAnnotation kwid >> next+#if __GLASGOW_HASKELL__ >= 800+    go (MarkInstead akwid kwid next)    = addDeltaAnnotationInstead akwid kwid >> next+#endif     go (MarkOutside akwid kwid next)    = addDeltaAnnotationsOutside akwid kwid >> next     go (MarkInside akwid next)          = addDeltaAnnotationsInside akwid >> next     go (MarkMany akwid next)            = addDeltaAnnotations akwid >> next@@ -391,19 +399,17 @@ -- comments. annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta () annotationsToCommentsDelta kws = do-  ga <- gets apAnns   ss <- getSrcSpan   cs <- gets apComments   let-    doOne :: GHC.AnnKeywordId -> [Comment]-    doOne kw = comments-      where-        spans = GHC.getAnnotation ga ss kw-        comments = map (mkKWComment kw) spans+    doOne :: GHC.AnnKeywordId -> Delta [Comment]+    doOne kw = do+      (spans,_) <- getAndRemoveAnnotationDelta ss kw+      return $ map (mkKWComment kw) spans     -- TODO:AZ make sure these are sorted/merged properly when the invariant for     -- allocateComments is re-established.-    newComments = concatMap doOne kws-  putUnallocatedComments (cs ++ newComments)+  newComments <- mapM doOne kws+  putUnallocatedComments (cs ++ concat newComments)  -- --------------------------------------------------------------------- @@ -783,6 +789,19 @@                     -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))   let filtered = sort $ filter (\s -> GHC.isSubspanOf s ss) ma   mapM_ do_one filtered++-- ---------------------------------------------------------------------+#if __GLASGOW_HASKELL__ >= 800+addDeltaAnnotationInstead :: GHC.AnnKeywordId  -> KeywordId -> Delta ()+addDeltaAnnotationInstead ann' kw = do+  ss <- getSrcSpan+  (ma,ann) <- getOneAnnotationDelta ann'+  case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier+    []     -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann))+    [pa]   -> addAnnotationWorker kw pa+    (pa:_) -> addAnnotationWorker kw pa `warn` ("addDeltaAnnotationInstead:(ss,ann,kw,ma)=" ++ showGhc (ss,ann,kw,ma))+#endif+-- ---------------------------------------------------------------------  -- | Look up and add possibly multiple Delta annotations not enclosed by -- the current SrcSpan at the current position, and advance the

@@ -148,6 +148,9 @@       (G GHC.AnnlarrowtailU) -> "⤙"       (G GHC.AnnrarrowtailU) -> "⤚" #endif+#if __GLASGOW_HASKELL__ >= 800+      AnnTypeApp             -> "@"+#endif  #if __GLASGOW_HASKELL__ <= 710 -- | Tries to find a unicode equivalent to a 'KeywordId'.

@@ -37,6 +37,7 @@          , initDynFlags         , initDynFlagsPure+        , parseModuleFromStringInternal         , parseModuleApiAnnsWithCpp         , parseModuleApiAnnsWithCppInternal         , postParseTransform@@ -86,7 +87,11 @@           -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w) parseWith dflags fileName parser s =   case runParser parser dflags fileName s of+#if __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 (mkApiAnns -> apianns) pmod -> Right (as, pmod)       where as = relativiseApiAnns pmod apianns @@ -115,7 +120,7 @@  -- --------------------------------------------------------------------- -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.RdrName))+parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) parseFile = runParser GHC.parseModule  -- ---------------------------------------------------------------------@@ -124,27 +129,27 @@                 -> Either (GHC.SrcSpan, String)                           (Anns, a) -parseExpr :: Parser (GHC.LHsExpr GHC.RdrName)+parseExpr :: Parser (GHC.LHsExpr GhcPs) parseExpr df fp = parseWith df fp GHC.parseExpression -parseImport :: Parser (GHC.LImportDecl GHC.RdrName)+parseImport :: Parser (GHC.LImportDecl GhcPs) parseImport df fp = parseWith df fp GHC.parseImport -parseType :: Parser (GHC.LHsType GHC.RdrName)+parseType :: Parser (GHC.LHsType GhcPs) parseType df fp = parseWith df fp GHC.parseType  -- safe, see D1007-parseDecl :: Parser (GHC.LHsDecl GHC.RdrName)+parseDecl :: Parser (GHC.LHsDecl GhcPs) #if __GLASGOW_HASKELL__ <= 710 parseDecl df fp = parseWith df fp (head . OL.fromOL <$> GHC.parseDeclaration) #else parseDecl df fp = parseWith df fp GHC.parseDeclaration #endif -parseStmt :: Parser (GHC.ExprLStmt GHC.RdrName)+parseStmt :: Parser (GHC.ExprLStmt GhcPs) parseStmt df fp = parseWith df fp GHC.parseStatement -parsePattern :: Parser (GHC.LPat GHC.RdrName)+parsePattern :: Parser (GHC.LPat GhcPs) parsePattern df fp = parseWith df fp GHC.parsePattern  -- ---------------------------------------------------------------------@@ -157,7 +162,7 @@ -- parseModule = parseModuleWithCpp defaultCppOptions -- @ ----- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GHC.RdrName')+-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs') parseModule   :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModule = parseModuleWithCpp defaultCppOptions normalLayout@@ -174,8 +179,21 @@   -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleFromString fp s = ghcWrapper $ do   dflags <- initDynFlagsPure fp s-  return $ parseWith dflags fp GHC.parseModule s+  return $ parseModuleFromStringInternal dflags fp s +-- | Internal part of 'parseModuleFromString'.+parseModuleFromStringInternal+  :: GHC.DynFlags+  -> FilePath+  -> String+  -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)+parseModuleFromStringInternal dflags fileName str =+  let (str1, lp) = stripLinePragmas str+      res        = case runParser GHC.parseModule dflags fileName str1 of+        GHC.PFailed ss m    -> Left (ss, GHC.showSDoc dflags m)+        GHC.POk     x  pmod -> Right $ (mkApiAnns x, lp, dflags, pmod)+  in  postParseTransform res normalLayout+ parseModuleWithOptions :: DeltaOptions                        -> FilePath                        -> IO (Either (GHC.SrcSpan, String)@@ -247,7 +265,11 @@         return (contents1,lp,dflags)   return $     case parseFile dflags' file fileContents of+#if __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 (mkApiAnns -> apianns) pmod  ->         Right $ (apianns, injectedComments, dflags', pmod) 

@@ -121,7 +121,11 @@ #else                          $  map (tokComment . commentToAnnotation . fst) cppCommentToks #endif+#if __GLASGOW_HASKELL__ >= 804+        GHC.PFailed _ sspan err -> parseError flags2 sspan err+#else         GHC.PFailed sspan err -> parseError flags2 sspan err+#endif  goodComment :: Comment -> Bool goodComment (Comment "" _ _) = False@@ -176,7 +180,11 @@   let src = stripPreprocessorDirectives buf   case GHC.lexTokenStream src startLoc flags of     GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts+#if __GLASGOW_HASKELL__ >= 804+    GHC.PFailed _ sspan err -> parseError flags sspan err+#else     GHC.PFailed sspan err -> parseError flags sspan err+#endif  -- --------------------------------------------------------------------- 

@@ -113,6 +113,11 @@         } +#if __GLASGOW_HASKELL__ >= 804+instance Semigroup PrettyWriter where+  (<>) = mappend+#endif+ instance Monoid PrettyWriter where   mempty = PrettyWriter mempty mempty mempty mempty mempty   (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j)@@ -153,6 +158,9 @@     go (MarkPPOptional _kwid _ next)    = next     go (MarkEOF next)                   = addEofAnnotation >> next     go (MarkExternal _ss akwid _ next)  = addPrettyAnnotation (G akwid) >> next+#if __GLASGOW_HASKELL__ >= 800+    go (MarkInstead akwid kwid next)    = addPrettyAnnotationsInstead akwid kwid >> next+#endif     go (MarkOutside akwid kwid next)    = addPrettyAnnotationsOutside akwid kwid >> next     -- go (MarkOutside akwid kwid next)    = addPrettyAnnotation kwid >> next     go (MarkInside akwid next)          = addPrettyAnnotationsInside akwid >> next@@ -200,55 +208,68 @@   _ <- debugP ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext   let     dp = case ann of-           (G GHC.AnnAs)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnAt)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnBang)      -> tellKd (ann,DP (0,1))-           (G GHC.AnnBackquote) -> tellKd (ann,DP (0,1))-           (G GHC.AnnBy)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnCase )     -> tellKd (ann,DP (0,1))-           (G GHC.AnnClass)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnClose)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnCloseC)    -> tellKd (ann,DP (0,0))-           (G GHC.AnnDcolon)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnDeriving)  -> tellKd (ann,DP (0,1))-           (G GHC.AnnDo)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnElse)      -> tellKd (ann,DP (1,2))-           (G GHC.AnnEqual)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnExport)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnFamily)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnForall)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnGroup)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnHiding)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnImport)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnIf)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnIn)        -> tellKd (ann,DP (1,0))-           (G GHC.AnnInstance)  -> tellKd (ann,DP (0,1))-           (G GHC.AnnLam)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnMinus)     -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator-           (G GHC.AnnModule)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnOf)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnOpenC)     -> tellKd (ann,DP (0,0))-           (G GHC.AnnOpenPE)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnQualified) -> tellKd (ann,DP (0,1))-           (G GHC.AnnRarrow)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnRole)      -> tellKd (ann,DP (0,1))-           (G GHC.AnnSafe)      -> tellKd (ann,DP (0,1))-           (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1))-           (G GHC.AnnThTyQuote) -> tellKd (ann,DP (0,1))-           (G GHC.AnnThen)      -> tellKd (ann,DP (1,2))-           (G GHC.AnnTilde)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnType)      -> tellKd (ann,DP (0,1))-           (G GHC.AnnUsing)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnVal)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnValStr)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnVbar)      -> tellKd (ann,DP (0,1))-           -- (G GHC.AnnWhere)     -> tellKd (ann,DP (0,1))-           (G GHC.AnnWhere)     -> tellKd (ann,DP (1,2))+           (G GHC.AnnAs)           -> tellKd (ann,DP (0,1))+           (G GHC.AnnAt)           -> tellKd (ann,DP (0,0))+           (G GHC.AnnBackquote)    -> tellKd (ann,DP (0,1))+           (G GHC.AnnBang)         -> tellKd (ann,DP (0,1))+           (G GHC.AnnBy)           -> tellKd (ann,DP (0,1))+           (G GHC.AnnCase )        -> tellKd (ann,DP (0,1))+           (G GHC.AnnClass)        -> tellKd (ann,DP (0,1))+           (G GHC.AnnClose)        -> tellKd (ann,DP (0,1))+           (G GHC.AnnCloseC)       -> tellKd (ann,DP (0,0))+           (G GHC.AnnDcolon)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnDeriving)     -> tellKd (ann,DP (0,1))+           (G GHC.AnnDo)           -> tellKd (ann,DP (0,1))+           (G GHC.AnnElse)         -> tellKd (ann,DP (1,2))+           (G GHC.AnnEqual)        -> tellKd (ann,DP (0,1))+           (G GHC.AnnExport)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnFamily)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnForall)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnGroup)        -> tellKd (ann,DP (0,1))+           (G GHC.AnnHiding)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnIf)           -> tellKd (ann,DP (0,1))+           (G GHC.AnnImport)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnIn)           -> tellKd (ann,DP (1,0))+           (G GHC.AnnInstance)     -> tellKd (ann,DP (0,1))+           (G GHC.AnnLam)          -> tellKd (ann,DP (0,1))+           (G GHC.AnnMinus)        -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator+           (G GHC.AnnModule)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnOf)           -> tellKd (ann,DP (0,1))+           (G GHC.AnnOpenC)        -> tellKd (ann,DP (0,0))+           (G GHC.AnnOpenPE)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnOpenPTE)      -> tellKd (ann,DP (0,1))+           (G GHC.AnnQualified)    -> tellKd (ann,DP (0,1))+           (G GHC.AnnRarrow)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnRole)         -> tellKd (ann,DP (0,1))+           (G GHC.AnnSafe)         -> tellKd (ann,DP (0,1))+           (G GHC.AnnSimpleQuote)  -> tellKd (ann,DP (0,1))+           (G GHC.AnnThIdSplice)   -> tellKd (ann,DP (0,1))+           (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1))+           (G GHC.AnnThTyQuote)    -> tellKd (ann,DP (0,1))+           (G GHC.AnnThen)         -> tellKd (ann,DP (1,2))+           (G GHC.AnnTilde)        -> tellKd (ann,DP (0,1))+           (G GHC.AnnType)         -> tellKd (ann,DP (0,1))+           (G GHC.AnnUsing)        -> tellKd (ann,DP (0,1))+           (G GHC.AnnVal)          -> tellKd (ann,DP (0,1))+           (G GHC.AnnValStr)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnVbar)         -> tellKd (ann,DP (0,1))+           (G GHC.AnnWhere)        -> tellKd (ann,DP (1,2))+#if __GLASGOW_HASKELL__ >= 800+           AnnTypeApp              -> tellKd (ann,DP (0,1))+#endif            _ ->                tellKd (ann,DP (0,0))   fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp  -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 800+addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty ()+addPrettyAnnotationsInstead _akwid AnnSemiSep = return ()+addPrettyAnnotationsInstead _akwid kwid = addPrettyAnnotation kwid+#endif++-- ---------------------------------------------------------------------+ addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty () addPrettyAnnotationsOutside _akwid AnnSemiSep = return () addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid@@ -321,7 +342,6 @@     let cs = [] #endif -    -- uncs <- getUnallocatedComments     -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext     ctx <- asks prContext @@ -379,7 +399,6 @@               && not (inAcs (Set.singleton TopLevel) ctx)     inList = inAcs (Set.singleton ListItem) ctx     inLambda = inAcs (Set.singleton LambdaExpr) ctx-      grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos     grhs _ = do

@@ -30,7 +30,6 @@ import Language.Haskell.GHC.ExactPrint.Annotate import Language.Haskell.GHC.ExactPrint.Lookup --- import Control.Exception import Control.Monad.Identity import Control.Monad.RWS import Control.Monad.Trans.Free@@ -105,6 +104,11 @@ data EPWriter a = EPWriter               { output :: !a } +#if __GLASGOW_HASKELL__ >= 804+instance Monoid w => Semigroup (EPWriter w) where+  (<>) = mappend+#endif+ instance Monoid w => Monoid (EPWriter w) where   mempty = EPWriter mempty   (EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b)@@ -156,6 +160,10 @@       markPrim (G kwid) mstr >> next     go (MarkPPOptional kwid mstr next) =       markPrim (G kwid) mstr >> next+#if __GLASGOW_HASKELL__ >= 800+    go (MarkInstead _ kwid next) =+      printStringAtMaybeAnnAll kwid Nothing  >> next+#endif     go (MarkOutside _ kwid next) =       printStringAtMaybeAnnAll kwid Nothing  >> next     go (MarkInside akwid next) =

@@ -263,13 +263,13 @@ -- ---------------------------------------------------------------------  -- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl'-wrapSig :: GHC.LSig GHC.RdrName -> GHC.LHsDecl GHC.RdrName+wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)  -- ---------------------------------------------------------------------  -- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl'-wrapDecl :: GHC.LHsBind GHC.RdrName -> GHC.LHsDecl GHC.RdrName+wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)  -- ---------------------------------------------------------------------@@ -322,7 +322,7 @@ -- ---------------------------------------------------------------------  -- |'Transform' monad version of 'setPrecedingLinesDecl'-setPrecedingLinesDeclT :: (Monad m) => GHC.LHsDecl GHC.RdrName -> Int -> Int -> TransformT m ()+setPrecedingLinesDeclT :: (Monad m) => GHC.LHsDecl GhcPs -> Int -> Int -> TransformT m () setPrecedingLinesDeclT ld n c =   modifyAnnsT (setPrecedingLinesDecl ld n c) @@ -349,7 +349,7 @@  -- |Unwrap a HsDecl and call setPrecedingLines on it -- ++AZ++ TODO: get rid of this, it is a synonym only-setPrecedingLinesDecl :: GHC.LHsDecl GHC.RdrName -> Int -> Int -> Anns -> Anns+setPrecedingLinesDecl :: GHC.LHsDecl GhcPs -> Int -> Int -> Anns -> Anns setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans  -- ---------------------------------------------------------------------@@ -457,10 +457,10 @@   -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM   -- logTr $ "balanceComments entered"   -- logDataWithAnnsTr "first" first-  case cast first :: Maybe (GHC.LHsDecl GHC.RdrName) of+  case cast first :: Maybe (GHC.LHsDecl GhcPs) of     Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do       balanceCommentsFB (GHC.L l fb) second-    _ -> case cast first :: Maybe (GHC.LHsBind GHC.RdrName) of+    _ -> case cast first :: Maybe (GHC.LHsBind GhcPs) of       Just fb'@(GHC.L _ (GHC.FunBind{})) -> do         balanceCommentsFB fb' second       _ -> balanceComments' first second@@ -492,7 +492,7 @@ -- |Once 'balanceComments' has been called to move trailing comments to a -- '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 GHC.RdrName -> GHC.Located b -> TransformT m ()+balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m () #if __GLASGOW_HASKELL__ <= 710 balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do #else@@ -559,11 +559,11 @@ -- |Insert a declaration into an AST element having sub-declarations -- (@HasDecls@) according to the given location function. insertAt :: (HasDecls (GHC.Located ast))-              => (GHC.LHsDecl GHC.RdrName-                  -> [GHC.LHsDecl GHC.RdrName]-                  -> [GHC.LHsDecl GHC.RdrName])+              => (GHC.LHsDecl GhcPs+                  -> [GHC.LHsDecl GhcPs]+                  -> [GHC.LHsDecl GhcPs])               -> GHC.Located ast-              -> GHC.LHsDecl GHC.RdrName+              -> GHC.LHsDecl GhcPs               -> Transform (GHC.Located ast) insertAt f t decl = do   oldDecls <- hsDecls t@@ -573,7 +573,7 @@ -- AST item insertAtStart, insertAtEnd :: (HasDecls (GHC.Located ast))               => GHC.Located ast-              -> GHC.LHsDecl GHC.RdrName+              -> GHC.LHsDecl GhcPs               -> Transform (GHC.Located ast)  insertAtStart = insertAt (:)@@ -584,7 +584,7 @@ insertAfter, insertBefore :: (HasDecls (GHC.Located ast))                           => GHC.Located old                           -> GHC.Located ast-                          -> GHC.LHsDecl GHC.RdrName+                          -> GHC.LHsDecl GhcPs                           -> Transform (GHC.Located ast) insertAfter (GHC.getLoc -> k) = insertAt findAfter   where@@ -610,7 +610,7 @@     -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl'     -- form, even if orginating in local decls. This is safe, as annotations     -- never attach to the wrapper, only to the wrapped item.-    hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GHC.RdrName]+    hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs]      -- | Replace the directly enclosed decl list by the given     --  decl list. Runs in the 'Transform' monad to be able to update list order@@ -631,7 +631,7 @@     --   where     --     nn = 2     -- @-    replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GHC.RdrName] -> TransformT m t+    replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GhcPs] -> TransformT m t  -- --------------------------------------------------------------------- @@ -645,16 +645,24 @@  -- --------------------------------------------------------------------- -instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where-#if __GLASGOW_HASKELL__ <= 710+instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where+#if __GLASGOW_HASKELL__ >= 804+  hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do+#elif __GLASGOW_HASKELL__ >= 800+  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do+#elif __GLASGOW_HASKELL__ >= 710   hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do #else-  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do+  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do #endif     decls <- hsDeclsValBinds lb     orderedDecls d decls +#if __GLASGOW_HASKELL__ >= 804+  replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) []+#else   replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) []+#endif     = do         logTr "replaceDecls LMatch"         let@@ -676,9 +684,17 @@         binds'' <- replaceDeclsValbinds (GHC.unLoc binds) []         let binds' = GHC.L (GHC.getLoc binds) binds'' #endif+#if __GLASGOW_HASKELL__ >= 804+        return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds')))+#else         return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))+#endif +#if __GLASGOW_HASKELL__ >= 804+  replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds+#else   replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds+#endif     = do         logTr "replaceDecls LMatch"         -- Need to throw in a fresh where clause if the binds were empty,@@ -713,11 +729,15 @@         let binds' = GHC.L (GHC.getLoc binds) binds'' #endif         -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'+#if __GLASGOW_HASKELL__ >= 804+        return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds')))+#else         return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))+#endif  -- --------------------------------------------------------------------- -instance HasDecls (GHC.LHsExpr GHC.RdrName) where+instance HasDecls (GHC.LHsExpr GhcPs) where #if __GLASGOW_HASKELL__ <= 710   hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do #else@@ -743,7 +763,7 @@         logTr "replaceDecls HsPar"         e' <- replaceDecls e newDecls         return (GHC.L l (GHC.HsPar e'))-  replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GHC.RdrName) undefined for:" ++ showGhc old+  replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GhcPs) undefined for:" ++ showGhc old  -- --------------------------------------------------------------------- @@ -751,7 +771,7 @@ -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent.-hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d) hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x @@ -759,7 +779,7 @@ -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent.-hsDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] #if __GLASGOW_HASKELL__ <= 710 hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do #else@@ -775,8 +795,8 @@ -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent.-replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]-                     -> TransformT m (GHC.LHsDecl GHC.RdrName)+replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs]+                     -> TransformT m (GHC.LHsDecl GhcPs) replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do   (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls   return (GHC.L l (GHC.ValD d'))@@ -786,8 +806,8 @@ -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent.-replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]-                    -> TransformT m (GHC.LHsBind GHC.RdrName)+replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs]+                    -> TransformT m (GHC.LHsBind GhcPs) replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls     = do         logTr "replaceDecls PatBind"@@ -824,7 +844,7 @@  -- --------------------------------------------------------------------- -instance HasDecls (GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where+instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where #if __GLASGOW_HASKELL__ <= 710   hsDecls ls@(GHC.L _ (GHC.LetStmt lb))       = do #else@@ -897,7 +917,7 @@ hasDeclsSybTransform :: (SYB.Data t2,Monad m)        => (forall t. HasDecls t => t -> m t)              -- ^Worker function for the general case-       -> (GHC.LHsBind GHC.RdrName -> m (GHC.LHsBind GHC.RdrName))+       -> (GHC.LHsBind GhcPs -> m (GHC.LHsBind GhcPs))              -- ^Worker function for FunBind/PatBind        -> t2 -- ^Item to be updated        -> m t2@@ -912,16 +932,16 @@      parsedSource (p::GHC.ParsedSource) = workerHasDecls p -    lmatch (lm::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+    lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs))       = workerHasDecls lm -    lexpr (le::GHC.LHsExpr GHC.RdrName)+    lexpr (le::GHC.LHsExpr GhcPs)       = workerHasDecls le -    lstmt (d::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName))+    lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs))       = workerHasDecls d -    lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GHC.RdrName)+    lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GhcPs)       = workerBind b     lhsbind b@(GHC.L _ GHC.PatBind{})       = workerBind b@@ -938,7 +958,7 @@ -- return anything for these as there is not meaningful 'replaceDecls' for it. -- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind' -- decls too, where they are needed for analysis only.-hsDeclsGeneric :: (SYB.Data t,Monad m) => t -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsGeneric :: (SYB.Data t,Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsGeneric t = q t   where     q = return []@@ -953,15 +973,15 @@      parsedSource (p::GHC.ParsedSource) = hsDecls p -    lmatch (lm::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsDecls lm+    lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) = hsDecls lm -    lexpr (le::GHC.LHsExpr GHC.RdrName) = hsDecls le+    lexpr (le::GHC.LHsExpr GhcPs) = hsDecls le -    lstmt (d::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsDecls d+    lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) = hsDecls d      -- --------------------------------- -    lhsbind :: (Monad m) => GHC.LHsBind GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+    lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] #if __GLASGOW_HASKELL__ <= 710     lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do #else@@ -980,18 +1000,18 @@      -- --------------------------------- -    llocalbinds :: (Monad m) => GHC.Located (GHC.HsLocalBinds GHC.RdrName) -> TransformT m [GHC.LHsDecl GHC.RdrName]+    llocalbinds :: (Monad m) => GHC.Located (GHC.HsLocalBinds GhcPs) -> TransformT m [GHC.LHsDecl GhcPs]     llocalbinds (GHC.L _ ds) = localbinds ds      -- --------------------------------- -    localbinds :: (Monad m) => GHC.HsLocalBinds GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+    localbinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs]     localbinds d = hsDeclsValBinds d  -- ---------------------------------------------------------------------  -- |Look up the annotated order and sort the decls accordingly-orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GHC.RdrName] -> TransformT m [GHC.LHsDecl GHC.RdrName]+orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GhcPs] -> TransformT m [GHC.LHsDecl GhcPs] orderedDecls parent decls = do   ans <- getAnnsT   case getAnnotationEP parent ans of@@ -1010,7 +1030,7 @@ -- care, as this does not necessarily return the declarations in order, the -- ordering should be done by the calling function from the 'GHC.HsLocalBinds' -- context in the AST.-hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsValBinds lb = case lb of     GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do       let@@ -1026,8 +1046,8 @@ -- ordering should be done by the calling function from the 'GHC.HsLocalBinds' -- context in the AST. replaceDeclsValbinds :: (Monad m)-                     => GHC.HsLocalBinds GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]-                     -> TransformT m (GHC.HsLocalBinds GHC.RdrName)+                     => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]+                     -> TransformT m (GHC.HsLocalBinds GhcPs) replaceDeclsValbinds _ [] = do   return (GHC.EmptyLocalBinds) replaceDeclsValbinds (GHC.HsValBinds _b) new@@ -1048,8 +1068,8 @@  -- --------------------------------------------------------------------- -type Decl  = GHC.LHsDecl GHC.RdrName-type Match = GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)+type Decl  = GHC.LHsDecl GhcPs+type Match = GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)  -- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the -- declarations are extracted and returned after modification. For a@@ -1097,7 +1117,7 @@  -- | Apply a transformation to the decls contained in @t@ modifyDeclsT :: (HasDecls t,HasTransform m)-             => ([GHC.LHsDecl GHC.RdrName] -> m [GHC.LHsDecl GHC.RdrName])+             => ([GHC.LHsDecl GhcPs] -> m [GHC.LHsDecl GhcPs])              -> t -> m t modifyDeclsT action t = do   decls <- liftT $ hsDecls t

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}@@ -32,11 +33,15 @@   , ACS'(..)   , ListContexts(..) +  -- * GHC version compatibility+  , GhcPs+  , GhcRn+  , GhcTc+   -- * Internal Types   , LayoutStartCol(..)   , declFun -   ) where  import Data.Data (Data, Typeable, toConstr,cast)@@ -154,10 +159,21 @@ mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a) ++#if __GLASGOW_HASKELL__ <= 802+type GhcPs = GHC.RdrName+type GhcRn = GHC.Name+type GhcTc = GHC.Id+#else+type GhcPs = GHC.GhcPs+type GhcRn = GHC.GhcRn+type GhcTc = GHC.GhcTc+#endif+ -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. mkAnnKey :: (Data a) => GHC.Located a -> AnnKey mkAnnKey ld =-  case cast ld :: Maybe (GHC.LHsDecl GHC.RdrName) of+  case cast ld :: Maybe (GHC.LHsDecl GhcPs) of     Just d -> declFun mkAnnKeyPrim d     Nothing -> mkAnnKeyPrim ld @@ -175,7 +191,10 @@ -- | The different syntactic elements which are not represented in the -- AST. data KeywordId = G GHC.AnnKeywordId  -- ^ A normal keyword-               | AnnSemiSep          -- ^ A seperating comma+               | AnnSemiSep          -- ^ A separating comma+#if __GLASGOW_HASKELL__ >= 800+               | AnnTypeApp          -- ^ Visible type application annotation+#endif                | AnnComment Comment                | AnnString String    -- ^ Used to pass information from                                      -- Delta to Print when we have to work@@ -189,6 +208,9 @@ instance Show KeywordId where   show (G gc)          = "(G " ++ show gc ++ ")"   show AnnSemiSep      = "AnnSemiSep"+#if __GLASGOW_HASKELL__ >= 800+  show AnnTypeApp      = "AnnTypeApp"+#endif   show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"   show (AnnString s)   = "(AnnString " ++ s ++ ")" #if __GLASGOW_HASKELL__ <= 710@@ -259,6 +281,11 @@                             -- propagate down the AST. Removed when it hits zero   } deriving (Show) +#if __GLASGOW_HASKELL__ >= 804+instance Semigroup (ACS' AstContext) where+  (<>) = mappend+#endif+ instance Monoid (ACS' AstContext) where   mempty = ACS mempty   -- ACS a `mappend` ACS b = ACS (a `mappend` b)@@ -327,7 +354,7 @@  -- --------------------------------------------------------------------- -declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b+declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b declFun f (GHC.L l de) =   case de of       GHC.TyClD d       -> f (GHC.L l d)

@@ -538,11 +538,11 @@         -- overLit :: GHC.HsOverLit GHC.RdrName -> String         -- overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr -        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String+        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String         bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList-        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String+        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String         bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList-        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String+        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String         bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList  #if __GLASGOW_HASKELL__ > 800

@@ -69,7 +69,7 @@       writeFile (failuresHtmlDir </> out) (mkPage fname (ppDiff diff) prev next original res)   where     tokenize :: String -> [[String]]-    tokenize s = map (:[]) . lines $ s+    -- tokenize s = map (:[]) . lines $ s  mkPage :: FilePath -> String -> String -> String -> String -> String -> String mkPage filename diff prev next original printed  =

@@ -28,11 +28,13 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 deriving (Eq, Ord, Show)+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion ghcVersion =-#if __GLASGOW_HASKELL__ > 800+#if __GLASGOW_HASKELL__ > 802+  GHC84+#elif __GLASGOW_HASKELL__ > 800   GHC82 #elif __GLASGOW_HASKELL__ >= 711   GHC80@@ -47,9 +49,10 @@     GHC710 -> ["ghc710-only","ghc710"]     GHC80  -> ["ghc710", "ghc80"]     GHC82  -> ["ghc710", "ghc80", "ghc82"]-    -- GHC82  -> ["ghc82-ghc-test"]-    -- GHC82  -> ["ghc82-ghc-backups-rename"]-    -- GHC82  -> ["ghc82"]+    GHC84  -> ["ghc710", "ghc80", "ghc82", "ghc84" ]+    -- GHC84  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc84-copied"]+    -- GHC84  -> ["ghc84-copied"]+    -- GHC84  -> ["ghc84"]  -- --------------------------------------------------------------------- @@ -129,8 +132,13 @@   roundTripTests <- findTests   prettyRoundTripTests <- findPrettyTests   return $ TestList [-                      internalTests, roundTripTests, transformTests, failingTests, noAnnotationTests+                      internalTests,+                      roundTripTests                     ,+                      transformTests+                    , failingTests+                    , noAnnotationTests+                    ,                       prettyRoundTripTests                     ] @@ -141,15 +149,16 @@   [   -- Tests requiring future GHC modifications     mkTestModBad "InfixOperator.hs"-  , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4 -#if __GLASGOW_HASKELL__ > 800+#if __GLASGOW_HASKELL__ > 802+#elif __GLASGOW_HASKELL__ > 800   , mkTestModBad "overloadedlabelsrun04.hs" #elif __GLASGOW_HASKELL__ > 710   , mkTestModBad "overloadedlabelsrun04.hs"   , mkTestModBad "TensorTests.hs" -- Should be fixed in GHC 8.2   , mkTestModBad "List2.hs"       -- Should be fixed in GHC 8.2 #else+  , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4   , mkTestModBad "UnicodeSyntax.hs"   , mkTestModBad "UnicodeRules.hs"   , mkTestModBad "Deprecation.hs"@@ -187,9 +196,31 @@       -- mkPrettyRoundtrip "ghc80" "pmc007.hs"       -- mkPrettyRoundtrip "ghc80" "MultiQuote.hs"       -- mkPrettyRoundtrip "ghc80" "T10689a.hs"-      -- mkPrettyRoundtrip "ghc710" "Ann01.hs" -       mkParserTest "ghc82" "T13594.hs"+      -- mkPrettyRoundtrip "ghc82" "TensorTests.hs"++   --    mkParserTest      "ghc84" "Main.hs"+      -- mkParserTest      "ghc84" "Types.hs"+    -- , mkPrettyRoundtrip "ghc80" "BundleExport.hs"+    -- , mkPrettyRoundtrip "ghc80" "ExportSyntax.hs"+    -- , mkPrettyRoundtrip "ghc80" "export-class.hs"+    -- , mkPrettyRoundtrip "ghc80" "export-syntax.hs"+    -- , mkPrettyRoundtrip "ghc80" "export-type.hs"++      -- mkPrettyRoundtrip "ghc84" "Main.hs"+      -- mkPrettyRoundtrip "ghc84" "Types.hs"++      mkPrettyRoundtrip "ghc80" "Vta1.hs"+    , mkPrettyRoundtrip "ghc80" "Vta2.hs"++      -- mkParserTest      "ghc80" "BundleExport.hs"++    -- , mkParserTest      "ghc710" "TypeOperators.hs"+    -- , mkParserTest      "ghc80" "TestUtils.hs"++     --   mkParserTest "ghc84" "Functors.hs"+     -- , mkParserTest "ghc80" "MonadT.hs"+       -- mkParserTest "ghc80" "SemicolonIf.hs"       -- mkParserTest "ghc80" "T10689a.hs"       -- mkParserTest "ghc80" "MonadT.hs"

@@ -29,6 +29,7 @@ import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCpp) import Language.Haskell.GHC.ExactPrint.Preprocess+import Language.Haskell.GHC.ExactPrint.Types   import qualified ApiAnnotation as GHC@@ -92,7 +93,7 @@       buffer = GHC.stringToStringBuffer str       parseState = GHC.mkPState flags buffer location -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.RdrName))+parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) parseFile = runParser GHC.parseModule  mkApiAnns :: GHC.PState -> GHC.ApiAnns@@ -177,7 +178,7 @@   runRoundTrip :: Changer-             -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GHC.RdrName)+             -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GhcPs)              -> [Comment]              -> IO (String, Anns, GHC.ParsedSource) runRoundTrip f !anns !parsedOrig cs = do@@ -209,7 +210,11 @@   cfileName <- GHC.liftIO $ canonicalizePath fileName    graph <- GHC.getModuleGraph+#if __GLASGOW_HASKELL__ >= 804+  cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph)+#else   cgraph <- GHC.liftIO $ canonicalizeGraph graph+#endif    let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph   case mm of

@@ -70,7 +70,7 @@  noAnnTests :: [Test] noAnnTests = [-  +         ]  -- ---------------------------------------------------------------------@@ -93,7 +93,8 @@                 roundtripStructure = astStructure parsed' []                 (status,debugTxt') = if roundtripStructure == originalStructure                   then (Success, "ok")-                  else (RoundTripFailure,diffText originalStructure roundtripStructure)+                  else (RoundTripFailure,diffText originalStructure roundtripStructure+                         ++ sep ++ originalStructure ++ sep ++ roundtripStructure)                 cppStatus = Nothing                 inconsistent = Nothing                 !annsOrig = relativiseApiAnnsWithComments injectedComments parsed apianns@@ -109,7 +110,7 @@  runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource                    -> [Comment]-                   -> IO (Either (GHC.SrcSpan, String)(Anns, GHC.ParsedSource))+                   -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) runPrettyRoundTrip origFile !anns !parsedOrig _cs = do   let !newAnns = addAnnotationsForPretty [] parsedOrig mempty   let comments = case Map.lookup GHC.noSrcSpan (snd anns) of@@ -192,14 +193,14 @@         var        = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String         dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String -        overLit :: GHC.HsOverLit GHC.RdrName -> String+        overLit :: GHC.HsOverLit GhcPs -> String         overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr -        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String+        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String         bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList-        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String+        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String         bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList-        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String+        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String         bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList  #if __GLASGOW_HASKELL__ > 800

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} module Test.Transform where  import Language.Haskell.GHC.ExactPrint@@ -103,12 +104,14 @@   -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'   let (p',(ans',_),_w) = runTransform ans doAddLocal       doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p-      replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)-                        -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+      replaceLocalBinds :: GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)+                        -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) #if __GLASGOW_HASKELL__ <= 710       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do-#else+#elif __GLASGOW_HASKELL__ <= 802       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do+#else+      replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do #endif         newSpan <- uniqueSrcSpanT         let@@ -133,9 +136,12 @@                                     [GHC.L ls sig])) #if __GLASGOW_HASKELL__ <= 710         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds)))-#else+#elif __GLASGOW_HASKELL__ <= 802         bindSpan <- uniqueSrcSpanT         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds))))+#else+        bindSpan <- uniqueSrcSpanT+        return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds)))) #endif       replaceLocalBinds x = return x   -- putStrLn $ "log:" ++ intercalate "\n" w@@ -155,12 +161,14 @@   -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'   let (p',(ans',_),_w) = runTransform ans doAddLocal       doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p-      replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)-                        -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+      replaceLocalBinds :: GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)+                        -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) #if __GLASGOW_HASKELL__ <= 710       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do-#else+#elif __GLASGOW_HASKELL__ <= 802       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do+#else+      replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do #endif         a1 <- getAnnsT         a' <- case sigs of@@ -178,8 +186,10 @@                                           (GHC.L ls sig:sigs))) #if __GLASGOW_HASKELL__ <= 710         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds')))-#else+#elif __GLASGOW_HASKELL__ <= 802         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds'))))+#else+        return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds')))) #endif       replaceLocalBinds x = return x   -- putStrLn $ "log:" ++ intercalate "\n" w@@ -278,7 +288,7 @@         | cond ln = GHC.L ln newName     replaceRdr x = x -    replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName+    replaceHsVar :: GHC.LHsExpr GhcPs -> GHC.LHsExpr GhcPs     replaceHsVar (GHC.L ln (GHC.HsVar _)) #if __GLASGOW_HASKELL__ <= 710         | cond ln = GHC.L ln (GHC.HsVar newName)@@ -287,6 +297,9 @@ #endif     replaceHsVar x = x +#if __GLASGOW_HASKELL__ > 802+    replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs+#endif     replacePat (GHC.L ln (GHC.VarPat _)) #if __GLASGOW_HASKELL__ <= 710         | cond ln = GHC.L ln (GHC.VarPat newName)@@ -318,7 +331,7 @@ changeLetIn1 ans parsed   = return (ans,SYB.everywhere (SYB.mkT replace) parsed)   where-    replace :: GHC.HsExpr GHC.RdrName -> GHC.HsExpr GHC.RdrName+    replace :: GHC.HsExpr GhcPs -> GHC.HsExpr GhcPs #if __GLASGOW_HASKELL__ <= 710     replace (GHC.HsLet localDecls expr@(GHC.L _ _)) #else@@ -526,7 +539,7 @@   let       doRmDecl = do         let-          go :: GHC.LHsExpr GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName)+          go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs)           go e@(GHC.L _ (GHC.HsLet{})) = do             decs <- hsDecls e             e' <- replaceDecls e (init decs)@@ -585,7 +598,7 @@   let       doRmDecl = do         let-          go :: GHC.HsExpr GHC.RdrName -> Transform (GHC.HsExpr GHC.RdrName)+          go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs) #if __GLASGOW_HASKELL__ <= 710           go (GHC.HsLet lb expr) = do #else

@@ -0,0 +1,6 @@+module Completesig03A where++data A = A | B++{-# COMPLETE A #-}+

@@ -0,0 +1,17 @@+{-# LANGUAGE UnboxedSums, MagicHash #-}++module Lib (flip, getInt) where++import GHC.Exts+import Prelude (Int)++{-# NOINLINE flip #-}+flip :: (# Int | Int# #) -> (# Int# | Int #)+flip (# i | #) = (# | i #)+flip (# | i #) = (# i | #)++{-# NOINLINE getInt #-}+getInt :: (# Int# | Int #) -> Int+getInt (# i | #) = I# i+getInt (# | i #) = i+

@@ -0,0 +1,40 @@+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Type.Family.List+-- Copyright   :  Copyright (C) 2015 Kyle Carter+-- License     :  BSD3+--+-- Maintainer  :  Kyle Carter <kylcarte@indiana.edu>+-- Stability   :  experimental+-- Portability :  RankNTypes+--+-- Convenient aliases and type families for working with+-- type-level lists.+----------------------------------------------------------------------------++module Type.Family.List where++import Type.Family.Constraint+import Type.Family.Monoid+import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>))+import Type.Class.Witness++type Ø    = '[]+type (:<) = '(:)+infixr 5 :<+

@@ -0,0 +1,10 @@+module Ppr048 where++{-# SCc foo #-}+foo :: Int -> Int+foo       x = x++{-# SCc foo2 "label" #-}+foo2 :: ()+foo2 = ()+

@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}++module T11727 where++pattern A,B :: Int+pattern A = 5+pattern B = 5+

@@ -0,0 +1,7 @@+module HolesInfix where++f, g, q :: Int -> Int -> Int+f x y = _ x y+g x y = x `_` y+q x y = x `_a` y+

@@ -0,0 +1,9 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Bug where++x :: forall a b. (a ~ Integer, b ~ Integer) => (a, b)+!x = (1, 2)+~y = (1, 2)

@@ -0,0 +1,41 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude,+             RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators,+             UndecidableInstances #-}++module TensorTests (tensorTests) where++import Apply.Cyc+import Tests+import Utils++import TestTypes++import Crypto.Lol+import Crypto.Lol.CRTrans+import Crypto.Lol.Cyclotomic.Tensor+import Crypto.Lol.Types++import Control.Applicative++import Data.Maybe++import Data.Singletons+import Data.Promotion.Prelude.Eq+import Data.Singletons.TypeRepStar ()++import qualified Test.Framework as TF++type TMRParams = ( '(,) <$> Tensors) <*> MRCombos+tmrParams :: Proxy TMRParams+tmrParams = Proxy++--type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos+type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos+tremParams :: Proxy TrEmParams+tremParams = Proxy++type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos)++data Liftable :: TyFun (Factored, *) Bool -> *+type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq)+

@@ -0,0 +1,44 @@+{-# LANGUAGE Arrows          #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax   #-}++-- See Trac #10162 and #11743 for details++module ShouldCompile where++import Control.Arrow+import Language.Haskell.TH++handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c+handle f h = proc (b,s) -> (f -< (b,s)) <+> (h -< (b,("FAIL",s)))++f :: ArrowPlus a => a (Int,Int) String+f = proc (x,y) ->+  ⦇handle+    (returnA -< show y)+    (\s -> returnA -< s ++ show x)+  ⦈++g :: ArrowPlus a => a (Int,Int) String+g = proc (x,y) ->+  ⦇handle+    (\msg -> returnA -< msg ++ show y)+    (\s msg -> returnA -< s ++ show x)+  ⦈ ("hello " ++ show x)++h :: ArrowPlus a => a (Int,Int) Int+h = proc (x,y) ->+  (+    (\z -> returnA -< x + z)+    <+>+    (\z -> returnA -< y + z)+  ) (x*y)+++matches :: PatQ -> ExpQ+matches pat = ⟦\x ->+  case x of+    $pat -> True+    _    -> False+  ⟧+

@@ -0,0 +1,21 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}+module Simple where++pattern Foo :: ()+pattern Foo = ()++a :: () -> ()+a Foo = ()++data A = B | C | D++{-# COMPLETE Foo #-}+{-# COMPLETE B,C #-}+{-# COMPLETE B #-}++b :: A -> A+b B = B+b C = C+

@@ -0,0 +1,530 @@+-- | Types are great. Lifting them into some sort of applicative functor makes+-- them even better. This module is an homage to our favorite applicatives, and+-- to the semigroups with which they are instrinsically connected.++{-# LANGUAGE NoImplicitPrelude #-} -- Prelude is bad+{-# LANGUAGE DeriveFunctor     #-} -- Writing Functor instances is boring++module Acme.Functors+    (+    -- * Lifted-but-why+      LiftedButWhy (..)++    -- * Or-not+    , OrNot (..)++    -- * Two+    , Two (..)++    -- * Any-number-of+    , AnyNumberOf (..), (~~)++    -- * One-or-more+    , OneOrMore (..)++    -- * Also-extra-thing+    , Also (..)++    -- * Or-instead-other-thing+    , OrInstead (..)++    -- * Or-instead-other-thing ("first" variant)+    , OrInsteadFirst (..)++    -- * Determined-by-parameter+    , DeterminedBy (..)++    ) where++import Acme.Functors.Classes+++--------------------------------------------------------------------------------+--  Lifted-but-why+--------------------------------------------------------------------------------++-- | __@LiftedButWhy@__ is a boring functor that just has one value and no other+-- structure or interesting properties.++data LiftedButWhy a =++    LiftedButWhy a+    -- ^ A value that has been lifted for some damned reason.+    --+    -- ... Okay, to be honest, this one is /nobody's/ favorite, but it is+    -- included here for completeness.++    deriving (Eq, Functor, Show)++-- | > pure = LiftedButWhy+-- >+-- > LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a)++instance Applicative LiftedButWhy where++    pure = LiftedButWhy++    LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a)++-- | > LiftedButWhy a >>= f = f a+instance Monad LiftedButWhy where++    LiftedButWhy a >>= f = f a++-- | > LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y)++instance Semigroup a => Semigroup (LiftedButWhy a) where++    LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y)++-- | > mempty = LiftedButWhy mempty++instance Monoid a => Monoid (LiftedButWhy a) where++    mempty = LiftedButWhy mempty+++--------------------------------------------------------------------------------+--  Or-not+--------------------------------------------------------------------------------++-- | __@OrNot@__ is somehow slightly more interesting than @LiftedButWhy@, even+-- though it may actually contain /less/. Instead of a value, there might /not/+-- be a value.+--+-- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to+-- be present. If any of them are absent, the whole expression evaluates to+-- @Nope@.++data OrNot a = ActuallyYes a -- ^ Some normal value.+             | Nope          -- ^ Chuck Testa.+    deriving (Eq, Functor, Show)++-- | If you have a function @f@ that might not actually be there, and a value+-- @a@ that might not actually be there, lifted application @(\<*\>)@ gives you+-- @f a@ only if both of them are actually there.+--+-- > pure = ActuallyYes+-- >+-- > ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a)+-- > _             <*> _             = Nope++instance Applicative OrNot where++    pure = ActuallyYes++    ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a)+    _             <*> _             = Nope++instance Monad OrNot where++    ActuallyYes a  >>= f = f a+    Nope           >>= _ = Nope++-- | If you have value @a@ that may not actually be there, and another value+-- @a'@ that might not actually be there, the lifted semigroup operation+-- @(\<\>)@ gives you @a \<\> a'@ only if both of them are actually there.+--+-- > ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a')+-- > _             <> _              = Nope++instance Semigroup a => Semigroup (OrNot a) where++    ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a')+    _             <> _              = Nope++-- | > mempty = ActuallyYes mempty++instance Monoid a => Monoid (OrNot a) where++    mempty = ActuallyYes mempty+++--------------------------------------------------------------------------------+--  Two+--------------------------------------------------------------------------------++-- | __@Two@__ is /two/ values. Yep. Just two values.++data Two a = Two { firstOfTwo  :: a -- ^ One value.+                 , secondOfTwo :: a -- ^ Another value.+                 }+    deriving (Eq, Functor, Show)++-- | If you have two functions @f@ and @g@ and two values @a@ and @a'@, then you+-- can apply them with @(\<*\>)@ to get two results @f a@ and @g a'@.+--+-- > pure a = Two a a+-- >+-- > Two f g <*> Two a a' = Two (f a) (g a')++instance Applicative Two where++    pure a = Two a a++    Two f g <*> Two a a' = Two (f a) (g a')++-- | > Two x y <> Two x' y' = Two (x <> x') (y <> y')++instance Semigroup a => Semigroup (Two a) where++    Two x y <> Two x' y' = Two (x <> x') (y <> y')++-- | > mempty = Two mempty mempty++instance Monoid a => Monoid (Two a) where++    mempty = Two mempty mempty+++--------------------------------------------------------------------------------+--  Any-number-of+--------------------------------------------------------------------------------++-- | __@AnyNumberOf@__ starts to get exciting. Any number of values you want.+-- Zero... one ... two ... three ... four ... five ... The possibilities are+-- /truly/ endless.++data AnyNumberOf a =++    OneAndMaybeMore a (AnyNumberOf a)+    -- ^ One value, and maybe even more after that!++    | ActuallyNone -- ^ Oh. Well this is less fun.++    deriving (Eq, Functor, Show)++-- | Alias for 'OneAndMaybeMore' which provides some brevity.++(~~) :: a -> AnyNumberOf a -> AnyNumberOf a+(~~) = OneAndMaybeMore++infixr 5 ~~++-- | You can use this to apply any number of functions to any number of+-- arguments.+--+-- > pure a = OneAndMaybeMore a ActuallyNone+-- >+-- > OneAndMaybeMore f fs <*> OneAndMaybeMore x xs =+-- >     OneAndMaybeMore (f x) (fs <*> xs)+-- > _ <*> _ = ActuallyNone+--+-- Example:+--+-- >     ( (+ 1) ~~ (* 2) ~~ (+ 5) ~~       ActuallyNone )+-- > <*> (    1  ~~    6  ~~    4  ~~ 37 ~~ ActuallyNone )+-- >  =  (    7  ~~   12  ~~    9  ~~       ActuallyNone )+--+-- This example demonstrates how when there are more arguments than functions,+-- any excess arguments (in this case, the @37@) are ignored.++instance Applicative AnyNumberOf where++    pure a = OneAndMaybeMore a ActuallyNone++    OneAndMaybeMore f fs <*> OneAndMaybeMore x xs =+        OneAndMaybeMore (f x) (fs <*> xs)+    _ <*> _ = ActuallyNone++-- | The operation of combining some number of @a@ with some other number of @a@+-- is sometimes referred to as /zipping/.+--+-- > OneAndMaybeMore x xs <> OneAndMaybeMore y ys =+-- >     OneAndMaybeMore (x <> y) (xs <> ys)+-- > _ <> _ = ActuallyNone++instance Semigroup a => Semigroup (AnyNumberOf a) where++    OneAndMaybeMore x xs <> OneAndMaybeMore y ys =+        OneAndMaybeMore (x <> y) (xs <> ys)+    _ <> _ = ActuallyNone++-- | > mempty = mempty ~~ mempty++instance Monoid a => Monoid (AnyNumberOf a) where++    mempty = mempty ~~ mempty+++--------------------------------------------------------------------------------+--  One-or-more+--------------------------------------------------------------------------------++-- | __@OneOrMore@__ is more restrictive than AnyNumberOf, yet somehow actually+-- /more/ interesting, because it excludes that dull situation where there+-- aren't any values at all.++data OneOrMore a = OneOrMore+    { theFirstOfMany :: a -- ^ Definitely at least this one.+    , possiblyMore :: AnyNumberOf a -- ^ And perhaps others.+    } deriving (Eq, Functor, Show)++-- | > pure a = OneOrMore a ActuallyNone+-- >+-- > OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs)++instance Applicative OneOrMore where++    pure a = OneOrMore a ActuallyNone++    OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs)++-- |+-- > OneOrMore a more <> OneOrMore a' more' =+-- >     OneOrMore a (more <> OneAndMaybeMore a' more')++instance Semigroup a => Semigroup (OneOrMore a) where++    OneOrMore a more <> OneOrMore a' more' =+        OneOrMore a (more <> OneAndMaybeMore a' more')++-- | > mempty = OneOrMore mempty ActuallyNone++instance Monoid a => Monoid (OneOrMore a) where++    mempty = OneOrMore mempty ActuallyNone+++--------------------------------------------------------------------------------+--  Also-extra-thing+--------------------------------------------------------------------------------++-- | __@Also extraThing@__ is a functor in which each value has an @extraThing@+-- of some other type that tags along with it.++data (Also extraThing) a = Also+    { withoutExtraThing :: a          -- ^ A value.+    , theExtraThing     :: extraThing -- ^ An additional thing that tags along.+    }+    deriving (Eq, Functor, Show)++-- | Dragging the @extraThing@ along can be a bit of a burden. It prevents @Also+-- extraThing@ from being an applicative functor — unless the @extraThing@ can+-- pull its weight by bringing a monoid to the table.+--+-- > pure = (`Also` mempty)+-- >+-- > (f `Also` extra1) <*> (a `Also` extra2) = f a+-- >                                           `Also` (extra1 <> extra2)++instance Monoid extraThing => Applicative (Also extraThing) where++    pure = (`Also` mempty)++    (f `Also` extra1) <*> (a `Also` extra2) = f a+                                              `Also` (extra1 <> extra2)++-- |+-- > (a `Also` extra1) <> (a' `Also` extra2) = (a <> a')+-- >                                           `Also` (extra1 <> extra2)++instance (Semigroup extraThing, Semigroup a) => Semigroup ((Also extraThing) a)+  where++    (a `Also` extra1) <> (a' `Also` extra2) = (a <> a')+                                              `Also` (extra1 <> extra2)++-- | > mempty = Also mempty mempty++instance (Monoid extraThing, Monoid a) => Monoid ((Also extraThing) a)+  where++    mempty = Also mempty mempty+++--------------------------------------------------------------------------------+--  Or-instead-other-thing+--------------------------------------------------------------------------------++-- | __@OrInstead otherThing@__ is a functor in which, instead of having a+-- value, can actually just have some totally unrelated @otherThing@ instead.+--+-- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to+-- be present. If any of them are the @otherThing@ instead, then the whole+-- expression evaluates to the combination of the @otherThing@s.++data (OrInstead otherThing) a =+      NotInstead a       -- ^ Some normal value.+    | Instead otherThing -- ^ Some totally unrelated other thing.+    deriving (Eq, Functor, Show)++-- | The possibility of having an @otherThing@ obstructs this functor's ability+-- to be applicative, much like the extra thing in @Also extraThing@ does. In+-- this case, since we do not need an empty value for the @otherThing@, it needs+-- only a semigroup to be in compliance.+--+-- > pure = NotInstead+-- >+-- > NotInstead f   <*> NotInstead a   = NotInstead (f a)+-- > Instead other1 <*> Instead other2 = Instead (other1 <> other2)+-- > Instead other  <*> _              = Instead other+-- > _              <*> Instead other  = Instead other++instance Semigroup otherThing => Applicative (OrInstead otherThing) where++    pure = NotInstead++    NotInstead f   <*> NotInstead a   = NotInstead (f a)+    Instead other1 <*> Instead other2 = Instead (other1 <> other2)+    Instead other  <*> _              = Instead other+    _              <*> Instead other  = Instead other++-- |+-- > NotInstead a   <> NotInstead a'  = NotInstead (a <> a')+-- > Instead other1 <> Instead other2 = Instead (other1 <> other2)+-- > Instead other  <> _              = Instead other+-- > _              <> Instead other  = Instead other++instance (Semigroup otherThing, Semigroup a) =>+  Semigroup ((OrInstead otherThing) a) where++    NotInstead a   <> NotInstead a'  = NotInstead (a <> a')+    Instead other1 <> Instead other2 = Instead (other1 <> other2)+    Instead other  <> _              = Instead other+    _              <> Instead other  = Instead other++-- > mempty = NotInstead mempty++instance (Semigroup otherThing, Monoid a) => Monoid ((OrInstead otherThing) a)+  where++    mempty = NotInstead mempty+++--------------------------------------------------------------------------------+--  Or-instead-first-thing+--------------------------------------------------------------------------------++-- | __@OrInsteadFirst otherThing@__ looks a lot like @OrInstead otherThing@,+-- but it manages to always be an applicative functor — and even a monad too —+-- by handling the @otherThing@s a bit more hamfistedly.+--+-- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to+-- be present. If any of them are the @otherThing@ instead, then the whole+-- expression evaluates to the /first/ @otherThing@ encountered, ignoring any+-- additional @otherThings@ that may subsequently pop up++data (OrInsteadFirst otherThing) a =+      NotInsteadFirst a       -- ^ Some normal value.+    | InsteadFirst otherThing -- ^ Some totally unrelated other thing.+    deriving (Eq, Functor, Show)++-- |+-- > pure = NotInsteadFirst+-- >+-- > NotInsteadFirst f  <*> NotInsteadFirst a  = NotInsteadFirst (f a)+-- > InsteadFirst other <*> _                  = InsteadFirst other+-- > _                  <*> InsteadFirst other = InsteadFirst other++instance Applicative (OrInsteadFirst otherThing) where++    pure = NotInsteadFirst++    NotInsteadFirst f  <*> NotInsteadFirst a  = NotInsteadFirst (f a)+    InsteadFirst other <*> _                  = InsteadFirst other+    _                  <*> InsteadFirst other = InsteadFirst other++-- |+-- > InsteadFirst other >>= _ = InsteadFirst other+-- > NotInsteadFirst a  >>= f = f a++instance Monad (OrInsteadFirst otherThing) where++    InsteadFirst other >>= _ = InsteadFirst other+    NotInsteadFirst a  >>= f = f a++-- |+-- > NotInsteadFirst a  <> NotInsteadFirst a' = NotInsteadFirst (a <> a')+-- > InsteadFirst other <> _                  = InsteadFirst other+-- > _                  <> InsteadFirst other = InsteadFirst other++instance (Semigroup otherThing, Semigroup a) =>+  Semigroup ((OrInsteadFirst otherThing) a) where++    NotInsteadFirst a  <> NotInsteadFirst a' = NotInsteadFirst (a <> a')+    InsteadFirst other <> _                  = InsteadFirst other+    _                  <> InsteadFirst other = InsteadFirst other++-- | > mempty = NotInsteadFirst mempty++instance (Semigroup otherThing, Monoid a) =>+  Monoid ((OrInsteadFirst otherThing) a) where++    mempty = NotInsteadFirst mempty+++--------------------------------------------------------------------------------+--  Determined-by-parameter+--------------------------------------------------------------------------------++-- | __@DeterminedBy parameter@__ is a value that... well, we're not really sure+-- what it is. We'll find out once a @parameter@ is provided.+--+-- The mechanism for deciding /how/ the value is determined from the+-- @parameter@ is opaque; all you can do is test it with different parameters+-- and see what results. There aren't even @Eq@ or @Show@ instances, which is+-- annoying.++data DeterminedBy parameter a = Determination ((->) parameter a)+    deriving (Functor)++-- |+-- > pure a = Determination (\_ -> a)+-- >+-- > Determination f <*> Determination a = Determination (\x -> f x (a x))++instance Applicative (DeterminedBy parameter) where++    pure a = Determination (\_ -> a)++    Determination f <*> Determination a = Determination (\x -> f x (a x))++-- |+-- > Determination fa >>= ff =+-- >     Determination (\x -> let Determination f = ff (fa x) in f x)++instance Monad (DeterminedBy parameter) where++    Determination fa >>= ff =+        Determination (\x -> let Determination f = ff (fa x) in f x)++-- | > Determination f <> Determination g = Determination (\x -> f x <> g x)++instance Semigroup a => Semigroup ((DeterminedBy parameter) a) where++    Determination f <> Determination g = Determination (\x -> f x <> g x)++-- | > mempty = Determination (\_ -> mempty)++instance Monoid a => Monoid ((DeterminedBy parameter) a) where++    mempty = Determination (\_ -> mempty)+++{-++--------------------------------------------------------------------------------+--  Notes+--------------------------------------------------------------------------------++LiftedButWhy is Identity.++OrNot is Maybe, but with a different semigroup and monoid.++Two doesn't have an analogue in the standard library as far as I know.++AnyNumberOf is ZipList.++OneOrMore is NonEmpty.++Also is (,), the 2-tuple.++OrInstead is AccValidation from the 'validation' package.++OrInsteadFirst is Either.++DeterminedBy is (->) also known as a function, whose functor is also known as+Reader.++-}

@@ -0,0 +1,150 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, StandaloneDeriving, TypeFamilies, GADTs+           , ViewPatterns, TypeOperators, TypeApplications, StandaloneDeriving+           , UnicodeSyntax, PatternSynonyms, FlexibleContexts, DataKinds, UndecidableInstances+           , TypeFamilyDependencies #-}++-- invoke as: ghci Main.hs -ddump-parsed -ddump-rn+-- or in GHCi: :set -ddump-parsed -ddump-rn++import TyFamWitnesses+import Language.Haskell.TH hiding (Type)+import Data.Type.Equality hiding (apply)+import Type.Reflection+import Unsafe.Coerce (unsafeCoerce)+import Data.Char (ord)+import GHC.TypeLits+++stuffhave = [d| type family Foo a b where+                  Foo a a = Int+                  Foo (IO a) a = Float+                  Foo (IO a) b = Bool+                  Foo a Char = String+                  Foo a b = Char |]++stuffhave1 = [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |]++stuffhave2 = [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |]+++witnesses [d| type family Foo a b where+                Foo a a = Int+                Foo (IO a) a = Float+                Foo (IO a) b = Bool+                Foo a Char = String+                Foo a b = Char |]++deriving instance Show (FooRefl a b)++-- now you can:+--+-- >>> :info FooRefl+-- type role FooRefl nominal nominal+-- data FooRefl a b where+--   Foo0 :: (Foo a a ~ Int) => FooRefl a a+--   Foo1 :: (Foo (IO b) b ~ Float) => FooRefl (IO b) b+--   Foo2 :: (Foo (IO a1) b ~ Bool) => FooRefl (IO a1) b+--   Foo3 :: (Foo a Char ~ String) => FooRefl a Char+--   Foo4 :: (Foo a b ~ Char) => FooRefl a b+--      -- Defined at Main.hs:13:1+-- instance Show (FooRefl a b) -- Defined at Main.hs:14:1+--+-- >>> :info reify_Foo+-- reify_Foo :: TypeRep a -> TypeRep b -> Maybe (FooRefl a b)+--      -- Defined at Main.hs:13:1+--+-- >>> reify_Foo (typeOf getChar) (typeRep @Char)+-- Just Foo1+--++witnesses [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |]+deriving instance Show (BarRefl a)++witnesses [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |]+deriving instance Show (ElimRefl a b)++pure []++stuffwant2 = [d|+  fooRefl :: forall a b . TypeRep a -> TypeRep b -> Maybe (FooRefl a b)+  fooRefl a b | Just HRefl <- eqTypeRep a b = pure Foo0+  fooRefl a b | Refl <- unsafeCoerce Refl :: Foo a b :~: Char = pure Foo1+  |]++stuffhave3 = [d| data Peano = Z | S Peano+                 type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1))+                 type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n+               |]+++witnesses [d| data Peano = Z | S Peano+              type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1))+              type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n+            |]+++deriving instance Show (ToPeanoRefl n)+deriving instance Show (FromPeanoRefl p)++witnesses [d| type family Unspell (w :: Symbol) = (r :: Nat) | r -> w where+                          Unspell "zero" = 0+                          Unspell "one" = 1+                          Unspell "two" = 2+                          Unspell "three" = 3+            |]+deriving instance Show (UnspellRefl w)++main = runQ (witnesses stuffhave2) >>= print++test@Just{} = reify_Elim (typeRep @Integer) (typeOf ((+1)::Integer->Integer))++lemma :: v -> TypeRep f -> TypeRep v+      -> Maybe (TypeRep (v `Elim` f), f -> v `Elim` f)+lemma w f v = do d `Fun'` c <- pure f+                 witness <- v `reify_Elim` f+                 case witness of+                   Elim0 -> pure (c, ($ w))+                   Elim1 -> do (e, g) <- lemma w c v+                               pure (d `Fun` e, (g.))++data Tag = Source | Destination | CheckSource Bool | CheckDest Bool | Cut Bool++newtype TaggedAction (t :: Tag) = Tagged (IO ())++data Action where+  Action :: Typeable t ⇒ TaggedAction t → Action+  Catalyst :: Typeable (c → d) ⇒ (c → d) → Action++pattern A :: forall k a. () => forall b. (TaggedAction b ~~ a) => TypeRep b → TypeRep a+pattern A b ← (eqTypeRep (typeRep @TaggedAction) → Just HRefl) `App` b+++reaction :: Action → Action → Maybe Action+reaction (Catalyst f) (Action v) = do (rep, f') ← lemma v (typeOf f) (typeOf v)+                                      pure $ case rep of+                                        _ `Fun'` _ → withTypeable rep (Catalyst $ f' f)+                                        A indx → withTypeable indx (Action $ f' f)+++member :: Eq a => a -> [a] -> Bool+member = elem++y $$ x = ($ y).($ x)++--Just (t3r, (($ elem) -> t3)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') -- https://ghc.haskell.org/trac/ghc/ticket/14293+Just (t3r, (($ "joe").($ elem) -> t3@True)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j')+Just (t4r, (($ 'o').($ elem) -> t4@True)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe")+-- Just (t4'r, ('x' $$ elem -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") -- Same bug+Just (t4'r, (($ 'x').($ elem) -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe")++t0@Nothing = lemma "joe" (typeOf ord) (typeOf "joe")+++Just u0 = reify_FromPeano (typeRep @Z)+Just u1 = reify_FromPeano (typeRep @(S Z))+Just u2 = reify_FromPeano (typeRep @(S (S Z)))++Just un0 = reify_Unspell (typeRep @"zero")+Just un1 = reify_Unspell (typeRep @"one")+Just un2 = reify_Unspell (typeRep @"two")+

@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}++module T13747 where++class C a where+  type family TC a :: *++class D a where+  data family TD a :: *++instance C Int where+  type instance TC Int = Int++instance D Double where+  data instance TD Double = TDDouble++instance D Int where+  newtype instance TD Int = TDInt Int++instance D Char where+    data instance TD Char where+        C1 :: TD Char+        C2 :: TD Char+

@@ -0,0 +1,392 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE RecursiveDo         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-name-shadowing     #-}+{-# OPTIONS_GHC -Wno-duplicate-exports  #-}++module Graphics.UI.Threepenny.Editors.Types+  (+  -- * GenericWidgets+    GenericWidget(..)+  , edited+  , contents+  , widgetControl+  , widgetTidings+  -- * Editors+  , Editor(.., Horizontally, horizontally, Vertically, vertically)+  , liftElement+  , dimapE+  , applyE+    -- ** Editor composition+  , (|*|), (|*), (*|)+  , (-*-), (-*), (*-)+  , field+  , fieldLayout+    -- ** Editor constructors+  , editorUnit+  , editorIdentity+  , editorString+  , editorText+  , editorCheckBox+  , editorReadShow+  , editorEnumBounded+  , editorSelection+  , editorSum+  , editorJust+  , EditorCollection(..)+  , editorCollection+  , editorList+  , EditorCollectionConfig(..)+  , defaultEditorCollectionConfig+  -- ** Representation of empty values+  , HasEmpty(..)+  ) where++import           Control.Monad+import           Data.Biapplicative+import           Data.Maybe+import           Data.HasEmpty+import qualified Data.Foldable as F+import           Data.Functor.Compose+import           Data.Functor.Identity+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Profunctor+import           Data.Text (Text)+import qualified Data.Text as Text+import           Graphics.UI.Threepenny.Attributes+import           Graphics.UI.Threepenny.Core           as UI hiding (empty)+import           Graphics.UI.Threepenny.Editors.Layout+import           Graphics.UI.Threepenny.Editors.Utils+import           Graphics.UI.Threepenny.Elements+import           Graphics.UI.Threepenny.Events+import           Graphics.UI.Threepenny.Widgets+import           Text.Read++data GenericWidget control a = GenericWidget+  { widgetTidings :: Tidings a -- ^ The dynamic contents of the widget.+  , widgetControl :: control   -- ^ The actual widget.+  }+  deriving Functor++instance Bifunctor GenericWidget where+  bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e)++traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a)+traverseControl f (GenericWidget t e) = GenericWidget t <$> f e++edited :: GenericWidget el a -> Event a+edited = rumors . widgetTidings++contents :: GenericWidget el a -> Behavior a+contents = facts . widgetTidings++instance Widget el => Widget (GenericWidget el a) where+  getElement = getElement . widgetControl++instance Renderable el => Renderable (GenericWidget el a) where+  render = render . widgetControl++renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a)+renderEditor = traverseControl render++-- | An editor for values of type @inner@ inside a datatype @outer@ realized by a @widget@.+--+--   All the three type arguments are functorial, but @outer@ is contravariant, so @Editor@ is a 'Biapplicative' functor and a 'Profunctor' (via 'dimapE').+--+--  'Biapplicative' allows to compose editors on both their @widget@ and @inner@ structure. When @widget@ is monoidal, widget composition is implicit and 'Applicative' suffices.+--+--  'Profunctor' allows to apply an @inner@ editor to an @outer@ datatype.+--+--   Once 'create'd, an 'Editor' yields a tuple of an @widget@ and a @Tidings inner@ which can be integrated in a threepenny app.+--++newtype Editor outer widget inner = Editor {+  create :: Behavior outer -> UI (GenericWidget widget inner)+  }++-- | Lift an HTML element into a vacuous editor.+liftElement :: UI el -> Editor a el ()+liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el++bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b'+bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create++dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b'+dimapE g h  = unCoer . dimap (fmap g) h . coer+  where+    coer   = Star . (Compose .) . create+    unCoer = Editor . fmap getCompose . runStar++applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b+applyE combineElements a b = Editor $ \s -> do+    a <- create a s+    b <- create b s+    return $ GenericWidget (widgetTidings a <*> widgetTidings b) (widgetControl a `combineElements` widgetControl b)++instance Functor (Editor a el) where+  fmap = dimapE id++instance Bifunctor (Editor a) where+  bimap = bimapEditor++instance Biapplicative (Editor a) where+  bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w+  (<<*>>) = applyE ($)++instance Monoid el => Applicative (Editor a el) where+  pure = bipure mempty+  (<*>) = applyE mappend++-- | Applicative modifier for vertical composition of editor factories.+--   This can be used in conjunction with ApplicativeDo as:+--+-- > editorPerson = vertically $ do+-- >       firstName <- Vertically $ field "First:" firstName editor+-- >       lastName  <- Vertically $ field "Last:"  lastName editor+-- >       age       <- Vertically $ field "Age:"   age editor+-- >       return Person{..}+--+-- DEPRECATED: Use the 'Vertical' layout builder instead+pattern Vertically :: Editor a Layout b -> Editor a Vertical b+pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a++-- | Applicative modifier for horizontal composition of editor factories.+--   This can be used in conjunction with ApplicativeDo as:+--+-- > editorPerson = horizontally $ do+-- >       firstName <- Horizontally $ field "First:" firstName editor+-- >       lastName  <- Horizontally $ field "Last:"  lastName editor+-- >       age       <- Horizontally $ field "Age:"   age editor+-- >       return Person{..}+--+-- DEPRECATED: Use the 'Horizontal' layout builder instead+pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b+pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a++infixl 4 |*|, -*-+infixl 5 |*, *|, -*, *-++-- | Apply a layout builder.+withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b+withLayout f = bimap f id++-- | Left-right editor composition+(|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a+a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b++-- | Left-right composition of an element with a editor+(*|) :: UI Element -> Editor s Layout a -> Editor s Layout a+e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a++-- | Left-right composition of an element with a editor+(|*) :: Editor s Layout a -> UI Element -> Editor s Layout a+a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e)++-- | Left-right editor composition+(-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a+a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b++-- | Left-right composition of an element with a editor+(*-) :: UI Element -> Editor s Layout a -> Editor s Layout a+e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a++-- | Left-right composition of an element with a editor+(-*) :: Editor s Layout a -> UI Element -> Editor s Layout a+a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e)++-- | A helper that arranges a label and an editor horizontally,+--   wrapped in the given monoidal layout builder.+fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a+fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e))++-- | A helper that arranges a label+--   and an editor horizontally.+field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a+field name f e = string name *| first getLayout (dimapE f id e)++editorUnit :: Editor b Element b+editorUnit = Editor $ \b -> do+    t <- new+    return $ GenericWidget (tidings b never) t++editorCheckBox :: Editor Bool Element Bool+editorCheckBox = Editor $ \b -> do+    t <- sink checked b $ input # set type_ "checkbox"+    return $ GenericWidget (tidings b $ checkedChange t) t++editorString :: Editor String TextEntry String+editorString = Editor $ \b -> do+    w <- askWindow+    t <- entry b+    liftIOLater $ do+      initialValue <- currentValue b+      _ <- runUI w $ set value initialValue (element t)+      return ()+    return $ GenericWidget (userText t) t++editorText :: Editor Text TextEntry Text+editorText = dimapE Text.unpack Text.pack editorString++editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a)+editorReadShow = Editor $ \b -> do+    e <- create editorString (maybe "" show <$> b)+    let readIt "" = Nothing+        readIt x  = readMaybe x+    let t = tidings b (readIt <$> edited e)+    return $ GenericWidget t (widgetControl e)++-- An editor that presents a choice of values.+editorEnumBounded+  :: (Bounded a, Enum a, Ord a, Show a)+  => Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)+editorEnumBounded = editorSelection (pure $ enumFrom minBound)++-- | An editor that presents a dynamic choice of values.+editorSelection+  :: Ord a+  => Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)+editorSelection options display = Editor $ \b -> do+  l <- listBox options b display+  return $ GenericWidget (tidings b (rumors $ userSelection l)) l++-- | Ignores 'Nothing' values and only updates for 'Just' values+editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b+editorJust (Editor editor) = Editor $ \b -> do+  e <- editor (Just <$> b)+  let ev = filterJust (edited e)+  return $ GenericWidget (tidings b ev) (widgetControl e)++-- | An editor for union types, built from editors for its constructors.+editorSum+  :: (Ord tag, Show tag, Renderable el)+  => (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a+editorSum combineLayout options selector = Editor $ \ba -> do+  options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options+  let tag = selector <$> ba+  tag' <- calmB tag+  let build a = lookup a options+  -- build a tag selector following the current tag+  l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show))+  -- a placeholder for the constructor editor+  nestedEditor <-+    new # sink children ((\x -> [maybe (error "editorSum") widgetControl (build x)]) <$> tag')+  --+  let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor)+  -- the result event fires when any of the nested editors or the tag selector fire.+  let editedEvents = fmap (edited . snd) options+      eTag = filterJust $ rumors (userSelection l)+      taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options]+      editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag+      editedE = head <$> unions (editedTag : editedEvents)+  return $ GenericWidget (tidings ba editedE) composed++editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a)+editorIdentity = dimapE runIdentity Identity++--------------------------+-- EditorCollection++data EditorCollection k w = EditorCollection+  { selector :: ListBox k+  , add, remove :: Element+  , selected :: w+  }++instance Renderable w => Renderable (EditorCollection k w) where+  render EditorCollection{..} =+    column+    [row [ element selector, element add, element remove]+    ,render selected]++data EditorCollectionConfig k v = EditorCollectionConfig+  { eccNewKey      :: Behavior k                 -- ^ Current value to use for creating a new key+  , eccAfterDelKey :: Behavior (Maybe k)         -- ^ Current value to use if the selected key is deleted+  , eccTemplate    :: v                          -- ^ Value to use for creating new items+  , eccOptions     :: Behavior (Set k)           -- ^ Currently user select able keys+  , eccDisplay     :: Behavior (k -> UI Element) -- ^ How to render a key+  }++defaultEditorCollectionConfig+  :: (Enum k, Ord k, Show k, HasEmpty v)+  => Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v+defaultEditorCollectionConfig db = EditorCollectionConfig+  { eccTemplate = emptyValue+  , eccOptions  = options+  , eccDisplay  = pure (UI.string . show)+  , eccNewKey   = maybe (toEnum 0) succ . Set.lookupMax <$> options+  , eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options+  }+  where+    options = Map.keysSet . snd <$> db++    deletedKey Nothing  _  = Nothing+    deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk++-- | A barebones editor for collections of editable items.+--   Displays an index selector, add and delete buttons, and an editor for the selected item.+--   Limitations:+--     - Won't work with recursive data structures, due to the lack of FRP switch.+editorCollection+  :: forall k v w.+     (Ord k, Renderable w)+  => (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v)+  -> Editor v w v+  -> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v)+editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo+  let EditorCollectionConfig{..} = mkConfig ba+      (selectedKey, db) = (fst <$> ba, snd <$> ba)+  sel  <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba)+  one  <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba+  addB <- button #+ [string "+"]+  remB <- button #+ [string "-"]+  let insert i = Map.insert i eccTemplate+      editsDb = head <$> unions+                [ replace <$> ba <@> edited one+                , insert  <$> eccNewKey <*> db <@ click addB+                , delete  <$> ba <@ click remB+                ]+      editsKey = head <$> unions+                [ edited sel+                , Just <$> eccNewKey <@ click addB+                , eccAfterDelKey <@ click remB+                ]+      tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb+  return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one))+ where+   replace (Just i,xx) x = Map.alter (const $ Just x) i xx+   replace (Nothing,x) _ = x+   delete  (Just i,xx)   = Map.delete i xx+   delete  (_,xx)        = xx++-- | A barebones editor for collections of editable items.+--   Displays an index selector, add and delete buttons, and an editor for the selected item.+--   Limitations:+--     - Won't work with recursive data structures, due to the lack of FRP switch.+editorList+  :: (HasEmpty a, Renderable w)+  => Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a])+editorList e =+  dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $+  editorCollection config e+  where+    (<&>) = flip (<$>)+    infixl 1 <&>+    config ba =+      (defaultEditorCollectionConfig ba)+      { eccAfterDelKey =+        ba <&> (\(i,m) ->+             i >>= (\i ->+                      if Map.member (i + 1) m+                      then return i+                      else let i' = max 0 (i - 1)+                           in guard(i'>=0) >> return i'))+      }+

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

@@ -1,22 +0,0 @@---- From https://github.com/alanz/ghc-exactprint/issues/53#issuecomment-306839162--blah = func-  where---                       status   standard   previous---                       quo      layouting  /associated---                                rule only  ast item- func =-  -- mercury             (1, 1)   (1,1)      (1,1)-    [-        -- venus         (1, 7)   (1, 7)     (1, 7) or (1, 2) if connected to "foo x"-      foo x-         -- earth        (1, 8)   (1, 8)     (1, 3)-     |   y <- z-       -- pluto          (1, -2)  (1, 6)     (1, -2)-      -- saturn          (1, -3)  (1, 5)     (1, -3)-     ,    x <- y-           -- jupiter    (1, 2)   (1, 10)    (1, 1)-     ,      pred x-  -- nepturn             (1, 1)   (1, 1)     (1, -10)-      ]

@@ -1,22 +0,0 @@---- From https://github.com/alanz/ghc-exactprint/issues/53#issuecomment-306839162--blah = func-  where---                       status   standard   previous---                       quo      layouting  /associated---                                rule only  ast item- func =-  -- mercury             (1, 1)   (1,1)      (1,1)-    [-        -- venus         (1, 7)   (1, 7)     (1, 7) or (1, 2) if connected to "foo x"-      foo x-         -- earth        (1, 8)   (1, 8)     (1, 3)-     |   y <- z-       -- pluto          (1, -2)  (1, 6)     (1, -2)-      -- saturn          (1, -3)  (1, 5)     (1, -3)-     ,    x <- y-           -- jupiter    (1, 2)   (1, 10)    (1, 1)-     ,      pred x-  -- nepturn             (1, 1)   (1, 1)     (1, -10)-      ]