summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlanZimmerman <>2020-03-26 23:09:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-03-26 23:09:00 (GMT)
commit744c4379500d1f3cfb3124ca5b1f9867d6923911 (patch)
treeeec2bcbb1580daf7c84c9475f2df97783b45473a
parent72a92d78f15b002ee468a5d56182518a3d4f9b3e (diff)
version 0.6.30.6.3
-rwxr-xr-xChangeLog2
-rw-r--r--ghc-exactprint.cabal93
-rw-r--r--src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs2952
-rw-r--r--src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs7
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Delta.hs2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Parsers.hs80
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Preprocess.hs39
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Pretty.hs2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Transform.hs28
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Types.hs16
-rw-r--r--tests/PrepareHackage.hs22
-rw-r--r--tests/Roundtrip.hs2
-rw-r--r--tests/Test.hs66
-rw-r--r--tests/Test/Common.hs28
-rw-r--r--tests/Test/NoAnnotations.hs16
-rw-r--r--tests/Test/Transform.hs42
-rwxr-xr-xtests/examples/ghc810/T16326_Compile1.hs43
-rwxr-xr-xtests/examples/ghc810/T17296.hs38
-rwxr-xr-xtests/examples/ghc810/T3391.hs15
-rwxr-xr-xtests/examples/ghc810/TH_scope.hs10
-rwxr-xr-xtests/examples/ghc810/TH_unresolvedInfix.hs137
-rwxr-xr-xtests/examples/ghc810/TH_unresolvedInfix_Lib.hs94
-rwxr-xr-xtests/examples/ghc810/mod181.hs9
-rwxr-xr-xtests/examples/ghc810/saks029.hs14
-rwxr-xr-xtests/examples/ghc810/saks032.hs22
-rwxr-xr-xtests/examples/pre-ghc810/arrowfail003.hs (renamed from tests/examples/ghc84/arrowfail003.hs)0
26 files changed, 3620 insertions, 159 deletions
diff --git a/ChangeLog b/ChangeLog
index 430ab7e..11d3a80 100755
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,5 @@
+2020-03-26 v0.6.3
+ * Support GHC 8.8.1, 8.8.2, 8.8.3, 8.10.1
2019-08-28 v0.6.2
* Support GHC 8.8.1 (release candidate)
2019-05-27 v0.6.1
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index 3c27c17..8eb6bb2 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -1,5 +1,5 @@
name: ghc-exactprint
-version: 0.6.2
+version: 0.6.3
synopsis: ExactPrint for GHC
description: Using the API Annotations available from GHC 7.10.2, this
library provides a means to round trip any code that can
@@ -40,16 +40,22 @@ tested-with: GHC == 7.10.3
, GHC == 8.6.2
, GHC == 8.6.4
, GHC == 8.6.5
+ , GHC == 8.8.1
+ , GHC == 8.8.2
+ , GHC == 8.8.3
+ , GHC == 8.10.1
extra-source-files: ChangeLog
src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs
tests/examples/failing/*.hs
- tests/examples/ghc710/*.hs
tests/examples/ghc710-only/*.hs
+ tests/examples/ghc710/*.hs
tests/examples/ghc80/*.hs
+ tests/examples/ghc810/*.hs
tests/examples/ghc82/*.hs
tests/examples/ghc84/*.hs
tests/examples/ghc86/*.hs
tests/examples/ghc88/*.hs
+ tests/examples/pre-ghc810/*.hs
tests/examples/pre-ghc86/*.hs
tests/examples/vect/*.hs
tests/examples/transform/*.hs
@@ -93,8 +99,12 @@ library
-- other-modules:
-- other-extensions:
- GHC-Options: -Wall
- build-depends: base >=4.8 && <4.14
+ if impl (ghc >= 8.0.1)
+ GHC-Options: -Wall -Wredundant-constraints
+ else
+ GHC-Options: -Wall
+ -- GHC-Options: -Weverything
+ build-depends: base >=4.8 && <4.16
, bytestring >= 0.10.6
, containers >= 0.5
, directory >= 1.2
@@ -113,22 +123,25 @@ library
build-depends: ghc-boot
hs-source-dirs: src
- if impl (ghc > 8.6.5)
- hs-source-dirs: src-ghc88
+ if impl (ghc > 8.8.3)
+ hs-source-dirs: src-ghc810
else
- if impl (ghc > 8.4.4)
- hs-source-dirs: src-ghc86
+ if impl (ghc > 8.6.5)
+ hs-source-dirs: src-ghc88
else
- if impl (ghc > 8.2.2)
- hs-source-dirs: src-ghc84
+ if impl (ghc > 8.4.4)
+ hs-source-dirs: src-ghc86
else
- if impl (ghc > 8.0.3)
- hs-source-dirs: src-ghc82
+ if impl (ghc > 8.2.2)
+ hs-source-dirs: src-ghc84
else
- if impl (ghc > 7.10.3)
- hs-source-dirs: src-ghc80
+ if impl (ghc > 8.0.3)
+ hs-source-dirs: src-ghc82
else
- hs-source-dirs: src-ghc710
+ if impl (ghc > 7.10.3)
+ hs-source-dirs: src-ghc80
+ else
+ hs-source-dirs: src-ghc710
default-language: Haskell2010
if impl (ghc < 7.10.2)
@@ -142,34 +155,41 @@ Test-Suite test
else
hs-source-dirs: tests
- if impl (ghc > 8.6.5)
- hs-source-dirs: src-ghc88
+ if impl (ghc > 8.8.3)
+ hs-source-dirs: src-ghc810
else
- if impl (ghc > 8.4.4)
- hs-source-dirs: src-ghc86
+ if impl (ghc > 8.6.5)
+ hs-source-dirs: src-ghc88
else
- if impl (ghc > 8.2.2)
- hs-source-dirs: src-ghc84
+ if impl (ghc > 8.4.4)
+ hs-source-dirs: src-ghc86
else
- if impl (ghc > 8.0.3)
- hs-source-dirs: src-ghc82
+ if impl (ghc > 8.2.2)
+ hs-source-dirs: src-ghc84
else
- if impl (ghc > 7.10.3)
- hs-source-dirs: src-ghc80
+ if impl (ghc > 8.0.3)
+ hs-source-dirs: src-ghc82
else
- hs-source-dirs: src-ghc710
+ if impl (ghc > 7.10.3)
+ hs-source-dirs: src-ghc80
+ else
+ hs-source-dirs: src-ghc710
main-is: Test.hs
other-modules: Test.Common
+ , Test.CommonUtils
, Test.Consistency
, Test.NoAnnotations
, Test.Transform
- GHC-Options: -threaded -Wall
+ if impl (ghc >= 8.0.1)
+ GHC-Options: -threaded -Wall -Wredundant-constraints
+ else
+ GHC-Options: -threaded -Wall
Default-language: Haskell2010
if impl (ghc < 7.10.2)
buildable: False
Build-depends: HUnit >= 1.2
- , base < 4.14
+ , base < 4.16
, bytestring
, containers >= 0.5
, Diff
@@ -219,8 +239,10 @@ executable roundtrip
buildable: True
else
buildable: False
- ghc-options:
- -threaded -Wall
+ if impl (ghc >= 8.0.1)
+ GHC-Options: -threaded -Wall -Wredundant-constraints
+ else
+ GHC-Options: -threaded -Wall
executable static
main-is: Static.hs
@@ -238,8 +260,10 @@ executable static
build-depends: ghc-boot
else
buildable: False
- ghc-options:
- -threaded -Wall
+ if impl (ghc >= 8.0.1)
+ GHC-Options: -threaded -Wall -Wredundant-constraints
+ else
+ GHC-Options: -threaded -Wall
executable prepare-hackage
main-is: PrepareHackage.hs
@@ -261,4 +285,7 @@ executable prepare-hackage
build-depends: ghc-boot
else
buildable: False
- GHC-Options: -threaded
+ if impl (ghc >= 8.0.1)
+ GHC-Options: -threaded -Wall -Wredundant-constraints
+ else
+ GHC-Options: -threaded -Wall
diff --git a/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs
new file mode 100644
index 0000000..433ab72
--- /dev/null
+++ b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs
@@ -0,0 +1,2952 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
+
+
+-- | 'annotate' is a function which given a GHC AST fragment, constructs
+-- a syntax tree which indicates which annotations belong to each specific
+-- part of the fragment.
+--
+-- "Delta" and "Print" provide two interpreters for this structure. You
+-- should probably use those unless you know what you're doing!
+--
+-- The functor 'AnnotationF' has a number of constructors which correspond
+-- to different sitations which annotations can arise. It is hoped that in
+-- future versions of GHC these can be simplified by making suitable
+-- modifications to the AST.
+
+module Language.Haskell.GHC.ExactPrint.Annotater
+ (
+ annotate
+ , AnnotationF(..)
+ , Annotated
+ , Annotate(..)
+ , withSortKeyContextsHelper
+ ) where
+
+
+import Language.Haskell.GHC.ExactPrint.AnnotateTypes
+import Language.Haskell.GHC.ExactPrint.Types
+import Language.Haskell.GHC.ExactPrint.Utils
+
+import qualified Bag as GHC
+import qualified BasicTypes as GHC
+import qualified BooleanFormula as GHC
+import qualified Class as GHC
+import qualified CoAxiom as GHC
+import qualified FastString as GHC
+import qualified ForeignCall as GHC
+import qualified GHC as GHC
+-- import qualified HsDoc as GHC
+import qualified Name as GHC
+import qualified RdrName as GHC
+import qualified Outputable as GHC
+import qualified SrcLoc as GHC
+
+import Control.Monad.Identity
+import Data.Data
+import Data.Maybe
+
+import qualified Data.Set as Set
+
+import Debug.Trace
+
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+{-# ANN module "HLint: ignore Redundant do" #-}
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+-- ---------------------------------------------------------------------
+
+class Data ast => Annotate ast where
+ markAST :: GHC.SrcSpan -> ast -> Annotated ()
+
+-- ---------------------------------------------------------------------
+
+-- | Construct a syntax tree which represent which KeywordIds must appear
+-- where.
+annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated ()
+annotate = markLocated
+
+-- instance Annotate (GHC.SrcSpanLess ast) where
+-- markAST s ast = undefined
+instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where
+ markAST l (GHC.L _ ast) = markAST l ast
+
+-- ---------------------------------------------------------------------
+
+-- | Constructs a syntax tree which contains information about which
+-- annotations are required by each element.
+markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+ => ast -> Annotated ()
+markLocated ast =
+ case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of
+ Just d -> markLHsDecl d
+ Nothing -> withLocated ast markAST
+
+-- ---------------------------------------------------------------------
+
+-- |When adding missing annotations, do not put a preceding space in front of a list
+markListNoPrecedingSpace :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+ => Bool -> [ast] -> Annotated ()
+markListNoPrecedingSpace intercal ls =
+ case ls of
+ [] -> return ()
+ (l:ls') -> do
+ if intercal
+ then do
+ if null ls'
+ then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l
+ else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l
+ markListIntercalate ls'
+ else do
+ setContext (Set.singleton NoPrecedingSpace) $ markLocated l
+ mapM_ markLocated ls'
+
+-- ---------------------------------------------------------------------
+
+
+-- |Mark a list, with the given keyword as a list item separator
+markListIntercalate :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
+ => [ast] -> Annotated ()
+markListIntercalate ls = markListIntercalateWithFun markLocated ls
+
+-- ---------------------------------------------------------------------
+
+markListWithContexts :: Annotate ast
+ => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated ()
+markListWithContexts ctxInitial ctxRest ls =
+ case ls of
+ [] -> return ()
+ [x] -> setContextLevel ctxInitial 2 $ markLocated x
+ (x:xs) -> do
+ setContextLevel ctxInitial 2 $ markLocated x
+ setContextLevel ctxRest 2 $ mapM_ markLocated xs
+
+-- ---------------------------------------------------------------------
+
+-- Context for only if just one, else first item, middle ones, and last one
+markListWithContexts' :: Annotate ast
+ => ListContexts
+ -> [GHC.Located ast] -> Annotated ()
+markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls =
+ case ls of
+ [] -> return ()
+ [x] -> setContextLevel ctxOnly level $ markLocated x
+ (x:xs) -> do
+ setContextLevel ctxInitial level $ markLocated x
+ go xs
+ where
+ level = 2
+ go [] = return ()
+ go [x] = setContextLevel ctxLast level $ markLocated x
+ go (x:xs) = do
+ setContextLevel ctxMiddle level $ markLocated x
+ go xs
+
+
+-- ---------------------------------------------------------------------
+
+markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markListWithLayout ls =
+ setLayoutFlag $ markList ls
+
+-- ---------------------------------------------------------------------
+
+markList :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markList ls =
+ setContext (Set.singleton NoPrecedingSpace)
+ $ markListWithContexts' listContexts' ls
+
+markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()
+markLocalBindsWithLayout binds = markHsLocalBinds binds
+
+-- ---------------------------------------------------------------------
+
+-- |This function is used to get around shortcomings in the GHC AST for 7.10.1
+markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated ()
+markLocatedFromKw kw (GHC.L l a) = do
+ -- Note: l is needed so that the pretty printer can make something up
+ ss <- getSrcSpanForKw l kw
+ AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a))
+ markLocated (GHC.L ss' a)
+
+-- ---------------------------------------------------------------------
+
+markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()
+markMaybe Nothing = return ()
+markMaybe (Just ast) = markLocated ast
+
+-- ---------------------------------------------------------------------
+-- Managing lists which have been separated, e.g. Sigs and Binds
+
+prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())]
+prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsModule GHC.GhcPs) where
+ markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do
+
+ case mmn of
+ Nothing -> return ()
+ Just (GHC.L ln mn) -> do
+ mark GHC.AnnModule
+ markExternal ln GHC.AnnVal (GHC.moduleNameString mn)
+
+ forM_ mdepr markLocated
+ forM_ mexp markLocated
+
+ mark GHC.AnnWhere
+
+ markOptional GHC.AnnOpenC -- Possible '{'
+ markManyOptional GHC.AnnSemi -- possible leading semis
+ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps
+
+ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs
+
+ markOptional GHC.AnnCloseC -- Possible '}'
+
+ markEOF
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.WarningTxt where
+ markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do
+ markAnnOpen txt "{-# WARNING"
+ mark GHC.AnnOpenS
+ markListIntercalate lss
+ mark GHC.AnnCloseS
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do
+ markAnnOpen txt "{-# DEPRECATED"
+ mark GHC.AnnOpenS
+ markListIntercalate lss
+ mark GHC.AnnCloseS
+ markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.StringLiteral where
+ markAST l (GHC.StringLiteral src fs) = do
+ markExternalSourceText l src (show (GHC.unpackFS fs))
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.SourceText,GHC.FastString) where
+ markAST l (src,fs) = do
+ markExternalSourceText l src (show (GHC.unpackFS fs))
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LIE GHC.GhcPs] where
+ markAST _ ls = do
+ inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl
+ mark GHC.AnnOpenP -- '('
+ -- Can't use markListIntercalate, there can be trailing commas, but only in imports.
+ markListIntercalateWithFunLevel markLocated 2 ls
+
+ mark GHC.AnnCloseP -- ')'
+
+instance Annotate (GHC.IE GHC.GhcPs) where
+ markAST _ ie = do
+
+ case ie of
+ GHC.IEVar _ ln -> markLocated ln
+
+ GHC.IEThingAbs _ ln -> do
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+
+ GHC.IEThingWith _ ln wc ns _lfs -> do
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mark GHC.AnnOpenP
+ case wc of
+ GHC.NoIEWildcard ->
+ unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+ $ markListIntercalate ns
+ GHC.IEWildcard n -> do
+ setContext (Set.fromList [PrefixOp,Intercalate])
+ $ mapM_ markLocated (take n ns)
+ mark GHC.AnnDotdot
+ case drop n ns of
+ [] -> return ()
+ ns' -> do
+ mark GHC.AnnComma
+ unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+ $ markListIntercalate ns'
+ mark GHC.AnnCloseP
+
+ (GHC.IEThingAll _ ln) -> do
+ setContext (Set.fromList [PrefixOp]) $ markLocated ln
+ mark GHC.AnnOpenP
+ mark GHC.AnnDotdot
+ mark GHC.AnnCloseP
+
+ (GHC.IEModuleContents _ (GHC.L lm mn)) -> do
+ mark GHC.AnnModule
+ markExternal lm GHC.AnnVal (GHC.moduleNameString mn)
+
+ -- Only used in Haddock mode so we can ignore them.
+ (GHC.IEGroup {}) -> return ()
+
+ (GHC.IEDoc {}) -> return ()
+
+ (GHC.IEDocNamed {}) -> return ()
+ GHC.XIE x -> error $ "got XIE for :" ++ showGhc x
+ ifInContext (Set.fromList [Intercalate])
+ (mark GHC.AnnComma)
+ (markOptional GHC.AnnComma)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.IEWrappedName GHC.RdrName) where
+ markAST _ (GHC.IEName ln) = do
+ unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+ $ markLocated ln
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ markAST _ (GHC.IEPattern ln) = do
+ mark GHC.AnnPattern
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ markAST _ (GHC.IEType ln) = do
+ mark GHC.AnnType
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+isSymRdr :: GHC.RdrName -> Bool
+isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "."
+
+instance Annotate GHC.RdrName where
+ markAST l n = do
+ let
+ str = rdrName2String n
+ isSym = isSymRdr n
+ doNormalRdrName = do
+ let str' = case str of
+ -- TODO: unicode support?
+ "forall" -> if spanLength l == 1 then "∀" else str
+ _ -> str
+
+ let
+ markParen :: GHC.AnnKeywordId -> Annotated ()
+ markParen pa = do
+ if isSym
+ then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar])
+ (mark pa) -- '('
+ (markOptional pa)
+ else markOptional pa
+
+ markOptional GHC.AnnSimpleQuote
+ markParen GHC.AnnOpenP
+ unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0
+ cnt <- countAnns GHC.AnnVal
+ case cnt of
+ 0 -> markExternal l GHC.AnnVal str'
+ 1 -> markWithString GHC.AnnVal str'
+ _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)
+ unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1
+ markParen GHC.AnnCloseP
+
+ case n of
+ GHC.Unqual _ -> doNormalRdrName
+ GHC.Qual _ _ -> doNormalRdrName
+ GHC.Orig _ _ -> if str == "~"
+ then doNormalRdrName
+ -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen)
+ else markExternal l GHC.AnnVal str
+ -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str
+ -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]"
+ GHC.Exact n' -> do
+ case str of
+ -- Special handling for Exact RdrNames, which are built-in Names
+ "[]" -> do
+ mark GHC.AnnOpenS -- '['
+ mark GHC.AnnCloseS -- ']'
+ "()" -> do
+ mark GHC.AnnOpenP -- '('
+ mark GHC.AnnCloseP -- ')'
+ ('(':'#':_) -> do
+ markWithString GHC.AnnOpen "(#" -- '(#'
+ let cnt = length $ filter (==',') str
+ replicateM_ cnt (mark GHC.AnnCommaTuple)
+ markWithString GHC.AnnClose "#)"-- '#)'
+ "[::]" -> do
+ markWithString GHC.AnnOpen "[:" -- '[:'
+ markWithString GHC.AnnClose ":]" -- ':]'
+ "->" -> do
+ mark GHC.AnnOpenP -- '('
+ mark GHC.AnnRarrow
+ mark GHC.AnnCloseP -- ')'
+ -- "~#" -> do
+ -- mark GHC.AnnOpenP -- '('
+ -- mark GHC.AnnTildehsh
+ -- mark GHC.AnnCloseP
+ "~" -> do
+ doNormalRdrName
+ "*" -> do
+ markExternal l GHC.AnnVal str
+ "★" -> do -- Note: unicode star
+ markExternal l GHC.AnnVal str
+ ":" -> do
+ -- Note: The OccName for ":" has the following attributes (via occAttributes)
+ -- (d, Data DataSym Sym Val )
+ -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
+ doNormalRdrName
+ -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName
+ ('(':',':_) -> do
+ mark GHC.AnnOpenP
+ let cnt = length $ filter (==',') str
+ replicateM_ cnt (mark GHC.AnnCommaTuple)
+ mark GHC.AnnCloseP -- ')'
+ _ -> do
+ let isSym' = isSymRdr (GHC.nameRdrName n')
+ when isSym' $ mark GHC.AnnOpenP -- '('
+ markWithString GHC.AnnVal str
+ when isSym $ mark GHC.AnnCloseP -- ')'
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ImportDecl GHC.GhcPs) where
+ markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do
+
+ -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
+ mark GHC.AnnImport
+
+ -- "{-# SOURCE" and "#-}"
+ case msrc of
+ GHC.SourceText _txt -> do
+ markAnnOpen msrc "{-# SOURCE"
+ markWithString GHC.AnnClose "#-}"
+ GHC.NoSourceText -> return ()
+ when safeflag (mark GHC.AnnSafe)
+ case qualFlag of
+ GHC.QualifiedPre -- 'qualified' appears in prepositive position.
+ -> (unsetContext TopLevel $ mark GHC.AnnQualified)
+ _ -> return ()
+ case mpkg of
+ Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) ->
+ markWithString GHC.AnnPackageName srcPkg
+ _ -> return ()
+
+ markLocated modname
+
+ case qualFlag of
+ GHC.QualifiedPost -- 'qualified' appears in postpositive position.
+ -> (unsetContext TopLevel $ mark GHC.AnnQualified)
+ _ -> return ()
+
+ case GHC.ideclAs imp of
+ Nothing -> return ()
+ Just mn -> do
+ mark GHC.AnnAs
+ markLocated mn
+
+ case hiding of
+ Nothing -> return ()
+ Just (isHiding,lie) -> do
+ if isHiding
+ then setContext (Set.singleton HasHiding) $
+ markLocated lie
+ else markLocated lie
+ markTrailingSemi
+
+
+ markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.ModuleName where
+ markAST l mname =
+ markExternal l GHC.AnnVal (GHC.moduleNameString mname)
+
+-- ---------------------------------------------------------------------
+
+markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated ()
+markLHsDecl (GHC.L l decl) =
+ case decl of
+ GHC.TyClD _ d -> markLocated (GHC.L l d)
+ GHC.InstD _ d -> markLocated (GHC.L l d)
+ GHC.DerivD _ d -> markLocated (GHC.L l d)
+ GHC.ValD _ d -> markLocated (GHC.L l d)
+ GHC.SigD _ d -> markLocated (GHC.L l d)
+ GHC.KindSigD _ d -> markLocated (GHC.L l d)
+ GHC.DefD _ d -> markLocated (GHC.L l d)
+ GHC.ForD _ d -> markLocated (GHC.L l d)
+ GHC.WarningD _ d -> markLocated (GHC.L l d)
+ GHC.AnnD _ d -> markLocated (GHC.L l d)
+ GHC.RuleD _ d -> markLocated (GHC.L l d)
+ GHC.SpliceD _ d -> markLocated (GHC.L l d)
+ GHC.DocD _ d -> markLocated (GHC.L l d)
+ GHC.RoleAnnotD _ d -> markLocated (GHC.L l d)
+ GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x
+
+instance Annotate (GHC.HsDecl GHC.GhcPs) where
+ markAST l d = markLHsDecl (GHC.L l d)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where
+ markAST _ (GHC.RoleAnnotDecl _ ln mr) = do
+ mark GHC.AnnType
+ mark GHC.AnnRole
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mapM_ markLocated mr
+ markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x
+
+instance Annotate (Maybe GHC.Role) where
+ markAST l Nothing = markExternal l GHC.AnnVal "_"
+ markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.SpliceDecl GHC.GhcPs) where
+ markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do
+ markLocated e
+ markTrailingSemi
+ markAST _ (GHC.SpliceDecl _ e _flag) = do
+ markLocated e
+ markTrailingSemi
+
+ markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RuleDecls GHC.GhcPs) where
+ markAST _ (GHC.HsRules _ src rules) = do
+ markAnnOpen src "{-# RULES"
+ setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules
+ markWithString GHC.AnnClose "#-}"
+ markTrailingSemi
+ markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RuleDecl GHC.GhcPs) where
+ markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do
+ markLocated ln
+ setContext (Set.singleton ExplicitNeverActive) $ markActivation l act
+
+ case mtybndrs of
+ Nothing -> return ()
+ Just bndrs -> do
+ mark GHC.AnnForall
+ mapM_ markLocated bndrs
+ mark GHC.AnnDot
+
+ mark GHC.AnnForall
+ mapM_ markLocated termbndrs
+ mark GHC.AnnDot
+
+ markLocated lhs
+ mark GHC.AnnEqual
+ markLocated rhs
+ inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi
+ markTrailingSemi
+{-
+ = HsRule -- Source rule
+ { rd_ext :: XHsRule pass
+ -- ^ After renamer, free-vars from the LHS and RHS
+ , rd_name :: Located (SourceText,RuleName)
+ -- ^ Note [Pragma source text] in BasicTypes
+ , rd_act :: Activation
+ , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]
+ -- ^ Forall'd type vars
+ , rd_tmvs :: [LRuleBndr pass]
+ -- ^ Forall'd term vars, before typechecking; after typechecking
+ -- this includes all forall'd vars
+ , rd_lhs :: Located (HsExpr pass)
+ , rd_rhs :: Located (HsExpr pass)
+ }
+
+-}
+
+ markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated ()
+markActivation _ act = do
+ case act of
+ GHC.ActiveBefore src phase -> do
+ mark GHC.AnnOpenS -- '['
+ mark GHC.AnnTilde -- ~
+ markSourceText src (show phase)
+ mark GHC.AnnCloseS -- ']'
+ GHC.ActiveAfter src phase -> do
+ mark GHC.AnnOpenS -- '['
+ markSourceText src (show phase)
+ mark GHC.AnnCloseS -- ']'
+ GHC.NeverActive -> do
+ inContext (Set.singleton ExplicitNeverActive) $ do
+ mark GHC.AnnOpenS -- '['
+ mark GHC.AnnTilde -- ~
+ mark GHC.AnnCloseS -- ']'
+ _ -> return ()
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RuleBndr GHC.GhcPs) where
+ markAST _ (GHC.RuleBndr _ ln) = markLocated ln
+ markAST _ (GHC.RuleBndrSig _ ln st) = do
+ mark GHC.AnnOpenP -- "("
+ markLocated ln
+ mark GHC.AnnDcolon
+ markLHsSigWcType st
+ mark GHC.AnnCloseP -- ")"
+ markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated ()
+markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do
+ markLocated ty
+markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit"
+markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.AnnDecl GHC.GhcPs) where
+ markAST _ (GHC.HsAnnotation _ src prov e) = do
+ markAnnOpen src "{-# ANN"
+ case prov of
+ (GHC.ValueAnnProvenance n) -> markLocated n
+ (GHC.TypeAnnProvenance n) -> do
+ mark GHC.AnnType
+ markLocated n
+ GHC.ModuleAnnProvenance -> mark GHC.AnnModule
+
+ markLocated e
+ markWithString GHC.AnnClose "#-}"
+ markTrailingSemi
+
+ markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.WarnDecls GHC.GhcPs) where
+ markAST _ (GHC.Warnings _ src warns) = do
+ markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED
+ mapM_ markLocated warns
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.WarnDecl GHC.GhcPs) where
+ markAST _ (GHC.Warning _ lns txt) = do
+ markListIntercalate lns
+ mark GHC.AnnOpenS -- "["
+ case txt of
+ GHC.WarningTxt _src ls -> markListIntercalate ls
+ GHC.DeprecatedTxt _src ls -> markListIntercalate ls
+ mark GHC.AnnCloseS -- "]"
+
+ markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x
+
+instance Annotate GHC.FastString where
+ -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
+ markAST l fs = do
+ markExternal l GHC.AnnVal (show (GHC.unpackFS fs))
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ForeignDecl GHC.GhcPs) where
+ markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ)
+ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do
+ mark GHC.AnnForeign
+ mark GHC.AnnImport
+ markLocated cconv
+ unless (ll == GHC.noSrcSpan) $ markLocated safety
+ markExternalSourceText ls src ""
+ markLocated ln
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+
+ markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do
+ mark GHC.AnnForeign
+ mark GHC.AnnExport
+ markLocated spec
+ markExternal ls GHC.AnnVal (sourceTextToString src "")
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mark GHC.AnnDcolon
+ markLocated typ
+
+
+ markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion"
+ markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion"
+ markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion"
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate GHC.CExportSpec) where
+ markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate GHC.CCallConv) where
+ markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall"
+ markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall"
+ markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi"
+ markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim"
+ markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript"
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate GHC.Safety) where
+ markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe"
+ markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe"
+ markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DerivDecl GHC.GhcPs) where
+
+ markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do
+ mark GHC.AnnDeriving
+ markMaybe ms
+ mark GHC.AnnInstance
+ markMaybe mov
+ markLocated typ
+ markTrailingSemi
+
+{-
+data DerivDecl pass = DerivDecl
+ { deriv_ext :: XCDerivDecl pass
+ , deriv_type :: LHsSigWcType pass
+ -- ^ The instance type to derive.
+ --
+ -- It uses an 'LHsSigWcType' because the context is allowed to be a
+ -- single wildcard:
+ --
+ -- > deriving instance _ => Eq (Foo a)
+ --
+ -- Which signifies that the context should be inferred.
+
+ -- See Note [Inferring the instance context] in TcDerivInfer.
+
+ , deriv_strategy :: Maybe (LDerivStrategy pass)
+ , deriv_overlap_mode :: Maybe (Located OverlapMode)
+
+type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
+
+data HsWildCardBndrs pass thing
+ -- See Note [HsType binders]
+ -- See Note [The wildcard story for types]
+ = HsWC { hswc_ext :: XHsWC pass thing
+ -- after the renamer
+ -- Wild cards, both named and anonymous
+
+ , hswc_body :: thing
+ -- Main payload (type or list of types)
+ -- If there is an extra-constraints wildcard,
+ -- it's still there in the hsc_body.
+ }
+
+
+-}
+
+
+ markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension"
+ markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension"
+ markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DerivStrategy GHC.GhcPs) where
+
+ markAST _ GHC.StockStrategy = mark GHC.AnnStock
+ markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass
+ markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype
+ markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do
+ mark GHC.AnnVia
+ markLocated ty
+ markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _))
+ = error $ "got XHsImplicitBndrs in AnnDerivStrategy"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DefaultDecl GHC.GhcPs) where
+
+ markAST _ (GHC.DefaultDecl _ typs) = do
+ mark GHC.AnnDefault
+ mark GHC.AnnOpenP -- '('
+ markListIntercalate typs
+ mark GHC.AnnCloseP -- ')'
+ markTrailingSemi
+
+ markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.InstDecl GHC.GhcPs) where
+
+ markAST l (GHC.ClsInstD _ cid) = markAST l cid
+ markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid
+ markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid
+ markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.OverlapMode where
+
+ -- NOTE: NoOverlap is only used in the typechecker
+ markAST _ (GHC.NoOverlap src) = do
+ markAnnOpen src "{-# NO_OVERLAP"
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.Overlappable src) = do
+ markAnnOpen src "{-# OVERLAPPABLE"
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.Overlapping src) = do
+ markAnnOpen src "{-# OVERLAPPING"
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.Overlaps src) = do
+ markAnnOpen src "{-# OVERLAPS"
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.Incoherent src) = do
+ markAnnOpen src "{-# INCOHERENT"
+ markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where
+
+ markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do
+ mark GHC.AnnInstance
+ markMaybe mov
+ markLocated poly
+ mark GHC.AnnWhere
+ markOptional GHC.AnnOpenC -- '{'
+ markInside GHC.AnnSemi
+
+ applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds)
+ ++ prepareListAnnotation sigs
+ ++ prepareListAnnotation tyfams
+ ++ prepareListAnnotation datafams
+ )
+
+ markOptional GHC.AnnCloseC -- '}'
+ markTrailingSemi
+
+ markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl"
+ markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where
+{-
+newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
+
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
+
+type FamInstEqn pass rhs
+ = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+
+
+-}
+ markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do
+ mark GHC.AnnType
+ mark GHC.AnnInstance -- Note: this keyword is optional
+ markFamEqn eqn
+ markTrailingSemi
+
+ markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl"
+
+-- ---------------------------------------------------------------------
+
+-- markFamEqn :: (GHC.HasOccName (GHC.IdP pass),
+-- Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)
+-- => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2)
+-- -> Annotated ()
+-- markFamEqn :: GHC.FamEqn GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs)
+markFamEqn :: GHC.FamEqn GhcPs (GHC.LHsType GHC.GhcPs)
+ -> Annotated ()
+markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do
+ markTyClassArgs bndrs fixity ln pats
+ mark GHC.AnnEqual
+ markLocated rhs
+{-
+data FamEqn pass pats rhs
+ = FamEqn
+ { feqn_ext :: XCFamEqn pass pats rhs
+ , feqn_tycon :: Located (IdP pass)
+ , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars
+ , feqn_pats :: pats
+ , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , feqn_rhs :: rhs
+ }
+-}
+
+markFamEqn (GHC.XFamEqn _) = error "got XFamEqn"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where
+
+ markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs pats fixity
+ defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do
+ case GHC.dd_ND defn of
+ GHC.NewType -> mark GHC.AnnNewtype
+ GHC.DataType -> mark GHC.AnnData
+ mark GHC.AnnInstance
+
+ markLocated ctx
+
+ markTyClassArgs bndrs fixity ln pats
+
+ case (GHC.dd_kindSig defn) of
+ Just s -> do
+ mark GHC.AnnDcolon
+ markLocated s
+ Nothing -> return ()
+ if isGadt $ GHC.dd_cons defn
+ then mark GHC.AnnWhere
+ else unless (null cons) $ mark GHC.AnnEqual
+ markDataDefn l (GHC.HsDataDefn GHC.NoExtField nd (GHC.noLoc []) typ _mk cons mderivs)
+ markOptional GHC.AnnWhere
+ markTrailingSemi
+
+ markAST _
+ (GHC.DataFamInstDecl
+ (GHC.HsIB _ (GHC.FamEqn _ _ _ _ _ (GHC.XHsDataDefn _))))
+ = error "extension hit for DataFamInstDecl"
+ markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _)))
+ = error "extension hit for DataFamInstDecl"
+ markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _))
+ = error "extension hit for DataFamInstDecl"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsBind GHC.GhcPs) where
+ markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do
+ -- Note: from a layout perspective a FunBind should not exist, so the
+ -- current context is passed through unchanged to the matches.
+ -- TODO: perhaps bring the edp from the first match up to the annotation for
+ -- the FunBind.
+ let
+ tlFun =
+ ifInContext (Set.fromList [CtxOnly,CtxFirst])
+ (markListWithContexts' listContexts matches)
+ (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches)
+ ifInContext (Set.singleton TopLevel)
+ (setContextLevel (Set.singleton TopLevel) 2 tlFun)
+ tlFun
+
+ -- -----------------------------------
+
+ markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do
+ markLocated lhs
+ case grhs of
+ (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards
+ _ -> return ()
+ markListIntercalateWithFunLevel markLocated 2 grhs
+
+ -- TODO: extract this common code
+ case lb of
+ GHC.EmptyLocalBinds{} -> return ()
+ _ -> do
+ mark GHC.AnnWhere
+ markOptional GHC.AnnOpenC -- '{'
+ markInside GHC.AnnSemi
+ markLocalBindsWithLayout lb
+ markOptional GHC.AnnCloseC -- '}'
+ markTrailingSemi
+
+ -- -----------------------------------
+
+ markAST _ (GHC.VarBind _ _n rhse _) =
+ -- Note: this bind is introduced by the typechecker
+ markLocated rhse
+
+ -- -----------------------------------
+
+ -- Introduced after renaming.
+ markAST _ (GHC.AbsBinds {}) =
+ traceM "warning: AbsBinds introduced after renaming"
+
+ -- -----------------------------------
+
+ markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do
+ mark GHC.AnnPattern
+ case args of
+ GHC.InfixCon la lb -> do
+ markLocated la
+ setContext (Set.singleton InfixOp) $ markLocated ln
+ markLocated lb
+ GHC.PrefixCon ns -> do
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mapM_ markLocated ns
+ GHC.RecCon fs -> do
+ markLocated ln
+ mark GHC.AnnOpenC -- '{'
+ markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs
+ mark GHC.AnnCloseC -- '}'
+ case dir of
+ GHC.ImplicitBidirectional -> mark GHC.AnnEqual
+ _ -> mark GHC.AnnLarrow
+
+ markLocated def
+ case dir of
+ GHC.Unidirectional -> return ()
+ GHC.ImplicitBidirectional -> return ()
+ GHC.ExplicitBidirectional mg -> do
+ mark GHC.AnnWhere
+ mark GHC.AnnOpenC -- '{'
+ markMatchGroup l mg
+ mark GHC.AnnCloseC -- '}'
+
+ markTrailingSemi
+
+ -- -----------------------------------
+
+ markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _)
+ = error "extension hit for HsBind"
+ markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _)
+ = error "extension hit for HsBind"
+ markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _))
+ = error "extension hit for HsBind"
+ markAST _ (GHC.XHsBindsLR _)
+ = error "extension hit for HsBind"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.IPBind GHC.GhcPs) where
+ markAST _ (GHC.IPBind _ en e) = do
+ case en of
+ Left n -> markLocated n
+ Right _i -> return ()
+ mark GHC.AnnEqual
+ markLocated e
+ markTrailingSemi
+
+ -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x
+ markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.HsIPName where
+ markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+ => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where
+
+ markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do
+ let
+ get_infix (GHC.FunRhs _ f _) = f
+ get_infix _ = GHC.Prefix
+
+ isFunBind GHC.FunRhs{} = True
+ isFunBind _ = False
+ case (get_infix mln,pats) of
+ (GHC.Infix, a:b:xs) -> do
+ if null xs
+ then markOptional GHC.AnnOpenP
+ else mark GHC.AnnOpenP
+ markLocated a
+ case mln of
+ GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n
+ _ -> return ()
+ markLocated b
+ if null xs
+ then markOptional GHC.AnnCloseP
+ else mark GHC.AnnCloseP
+ mapM_ markLocated xs
+ _ -> do
+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+ inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam
+ case mln of
+ GHC.FunRhs n _ s -> do
+ setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do
+ when (s == GHC.SrcStrict) $ mark GHC.AnnBang
+ markLocated n
+ mapM_ markLocated pats
+ _ -> markListNoPrecedingSpace False pats
+
+ -- TODO: The AnnEqual annotation actually belongs in the first GRHS value
+ case grhs of
+ (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards
+ _ -> return ()
+ inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam
+ mapM_ markLocated grhs
+
+ case lb of
+ GHC.EmptyLocalBinds{} -> return ()
+ _ -> do
+ mark GHC.AnnWhere
+ markOptional GHC.AnnOpenC -- '{'
+ markInside GHC.AnnSemi
+ markLocalBindsWithLayout lb
+ markOptional GHC.AnnCloseC -- '}'
+ markTrailingSemi
+
+ -- -----------------------------------
+
+ markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _))
+ = error "hit extension for Match"
+ markAST _ (GHC.XMatch _)
+ = error "hit extension for Match"
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+ => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where
+ markAST _ (GHC.GRHS _ guards expr) = do
+ case guards of
+ [] -> return ()
+ (_:_) -> do
+ mark GHC.AnnVbar
+ unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp])
+ $ markListIntercalate guards
+ ifInContext (Set.fromList [CaseAlt])
+ (return ())
+ (mark GHC.AnnEqual)
+
+ markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test
+
+ inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam
+ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr
+
+ markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.Sig GHC.GhcPs) where
+
+ markAST _ (GHC.TypeSig _ lns st) = do
+ setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns
+ mark GHC.AnnDcolon
+ markLHsSigWcType st
+ markTrailingSemi
+ tellContext (Set.singleton FollowingLine)
+
+ markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do
+ mark GHC.AnnPattern
+ setContext (Set.singleton PrefixOp) $ markListIntercalate lns
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+
+ markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do
+ when isDefault $ mark GHC.AnnDefault
+ setContext (Set.singleton PrefixOp) $ markListIntercalate ns
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+
+ markAST _ (GHC.IdSig {}) =
+ traceM "warning: Introduced after renaming"
+
+ markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do
+ let fixstr = case fdir of
+ GHC.InfixL -> "infixl"
+ GHC.InfixR -> "infixr"
+ GHC.InfixN -> "infix"
+ markWithString GHC.AnnInfix fixstr
+ markSourceText src (show v)
+ setContext (Set.singleton InfixOp) $ markListIntercalate lns
+ markTrailingSemi
+
+ markAST l (GHC.InlineSig _ ln inl) = do
+ markAnnOpen (GHC.inl_src inl) "{-# INLINE"
+ markActivation l (GHC.inl_act inl)
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+ markAST l (GHC.SpecSig _ ln typs inl) = do
+ markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ markActivation l (GHC.inl_act inl)
+ markLocated ln
+ mark GHC.AnnDcolon -- '::'
+ markListIntercalateWithFunLevel markLHsSigType 2 typs
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+
+ markAST _ (GHC.SpecInstSig _ src typ) = do
+ markAnnOpen src "{-# SPECIALISE"
+ mark GHC.AnnInstance
+ markLHsSigType typ
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+
+ markAST _ (GHC.MinimalSig _ src formula) = do
+ markAnnOpen src "{-# MINIMAL"
+ markLocated formula
+ markWithString GHC.AnnClose "#-}"
+ markTrailingSemi
+
+ markAST _ (GHC.SCCFunSig _ src ln ml) = do
+ markAnnOpen src "{-# SCC"
+ markLocated ln
+ markMaybe ml
+ markWithString GHC.AnnClose "#-}"
+ markTrailingSemi
+
+ markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do
+ markAnnOpen src "{-# COMPLETE"
+ markListIntercalate ns
+ case mlns of
+ Nothing -> return ()
+ Just _ -> do
+ mark GHC.AnnDcolon
+ markMaybe mlns
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+ -- -----------------------------------
+ markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _))
+ = error "hit extension for Sig"
+ markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _))
+ = error "hit extension for Sig"
+ markAST _ (GHC.FixSig _ (GHC.XFixitySig _))
+ = error "hit extension for Sig"
+ markAST _ (GHC.XSig _)
+ = error "hit extension for Sig"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.StandaloneKindSig GHC.GhcPs) where
+
+ markAST _ (GHC.StandaloneKindSig _ ln st) = do
+ mark GHC.AnnType
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mark GHC.AnnDcolon
+ markLHsSigType st
+ markTrailingSemi
+ tellContext (Set.singleton FollowingLine)
+
+ markAST _ (GHC.XStandaloneKindSig _)
+ = error "hit extension for StandaloneKindSig"
+
+-- --------------------------------------------------------------------
+
+markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated ()
+markLHsSigType (GHC.HsIB _ typ) = markLocated typ
+markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+instance Annotate [GHC.LHsSigType GHC.GhcPs] where
+ markAST _ ls = do
+ -- mark GHC.AnnDeriving
+ -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it
+ -- is a HsTyVar. So for round trip pretty printing we need to take this into
+ -- account.
+ let marker = case ls of
+ [] -> markManyOptional
+ [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t)
+ then markMany
+ else markManyOptional
+ _ -> markMany -- Need parens if more than one entry
+ marker GHC.AnnOpenP
+ markListIntercalateWithFun markLHsSigType ls
+ marker GHC.AnnCloseP
+
+-- --------------------------------------------------------------------
+
+instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
+ markAST _ (GHC.Var x) = do
+ setContext (Set.singleton PrefixOp) $ markLocated x
+ inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls
+ markAST _ (GHC.And ls) = do
+ markListIntercalateWithFunLevel markLocated 2 ls
+ inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ markAST _ (GHC.Parens x) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated x
+ mark GHC.AnnCloseP -- ')'
+ inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where
+ markAST _l (GHC.UserTyVar _ n) = do
+ markLocated n
+
+ markAST _ (GHC.KindedTyVar _ n ty) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated n
+ mark GHC.AnnDcolon -- '::'
+ markLocated ty
+ mark GHC.AnnCloseP -- '('
+
+ markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsType GHC.GhcPs) where
+ markAST loc ty = do
+ inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt
+ markType loc ty
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
+ where
+
+ -- markType :: GHC.SrcSpan -> ast -> Annotated ()
+ markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated ()
+ markType _ (GHC.HsForAllTy _ fvf tvs typ) = do
+ mark GHC.AnnForall
+ mapM_ markLocated tvs
+ case fvf of
+ GHC.ForallInvis -> mark GHC.AnnDot
+ GHC.ForallVis -> mark GHC.AnnRarrow
+ markLocated typ
+
+ markType _ (GHC.HsQualTy _ cxt typ) = do
+ markLocated cxt
+ markLocated typ
+
+ markType _ (GHC.HsTyVar _ promoted name) = do
+ when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote
+ unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name
+
+ markType _ (GHC.HsAppTy _ t1 t2) = do
+ setContext (Set.singleton PrefixOp) $ markLocated t1
+ markLocated t2
+
+ markType _ (GHC.HsAppKindTy l t k) = do
+ setContext (Set.singleton PrefixOp) $ markLocated t
+ markTypeApp l
+ markLocated k
+
+ markType _ (GHC.HsFunTy _ t1 t2) = do
+ markLocated t1
+ mark GHC.AnnRarrow
+ markLocated t2
+ -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT
+
+ markType _ (GHC.HsListTy _ t) = do
+ mark GHC.AnnOpenS -- '['
+ markLocated t
+ mark GHC.AnnCloseS -- ']'
+
+ markType _ (GHC.HsTupleTy _ tt ts) = do
+ case tt of
+ GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '('
+ _ -> markWithString GHC.AnnOpen "(#" -- '(#'
+ markListIntercalateWithFunLevel markLocated 2 ts
+ case tt of
+ GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')'
+ _ -> markWithString GHC.AnnClose "#)" -- '#)'
+
+ markType _ (GHC.HsSumTy _ tys) = do
+ markWithString GHC.AnnOpen "(#"
+ markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys
+ markWithString GHC.AnnClose "#)"
+
+ markType _ (GHC.HsOpTy _ t1 lo t2) = do
+ markLocated t1
+ if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo)
+ then do
+ markOptional GHC.AnnSimpleQuote
+ else do
+ mark GHC.AnnSimpleQuote
+ unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo
+ markLocated t2
+
+ markType _ (GHC.HsParTy _ t) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated t
+ mark GHC.AnnCloseP -- ')'
+
+ markType _ (GHC.HsIParamTy _ n t) = do
+ markLocated n
+ mark GHC.AnnDcolon
+ markLocated t
+
+ markType l (GHC.HsStarTy _ isUnicode) = do
+ if isUnicode
+ then markExternal l GHC.AnnVal "\x2605" -- Unicode star
+ else markExternal l GHC.AnnVal "*"
+
+ markType _ (GHC.HsKindSig _ t k) = do
+ markOptional GHC.AnnOpenP -- '('
+ markLocated t
+ mark GHC.AnnDcolon -- '::'
+ markLocated k
+ markOptional GHC.AnnCloseP -- ')'
+
+ markType l (GHC.HsSpliceTy _ s) = do
+ markAST l s
+
+ markType _ (GHC.HsDocTy _ t ds) = do
+ markLocated t
+ markLocated ds
+
+ markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do
+ case mt of
+ GHC.NoSourceText -> return ()
+ GHC.SourceText src -> do
+ markWithString GHC.AnnOpen src
+ markWithString GHC.AnnClose "#-}"
+ case str of
+ GHC.SrcLazy -> mark GHC.AnnTilde
+ GHC.SrcStrict -> mark GHC.AnnBang
+ GHC.NoSrcStrict -> return ()
+
+ markLocated t
+
+ markType _ (GHC.HsRecTy _ cons) = do
+ mark GHC.AnnOpenC -- '{'
+ markListIntercalate cons
+ mark GHC.AnnCloseC -- '}'
+
+ markType _ (GHC.HsExplicitListTy _ promoted ts) = do
+ when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenS -- "["
+ markListIntercalate ts
+ mark GHC.AnnCloseS -- ']'
+
+ markType _ (GHC.HsExplicitTupleTy _ ts) = do
+ mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenP
+ markListIntercalate ts
+ mark GHC.AnnCloseP
+
+ markType l (GHC.HsTyLit _ lit) = do
+ case lit of
+ (GHC.HsNumTy s v) ->
+ markExternalSourceText l s (show v)
+ (GHC.HsStrTy s v) ->
+ markExternalSourceText l s (show v)
+
+ markType l (GHC.HsWildCardTy _) = do
+ markExternal l GHC.AnnVal "_"
+
+ markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x
+
+
+-- ---------------------------------------------------------------------
+
+-- instance Annotate (GHC.HsAppType GHC.GhcPs) where
+-- markAST _ (GHC.HsAppInfix _ n) = do
+-- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote
+-- setContext (Set.singleton InfixOp) $ markLocated n
+-- markAST _ (GHC.HsAppPrefix _ t) = do
+-- markOptional GHC.AnnTilde
+-- setContext (Set.singleton PrefixOp) $ markLocated t
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsSplice GHC.GhcPs) where
+ markAST l c =
+ case c of
+ GHC.HsQuasiQuote _ _ n _pos fs -> do
+ markExternal l GHC.AnnVal
+ -- Note: Lexer.x does not provide unicode alternative. 2017-02-26
+ ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")
+
+ GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE
+ if (hasParens == GHC.HasDollar)
+ then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))
+ else markLocated b
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+ GHC.HsTypedSplice _ hasParens _n b -> do
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE
+ markLocated b
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+ -- -------------------------------
+
+ GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE
+ if (hasParens == GHC.HasDollar)
+ then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))
+ else markLocated b
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+ GHC.HsUntypedSplice _ hasParens _n b -> do
+ case hasParens of
+ GHC.HasParens -> mark GHC.AnnOpenPE
+ GHC.HasDollar -> mark GHC.AnnThIdSplice
+ GHC.NoParens -> return ()
+ markLocated b
+ when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP
+
+ GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC"
+ GHC.HsSplicedT{} -> error "HsSplicedT only exists between renamer and typechecker in GHC"
+
+ -- -------------------------------
+
+ (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ConDeclField GHC.GhcPs) where
+ markAST _ (GHC.ConDeclField _ ns ty mdoc) = do
+ unsetContext Intercalate $ do
+ markListIntercalate ns
+ mark GHC.AnnDcolon
+ markLocated ty
+ markMaybe mdoc
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+ markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FieldOcc GHC.GhcPs) where
+ markAST _ (GHC.FieldOcc _ rn) = do
+ markLocated rn
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+ markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.HsDocString where
+ markAST l s = do
+ markExternal l GHC.AnnVal (GHC.unpackHDS s)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.Pat GHC.GhcPs) where
+ markAST loc typ = do
+ markPat loc typ
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat")
+ where
+ markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"
+ markPat l (GHC.VarPat _ n) = do
+ -- The parser inserts a placeholder value for a record pun rhs. This must be
+ -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is
+ -- resolved, particularly for pretty printing where annotations are added.
+ let pun_RDR = "pun-right-hand-side"
+ when (showGhc n /= pun_RDR) $
+ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n)
+ -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n
+ markPat _ (GHC.LazyPat _ p) = do
+ mark GHC.AnnTilde
+ markLocated p
+
+ markPat _ (GHC.AsPat _ ln p) = do
+ markLocated ln
+ mark GHC.AnnAt
+ markLocated p
+
+ markPat _ (GHC.ParPat _ p) = do
+ mark GHC.AnnOpenP
+ markLocated p
+ mark GHC.AnnCloseP
+
+ markPat _ (GHC.BangPat _ p) = do
+ mark GHC.AnnBang
+ markLocated p
+
+ markPat _ (GHC.ListPat _ ps) = do
+ mark GHC.AnnOpenS
+ markListIntercalateWithFunLevel markLocated 2 ps
+ mark GHC.AnnCloseS
+
+ markPat _ (GHC.TuplePat _ pats b) = do
+ if b == GHC.Boxed then mark GHC.AnnOpenP
+ else markWithString GHC.AnnOpen "(#"
+ markListIntercalateWithFunLevel markLocated 2 pats
+ if b == GHC.Boxed then mark GHC.AnnCloseP
+ else markWithString GHC.AnnClose "#)"
+
+ markPat _ (GHC.SumPat _ pat alt arity) = do
+ markWithString GHC.AnnOpen "(#"
+ replicateM_ (alt - 1) $ mark GHC.AnnVbar
+ markLocated pat
+ replicateM_ (arity - alt) $ mark GHC.AnnVbar
+ markWithString GHC.AnnClose "#)"
+
+ markPat _ (GHC.ConPatIn n dets) = do
+ markHsConPatDetails n dets
+
+ markPat _ GHC.ConPatOut {} =
+ traceM "warning: ConPatOut Introduced after renaming"
+
+ markPat _ (GHC.ViewPat _ e pat) = do
+ markLocated e
+ mark GHC.AnnRarrow
+ markLocated pat
+
+ markPat l (GHC.SplicePat _ s) = do
+ markAST l s
+
+ markPat l (GHC.LitPat _ lp) = markAST l lp
+
+ markPat _ (GHC.NPat _ ol mn _) = do
+ when (isJust mn) $ mark GHC.AnnMinus
+ markLocated ol
+
+ markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do
+ markLocated ln
+ markWithString GHC.AnnVal "+" -- "+"
+ markLocated ol
+
+
+ markPat _ (GHC.SigPat _ pat ty) = do
+ markLocated pat
+ mark GHC.AnnDcolon
+ markLHsSigWcType ty
+
+ markPat _ GHC.CoPat {} =
+ traceM "warning: CoPat introduced after renaming"
+
+ -- markPat _ (GHC.XPat (GHC.L l p)) = markPat l p
+ markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+hsLit2String :: GHC.HsLit GHC.GhcPs -> String
+hsLit2String lit =
+ case lit of
+ GHC.HsChar src v -> toSourceTextWithSuffix src v ""
+ -- It should be included here
+ -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471
+ GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#"
+ GHC.HsString src v -> toSourceTextWithSuffix src v ""
+ GHC.HsStringPrim src v -> toSourceTextWithSuffix src v ""
+ GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v ""
+ GHC.HsIntPrim src v -> toSourceTextWithSuffix src v ""
+ GHC.HsWordPrim src v -> toSourceTextWithSuffix src v ""
+ GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v ""
+ GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v ""
+ GHC.HsInteger src v _ -> toSourceTextWithSuffix src v ""
+ GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v ""
+ GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#"
+ GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##"
+ (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x
+
+toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String
+toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix
+toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix
+
+-- --------------------------------------------------------------------
+
+markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated ()
+markHsConPatDetails ln dets = do
+ case dets of
+ GHC.PrefixCon args -> do
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mapM_ markLocated args
+ GHC.RecCon (GHC.HsRecFields fs dd) -> do
+ markLocated ln
+ mark GHC.AnnOpenC -- '{'
+ case dd of
+ Nothing -> markListIntercalateWithFunLevel markLocated 2 fs
+ Just _ -> do
+ setContext (Set.singleton Intercalate) $ mapM_ markLocated fs
+ mark GHC.AnnDotdot
+ mark GHC.AnnCloseC -- '}'
+ GHC.InfixCon a1 a2 -> do
+ markLocated a1
+ unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln
+ markLocated a2
+
+markHsConDeclDetails ::
+ Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated ()
+
+markHsConDeclDetails isDeprecated inGadt lns dets = do
+ case dets of
+ GHC.PrefixCon args ->
+ setContext (Set.singleton PrefixOp) $ mapM_ markLocated args
+ -- GHC.RecCon fs -> markLocated fs
+ GHC.RecCon fs -> do
+ mark GHC.AnnOpenC
+ if inGadt
+ then do
+ if isDeprecated
+ then setContext (Set.fromList [InGadt]) $ markLocated fs
+ else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs
+ else do
+ if isDeprecated
+ then markLocated fs
+ else setContext (Set.fromList [InRecCon]) $ markLocated fs
+ GHC.InfixCon a1 a2 -> do
+ markLocated a1
+ setContext (Set.singleton InfixOp) $ mapM_ markLocated lns
+ markLocated a2
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LConDeclField GHC.GhcPs] where
+ markAST _ fs = do
+ markOptional GHC.AnnOpenC -- '{'
+ markListIntercalate fs
+ markOptional GHC.AnnDotdot
+ inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}'
+ inContext (Set.singleton InGadt) $ do
+ mark GHC.AnnRarrow
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsOverLit GHC.GhcPs) where
+ markAST l ol =
+ let str = case GHC.ol_val ol of
+ GHC.HsIntegral (GHC.IL src _ _) -> src
+ GHC.HsFractional (GHC.FL src _ _) -> src
+ GHC.HsIsString src _ -> src
+ in
+ markExternalSourceText l str ""
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate arg)
+ => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where
+ markAST _ (GHC.HsIB _ thing) = do
+ markLocated thing
+ markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where
+
+ markAST _ (GHC.LastStmt _ body _ _)
+ = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
+
+ markAST _ (GHC.BindStmt _ pat body _ _) = do
+ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat
+ mark GHC.AnnLarrow
+ unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
+
+ ifInContext (Set.singleton Intercalate)
+ (mark GHC.AnnComma)
+ (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
+ markTrailingSemi
+
+ markAST _ GHC.ApplicativeStmt{}
+ = error "ApplicativeStmt should not appear in ParsedSource"
+
+ markAST _ (GHC.BodyStmt _ body _ _) = do
+ unsetContext Intercalate $ markLocated body
+ inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+ inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
+ markTrailingSemi
+
+ markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do
+ mark GHC.AnnLet
+ markOptional GHC.AnnOpenC -- '{'
+ markInside GHC.AnnSemi
+ markLocalBindsWithLayout lb
+ markOptional GHC.AnnCloseC -- '}'
+ ifInContext (Set.singleton Intercalate)
+ (mark GHC.AnnComma)
+ (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
+ markTrailingSemi
+
+ markAST l (GHC.ParStmt _ pbs _ _) = do
+ -- Within a given parallel list comprehension,one of the sections to be done
+ -- in parallel. It is a normal list comprehension, so has a list of
+ -- ParStmtBlock, one for each part of the sub- list comprehension
+
+
+ ifInContext (Set.singleton Intercalate)
+ (
+
+ unsetContext Intercalate $
+ markListWithContextsFunction
+ (LC (Set.singleton Intercalate) -- only
+ Set.empty -- first
+ Set.empty -- middle
+ (Set.singleton Intercalate) -- last
+ ) (markAST l) pbs
+ )
+ (
+ unsetContext Intercalate $
+ markListWithContextsFunction
+ (LC Set.empty -- only
+ (Set.fromList [AddVbar]) -- first
+ (Set.fromList [AddVbar]) -- middle
+ Set.empty -- last
+ ) (markAST l) pbs
+ )
+ markTrailingSemi
+
+ markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do
+ setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts
+ case form of
+ GHC.ThenForm -> do
+ mark GHC.AnnThen
+ unsetContext Intercalate $ markLocated using
+ case by of
+ Just b -> do
+ mark GHC.AnnBy
+ unsetContext Intercalate $ markLocated b
+ Nothing -> return ()
+ GHC.GroupForm -> do
+ mark GHC.AnnThen
+ mark GHC.AnnGroup
+ case by of
+ Just b -> mark GHC.AnnBy >> markLocated b
+ Nothing -> return ()
+ mark GHC.AnnUsing
+ markLocated using
+ inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+ inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
+ markTrailingSemi
+
+ markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do
+ mark GHC.AnnRec
+ markOptional GHC.AnnOpenC
+ markInside GHC.AnnSemi
+ markListWithLayout stmts
+ markOptional GHC.AnnCloseC
+ inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+ inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
+ markTrailingSemi
+
+ markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- Note: We never have a located ParStmtBlock, so have nothing to hang the
+-- annotation on. This means there is no pushing of context from the parent ParStmt.
+instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where
+ markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do
+ markListIntercalate stmts
+ markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where
+ markAST _ lb = markHsLocalBinds lb
+
+-- ---------------------------------------------------------------------
+
+markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()
+markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) =
+ applyListAnnotationsLayout
+ (prepareListAnnotation (GHC.bagToList binds)
+ ++ prepareListAnnotation sigs
+ )
+markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds
+markHsLocalBinds GHC.EmptyLocalBinds{} = return ()
+
+markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension"
+markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension"
+markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension"
+
+-- ---------------------------------------------------------------------
+
+markMatchGroup :: (Annotate body)
+ => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body)
+ -> Annotated ()
+markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _)
+ = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches
+markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+ => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where
+ markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsExpr GHC.GhcPs) where
+ markAST loc expr = do
+ markExpr loc expr
+ inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+ -- TODO: If the AnnComma is not needed, revert to markAST
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ where
+ markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do
+ ifInContext (Set.singleton PrefixOp)
+ (setContext (Set.singleton PrefixOp) $ markLocated n)
+ (ifInContext (Set.singleton InfixOp)
+ (setContext (Set.singleton InfixOp) $ markLocated n)
+ (markLocated n)
+ )
+
+ markExpr l (GHC.HsUnboundVar {}) = do
+ ifInContext (Set.fromList [InfixOp])
+ (do mark GHC.AnnBackquote
+ markWithString GHC.AnnVal "_"
+ mark GHC.AnnBackquote)
+ (markExternal l GHC.AnnVal "_")
+
+ markExpr l (GHC.HsRecFld _ f) = markAST l f
+
+ markExpr l (GHC.HsOverLabel _ _ fs)
+ = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)
+
+
+ markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) =
+ markAST l n
+ markExpr l (GHC.HsOverLit _ ov) = markAST l ov
+ markExpr l (GHC.HsLit _ lit) = markAST l lit
+
+ markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do
+ setContext (Set.singleton LambdaExpr) $ do
+ -- TODO: Change this, HsLam binds do not need obey layout rules.
+ -- And will only ever have a single match
+ markLocated match
+ markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match"
+
+ markExpr l (GHC.HsLamCase _ match) = do
+ mark GHC.AnnLam
+ mark GHC.AnnCase
+ markOptional GHC.AnnSemi
+ markOptional GHC.AnnOpenC
+ setContext (Set.singleton CaseAlt) $ do
+ markMatchGroup l match
+ markOptional GHC.AnnCloseC
+
+ markExpr _ (GHC.HsApp _ e1 e2) = do
+ setContext (Set.singleton PrefixOp) $ markLocated e1
+ setContext (Set.singleton PrefixOp) $ markLocated e2
+
+ -- -------------------------------
+
+ markExpr _ (GHC.OpApp _ e1 e2 e3) = do
+ let
+ isInfix = case e2 of
+ -- TODO: generalise this. Is it a fixity thing?
+ GHC.L _ (GHC.HsVar{}) -> True
+ _ -> False
+
+ normal =
+ -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context
+ ifInContext (Set.singleton LeftMost)
+ (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1)
+ (markLocated e1)
+
+ if isInfix
+ then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1
+ else normal
+
+ unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2
+
+ if isInfix
+ then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3
+ else markLocated e3
+
+ -- -------------------------------
+
+ markExpr _ (GHC.NegApp _ e _) = do
+ mark GHC.AnnMinus
+ markLocated e
+
+ markExpr _ (GHC.HsPar _ e) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated e
+ mark GHC.AnnCloseP -- ')'
+
+ markExpr _ (GHC.SectionL _ e1 e2) = do
+ markLocated e1
+ setContext (Set.singleton InfixOp) $ markLocated e2
+
+ markExpr _ (GHC.SectionR _ e1 e2) = do
+ setContext (Set.singleton InfixOp) $ markLocated e1
+ markLocated e2
+
+ markExpr _ (GHC.ExplicitTuple _ args b) = do
+ if b == GHC.Boxed then mark GHC.AnnOpenP
+ else markWithString GHC.AnnOpen "(#"
+
+ setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args
+
+ if b == GHC.Boxed then mark GHC.AnnCloseP
+ else markWithString GHC.AnnClose "#)"
+
+ markExpr _ (GHC.ExplicitSum _ alt arity e) = do
+ markWithString GHC.AnnOpen "(#"
+ replicateM_ (alt - 1) $ mark GHC.AnnVbar
+ markLocated e
+ replicateM_ (arity - alt) $ mark GHC.AnnVbar
+ markWithString GHC.AnnClose "#)"
+
+ markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do
+ mark GHC.AnnCase
+ setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1
+ mark GHC.AnnOf
+ markOptional GHC.AnnOpenC
+ markInside GHC.AnnSemi
+ setContext (Set.singleton CaseAlt) $ markMatchGroup l matches
+ markOptional GHC.AnnCloseC
+
+ -- We set the layout for HsIf even though it need not obey layout rules as
+ -- when moving these expressions it's useful that they maintain "internal
+ -- integrity", that is to say the subparts remain indented relative to each
+ -- other.
+ markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do
+ -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do
+ mark GHC.AnnIf
+ markLocated e1
+ markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen
+ mark GHC.AnnThen
+ setContextLevel (Set.singleton ListStart) 2 $ markLocated e2
+ markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse
+ mark GHC.AnnElse
+ setContextLevel (Set.singleton ListStart) 2 $ markLocated e3
+
+ markExpr _ (GHC.HsMultiIf _ rhs) = do
+ mark GHC.AnnIf
+ markOptional GHC.AnnOpenC
+ setContext (Set.singleton CaseAlt) $ do
+ -- mapM_ markLocated rhs
+ markListWithLayout rhs
+ markOptional GHC.AnnCloseC
+
+ markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do
+ setLayoutFlag (do -- Make sure the 'in' gets indented too
+ mark GHC.AnnLet
+ markOptional GHC.AnnOpenC
+ markInside GHC.AnnSemi
+ markLocalBindsWithLayout binds
+ markOptional GHC.AnnCloseC
+ mark GHC.AnnIn
+ markLocated e)
+
+ -- -------------------------------
+
+ markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do
+ case cts of
+ GHC.DoExpr -> mark GHC.AnnDo
+ GHC.MDoExpr -> mark GHC.AnnMdo
+ _ -> return ()
+ let (ostr,cstr) =
+ if isListComp cts
+ then ("[", "]")
+ else ("{", "}")
+
+ when (isListComp cts) $ markWithString GHC.AnnOpen ostr
+ markOptional GHC.AnnOpenS
+ markOptional GHC.AnnOpenC
+ markInside GHC.AnnSemi
+ if isListComp cts
+ then do
+ markLocated (last es)
+ mark GHC.AnnVbar
+ setLayoutFlag (markListIntercalate (init es))
+ else do
+ markListWithLayout es
+ markOptional GHC.AnnCloseS
+ markOptional GHC.AnnCloseC
+ when (isListComp cts) $ markWithString GHC.AnnClose cstr
+
+ -- -------------------------------
+
+ markExpr _ (GHC.ExplicitList _ _ es) = do
+ mark GHC.AnnOpenS
+ setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es
+ mark GHC.AnnCloseS
+
+ markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do
+ markLocated n
+ mark GHC.AnnOpenC
+ case dd of
+ Nothing -> markListIntercalate fs
+ Just _ -> do
+ setContext (Set.singleton Intercalate) $ mapM_ markLocated fs
+ mark GHC.AnnDotdot
+ mark GHC.AnnCloseC
+
+ markExpr _ (GHC.RecordUpd _ e fs) = do
+ markLocated e
+ mark GHC.AnnOpenC
+ markListIntercalate fs
+ mark GHC.AnnCloseC
+
+ markExpr _ (GHC.ExprWithTySig _ e typ) = do
+ setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e
+ mark GHC.AnnDcolon
+ markLHsSigWcType typ
+
+ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do
+ mark GHC.AnnOpenS -- '['
+ case seqInfo of
+ GHC.From e -> do
+ markLocated e
+ mark GHC.AnnDotdot
+ GHC.FromTo e1 e2 -> do
+ markLocated e1
+ mark GHC.AnnDotdot
+ markLocated e2
+ GHC.FromThen e1 e2 -> do
+ markLocated e1
+ mark GHC.AnnComma
+ markLocated e2
+ mark GHC.AnnDotdot
+ GHC.FromThenTo e1 e2 e3 -> do
+ markLocated e1
+ mark GHC.AnnComma
+ markLocated e2
+ mark GHC.AnnDotdot
+ markLocated e3
+ mark GHC.AnnCloseS -- ']'
+
+ markExpr _ (GHC.HsSCC _ src csFStr e) = do
+ markAnnOpen src "{-# SCC"
+ let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
+ markWithStringOptional GHC.AnnVal txt
+ markWithString GHC.AnnValStr txt
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+
+ markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do
+ -- markWithString GHC.AnnOpen src -- "{-# CORE"
+ markAnnOpen src "{-# CORE"
+ -- markWithString GHC.AnnVal (GHC.sl_st csFStr)
+ markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+ -- TODO: make monomorphic
+ markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do
+ mark GHC.AnnSimpleQuote
+ setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v)
+ markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do
+ mark GHC.AnnThTyQuote
+ markLocatedFromKw GHC.AnnName (GHC.L l v)
+ markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do
+ markWithString GHC.AnnOpen "[d|"
+ markOptional GHC.AnnOpenC
+ setContext (Set.singleton NoAdvanceLine)
+ $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds
+ markOptional GHC.AnnCloseC
+ mark GHC.AnnCloseQ -- "|]"
+ -- Introduced after the renamer
+ markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) =
+ traceM "warning: DecBrG introduced after renamer"
+ markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do
+ mark GHC.AnnOpenEQ -- "[|"
+ markOptional GHC.AnnOpenE -- "[e|"
+ markLocated e
+ mark GHC.AnnCloseQ -- "|]"
+ markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do
+ markWithString GHC.AnnOpen "[||"
+ markWithStringOptional GHC.AnnOpenE "[e||"
+ markLocated e
+ markWithString GHC.AnnClose "||]"
+ markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do
+ markWithString GHC.AnnOpen "[t|"
+ markLocated e
+ mark GHC.AnnCloseQ -- "|]"
+ markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do
+ markWithString GHC.AnnOpen "[p|"
+ markLocated e
+ mark GHC.AnnCloseQ -- "|]"
+
+ markExpr _ (GHC.HsRnBracketOut {}) =
+ traceM "warning: HsRnBracketOut introduced after renamer"
+ markExpr _ (GHC.HsTcBracketOut {}) =
+ traceM "warning: HsTcBracketOut introduced after renamer"
+
+ markExpr l (GHC.HsSpliceE _ e) = markAST l e
+
+ markExpr _ (GHC.HsProc _ p c) = do
+ mark GHC.AnnProc
+ markLocated p
+ mark GHC.AnnRarrow
+ markLocated c
+
+ markExpr _ (GHC.HsStatic _ e) = do
+ mark GHC.AnnStatic
+ markLocated e
+
+ -- markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do
+ -- -- isRightToLeft True => right-to-left (f -< arg)
+ -- -- False => left-to-right (arg >- f)
+ -- if isRightToLeft
+ -- then do
+ -- markLocated e1
+ -- case o of
+ -- GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail
+ -- GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail
+ -- else do
+ -- markLocated e2
+ -- case o of
+ -- GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail
+ -- GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail
+
+ -- if isRightToLeft
+ -- then markLocated e2
+ -- else markLocated e1
+
+ -- markExpr _ (GHC.HsArrForm _ e _ cs) = do
+ -- markWithString GHC.AnnOpenB "(|"
+ -- markLocated e
+ -- mapM_ markLocated cs
+ -- markWithString GHC.AnnCloseB "|)"
+
+ markExpr _ (GHC.HsTick {}) = return ()
+ markExpr _ (GHC.HsBinTick {}) = return ()
+
+ markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do
+ -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+ markAnnOpen src "{-# GENERATED"
+ markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING
+
+ let
+ markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v)
+ markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s
+
+ markOne 1 v1 s1 -- INTEGER
+ markOffset GHC.AnnColon 0 -- ':'
+ markOne 2 v2 s2 -- INTEGER
+ mark GHC.AnnMinus -- '-'
+ markOne 3 v3 s3 -- INTEGER
+ markOffset GHC.AnnColon 1 -- ':'
+ markOne 4 v4 s4 -- INTEGER
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+
+ -- markExpr _ (GHC.EAsPat _ ln e) = do
+ -- markLocated ln
+ -- mark GHC.AnnAt
+ -- markLocated e
+
+ -- markExpr _ (GHC.EViewPat _ e1 e2) = do
+ -- markLocated e1
+ -- mark GHC.AnnRarrow
+ -- markLocated e2
+
+ -- markExpr _ (GHC.ELazyPat _ e) = do
+ -- mark GHC.AnnTilde
+ -- markLocated e
+
+ markExpr _ (GHC.HsAppType _ e ty) = do
+ markLocated e
+ markInstead GHC.AnnAt AnnTypeApp
+ markLHsWcType ty
+
+ markExpr _ (GHC.HsWrap {}) =
+ traceM "warning: HsWrap introduced after renaming"
+
+ markExpr _ (GHC.HsConLikeOut{}) =
+ traceM "warning: HsConLikeOut introduced after type checking"
+
+ markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension"
+ markExpr _ (GHC.XExpr _) = error "markExpr got extension"
+
+-- ---------------------------------------------------------------------
+
+markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated ()
+markLHsWcType (GHC.HsWC _ ty) = do
+ markLocated ty
+markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsLit GHC.GhcPs) where
+ markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where
+ markAST _ (GHC.HsRecField lbl expr punFlag) = do
+ unsetContext Intercalate $ markLocated lbl
+ when (punFlag == False) $ do
+ mark GHC.AnnEqual
+ unsetContext Intercalate $ markLocated expr
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where
+ markAST _ (GHC.Unambiguous _ n) = markLocated n
+ markAST _ (GHC.Ambiguous _ n) = markLocated n
+ markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- |Used for declarations that need to be aligned together, e.g. in a
+-- do or let .. in statement/expr
+instance Annotate [GHC.ExprLStmt GHC.GhcPs] where
+ markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsTupArg GHC.GhcPs) where
+ markAST _ (GHC.Present _ (GHC.L l e)) = do
+ markLocated (GHC.L l e)
+ inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma)
+
+ markAST _ (GHC.Missing _) = do
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+ markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsCmdTop GHC.GhcPs) where
+ markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd
+ markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x
+
+instance Annotate (GHC.HsCmd GHC.GhcPs) where
+ markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do
+ -- isRightToLeft True => right-to-left (f -< arg)
+ -- False => left-to-right (arg >- f)
+ if isRightToLeft
+ then do
+ markLocated e1
+ case o of
+ GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail
+ GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail
+ else do
+ markLocated e2
+ case o of
+ GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail
+ GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail
+
+ if isRightToLeft
+ then markLocated e2
+ else markLocated e1
+
+ markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do
+ -- The AnnOpen should be marked for a prefix usage, not for a postfix one,
+ -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm
+
+ let isPrefixOp = case fixity of
+ GHC.Infix -> False
+ GHC.Prefix -> True
+ when isPrefixOp $ mark GHC.AnnOpenB -- "(|"
+
+ -- This may be an infix operation
+ applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp)
+ (Set.singleton InfixOp) (Set.singleton InfixOp))
+ (prepareListAnnotation [e]
+ ++ prepareListAnnotation cs)
+ when isPrefixOp $ mark GHC.AnnCloseB -- "|)"
+
+ markAST _ (GHC.HsCmdApp _ e1 e2) = do
+ markLocated e1
+ markLocated e2
+
+ markAST l (GHC.HsCmdLam _ match) = do
+ setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match
+
+ markAST _ (GHC.HsCmdPar _ e) = do
+ mark GHC.AnnOpenP
+ markLocated e
+ mark GHC.AnnCloseP -- ')'
+
+ markAST l (GHC.HsCmdCase _ e1 matches) = do
+ mark GHC.AnnCase
+ markLocated e1
+ mark GHC.AnnOf
+ markOptional GHC.AnnOpenC
+ setContext (Set.singleton CaseAlt) $ do
+ markMatchGroup l matches
+ markOptional GHC.AnnCloseC
+
+ markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do
+ mark GHC.AnnIf
+ markLocated e1
+ markOffset GHC.AnnSemi 0
+ mark GHC.AnnThen
+ markLocated e2
+ markOffset GHC.AnnSemi 1
+ mark GHC.AnnElse
+ markLocated e3
+
+ markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do
+ mark GHC.AnnLet
+ markOptional GHC.AnnOpenC
+ markLocalBindsWithLayout binds
+ markOptional GHC.AnnCloseC
+ mark GHC.AnnIn
+ markLocated e
+
+ markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do
+ mark GHC.AnnDo
+ markOptional GHC.AnnOpenC
+ markListWithLayout es
+ markOptional GHC.AnnCloseC
+
+ markAST _ (GHC.HsCmdWrap {}) =
+ traceM "warning: HsCmdWrap introduced after renaming"
+
+ markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where
+ markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyClDecl GHC.GhcPs) where
+
+ markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi
+{-
+ SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs
+ , tcdLName :: Located (IdP pass) -- ^ Type constructor
+ , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an
+ -- associated type these
+ -- include outer binders
+ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , tcdRhs :: LHsType pass } -- ^ RHS of type declaration
+
+-}
+ markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do
+ -- There may be arbitrary parens around parts of the constructor that are
+ -- infix.
+ -- Turn these into comments so that they feed into the right place automatically
+ -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+ mark GHC.AnnType
+
+ markTyClass Nothing fixity ln tyvars
+ mark GHC.AnnEqual
+ markLocated typ
+ markTrailingSemi
+
+ markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity
+ (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do
+ if nd == GHC.DataType
+ then mark GHC.AnnData
+ else mark GHC.AnnNewtype
+ markMaybe mctyp
+ markLocated ctx
+ markTyClass Nothing fixity ln tyVars
+ case mk of
+ Nothing -> return ()
+ Just k -> do
+ mark GHC.AnnDcolon
+ markLocated k
+ if isGadt cons
+ then mark GHC.AnnWhere
+ else unless (null cons) $ mark GHC.AnnEqual
+ markOptional GHC.AnnWhere
+ markOptional GHC.AnnOpenC
+ setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace)
+ $ markListWithContexts' listContexts cons
+ markOptional GHC.AnnCloseC
+ setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs
+ markTrailingSemi
+
+ -- -----------------------------------
+
+ markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds
+ sigs meths ats atdefs docs) = do
+ mark GHC.AnnClass
+ markLocated ctx
+
+ markTyClass Nothing fixity ln tyVars
+
+ unless (null fds) $ do
+ mark GHC.AnnVbar
+ markListIntercalateWithFunLevel markLocated 2 fds
+ mark GHC.AnnWhere
+ markOptional GHC.AnnOpenC -- '{'
+ markInside GHC.AnnSemi
+ -- AZ:TODO: we end up with both the tyVars and the following body of the
+ -- class defn in annSortKey for the class. This could cause problems when
+ -- changing things.
+ setContext (Set.singleton InClassDecl) $
+ applyListAnnotationsLayout
+ (prepareListAnnotation sigs
+ ++ prepareListAnnotation (GHC.bagToList meths)
+ ++ prepareListAnnotation ats
+ ++ prepareListAnnotation atdefs
+ ++ prepareListAnnotation docs
+ )
+ markOptional GHC.AnnCloseC -- '}'
+ markTrailingSemi
+{-
+ | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs
+ tcdCtxt :: LHsContext pass, -- ^ Context...
+ tcdLName :: Located (IdP pass), -- ^ Name of the class
+ tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables
+ tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
+ tcdFDs :: [Located (FunDep (Located (IdP pass)))],
+ -- ^ Functional deps
+ tcdSigs :: [LSig pass], -- ^ Methods' signatures
+ tcdMeths :: LHsBinds pass, -- ^ Default methods
+ tcdATs :: [LFamilyDecl pass], -- ^ Associated types;
+ tcdATDefs :: [LTyFamDefltEqn pass],
+ -- ^ Associated type defaults
+ tcdDocs :: [LDocDecl] -- ^ Haddock docs
+ }
+
+-}
+
+ markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _)
+ = error "extension hit for TyClDecl"
+ markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _))
+ = error "extension hit for TyClDecl"
+ markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _)
+ = error "extension hit for TyClDecl"
+ markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _)
+ = error "extension hit for TyClDecl"
+ markAST _ (GHC.XTyClDecl _)
+ = error "extension hit for TyClDecl"
+
+-- ---------------------------------------------------------------------
+
+markTypeApp :: GHC.SrcSpan -> Annotated ()
+markTypeApp loc = do
+ let l = GHC.srcSpanFirstCharacter loc
+ markExternal l GHC.AnnVal "@"
+
+-- ---------------------------------------------------------------------
+
+markTyClassArgs :: (Annotate a)
+ => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity
+ -- -> GHC.Located a -> [ast] -> Annotated ()
+ -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated ()
+markTyClassArgs mbndrs fixity ln tyVars = do
+ let
+ cvt (GHC.HsValArg val) = markLocated val
+ cvt (GHC.HsTypeArg loc typ) = do
+ markTypeApp loc
+ -- let l = GHC.srcSpanFirstCharacter loc
+ -- markExternal l GHC.AnnVal "@"
+ markLocated typ
+ cvt (GHC.HsArgPar _ss) = undefined
+ markTyClassWorker cvt mbndrs fixity ln tyVars
+ {-
+type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
+
+data HsArg tm ty
+ = HsValArg tm -- Argument is an ordinary expression (f arg)
+ | HsTypeArg ty -- Argument is a visible type application (f @ty)
+ | HsArgPar SrcSpan -- See Note [HsArgPar]
+-}
+
+-- TODO:AZ: simplify
+markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, Annotate ast,GHC.HasSrcSpan ast)
+ => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity
+ -> GHC.Located a -> [ast] -> Annotated ()
+markTyClass = markTyClassWorker markLocated
+
+markTyClassWorker :: (Annotate a)
+ => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity
+ -- -> GHC.Located a -> [ast] -> Annotated ()
+ -> GHC.Located a -> [b] -> Annotated ()
+markTyClassWorker markFn mbndrs fixity ln tyVars = do
+ let processBinders =
+ case mbndrs of
+ Nothing -> return ()
+ Just bndrs -> do
+ mark GHC.AnnForall
+ mapM_ markLocated bndrs
+ mark GHC.AnnDot
+
+ -- There may be arbitrary parens around parts of the constructor
+ -- Turn these into comments so that they feed into the right place automatically
+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+ let markParens = if fixity == GHC.Infix && length tyVars > 2
+ then markMany
+ else markManyOptional
+ if fixity == GHC.Prefix
+ then do
+ markManyOptional GHC.AnnOpenP
+ processBinders
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars
+ setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars
+ when (length tyVars >= 2) $ do
+ markParens GHC.AnnCloseP
+ setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars
+ markManyOptional GHC.AnnCloseP
+ else do
+ case tyVars of
+ (x:y:xs) -> do
+ markParens GHC.AnnOpenP
+ processBinders
+ markFn x
+ setContext (Set.singleton InfixOp) $ markLocated ln
+ markFn y
+ markParens GHC.AnnCloseP
+ mapM_ markFn xs
+ markManyOptional GHC.AnnCloseP
+ _ -> error $ "markTyClass: Infix op without operands"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where
+ markAST _ ds = mapM_ markLocated ds
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where
+ markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do
+ mark GHC.AnnDeriving
+ case mstrategy of
+ Nothing -> return ()
+ Just (GHC.L _ (GHC.ViaStrategy{})) -> return ()
+ Just s -> markLocated s
+ markLocated typs
+ case mstrategy of
+ Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s
+ _ -> return ()
+
+ markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x
+
+{-
+ = HsDerivingClause
+ { deriv_clause_ext :: XCHsDerivingClause pass
+ , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
+ -- ^ The user-specified strategy (if any) to use when deriving
+ -- 'deriv_clause_tys'.
+ , deriv_clause_tys :: Located [LHsSigType pass]
+ -- ^ The types to derive.
+ --
+ -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
+ -- we can mention type variables that aren't bound by the datatype, e.g.
+ --
+ -- > data T b = ... deriving (C [a])
+ --
+ -- should produce a derived instance for @C [a] (T b)@.
+ }
+
+-}
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FamilyDecl GHC.GhcPs) where
+ markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do
+ case info of
+ GHC.DataFamily -> mark GHC.AnnData
+ _ -> mark GHC.AnnType
+
+ mark GHC.AnnFamily
+
+ markTyClass Nothing fixity ln tyvars
+ case GHC.unLoc rsig of
+ GHC.NoSig _ -> return ()
+ GHC.KindSig _ _ -> do
+ mark GHC.AnnDcolon
+ markLocated rsig
+ GHC.TyVarSig _ _ -> do
+ mark GHC.AnnEqual
+ markLocated rsig
+ (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x
+ case minj of
+ Nothing -> return ()
+ Just inj -> do
+ mark GHC.AnnVbar
+ markLocated inj
+ case info of
+ GHC.ClosedTypeFamily (Just eqns) -> do
+ mark GHC.AnnWhere
+ markOptional GHC.AnnOpenC -- {
+ markListWithLayout eqns
+ markOptional GHC.AnnCloseC -- }
+ GHC.ClosedTypeFamily Nothing -> do
+ mark GHC.AnnWhere
+ mark GHC.AnnOpenC -- {
+ mark GHC.AnnDotdot
+ mark GHC.AnnCloseC -- }
+ _ -> return ()
+ markTrailingSemi
+
+ markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _)
+ = error "got extension for FamilyDecl"
+ markAST _ (GHC.XFamilyDecl _)
+ = error "got extension for FamilyDecl"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where
+ markAST _ (GHC.NoSig _) = return ()
+ markAST _ (GHC.KindSig _ k) = markLocated k
+ markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv
+ markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where
+ markAST _ (GHC.InjectivityAnn ln lns) = do
+ markLocated ln
+ mark GHC.AnnRarrow
+ mapM_ markLocated lns
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where
+{-
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
+
+type FamInstEqn pass rhs
+ = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+
+type HsTyPats pass = [LHsTypeArg pass]
+
+-}
+ markAST _ (GHC.HsIB _ eqn) = do
+ markFamEqn eqn
+ markTrailingSemi
+ markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where
+
+-- markAST _ (GHC.FamEqn _ ln mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do
+-- mark GHC.AnnType
+-- mark GHC.AnnInstance
+-- markTyClass mbndrs fixity ln bndrs
+-- mark GHC.AnnEqual
+-- markLocated typ
+
+ -- markAST _ (GHC.FamEqn _ _ _ (GHC.XLHsQTyVars _) _ _)
+ -- = error "TyFamDefltEqn hit extension point"
+ -- markAST _ (GHC.XFamEqn _)
+ -- = error "TyFamDefltEqn hit extension point"
+
+-- ---------------------------------------------------------------------
+
+-- TODO: modify lexer etc, in the meantime to not set haddock flag
+instance Annotate GHC.DocDecl where
+ markAST l v =
+ let str =
+ case v of
+ (GHC.DocCommentNext ds) -> GHC.unpackHDS ds
+ (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds
+ (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds
+ (GHC.DocGroup _i ds) -> GHC.unpackHDS ds
+ in
+ markExternal l GHC.AnnVal str >> markTrailingSemi
+{-
+data DocDecl
+ = DocCommentNext HsDocString
+ | DocCommentPrev HsDocString
+ | DocCommentNamed String HsDocString
+ | DocGroup Int HsDocString
+
+-}
+
+-- ---------------------------------------------------------------------
+
+markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated ()
+markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do
+ markLocated ctx
+ markMaybe typ
+ if isGadt cons
+ then markListWithLayout cons
+ else markListIntercalateWithFunLevel markLocated 2 cons
+ setContext (Set.singleton Deriving) $ markLocated derivs
+markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- Note: GHC.HsContext name aliases to here too
+instance Annotate [GHC.LHsType GHC.GhcPs] where
+ markAST l ts = do
+ -- Note: A single item in parens in a standalone deriving clause
+ -- is parsed as a HsSigType, which is always a HsForAllTy or
+ -- HsQualTy. Without parens it is always a HsVar. So for round
+ -- trip pretty printing we need to take this into account.
+ let
+ parenIfNeeded' pa =
+ case ts of
+ [] -> if l == GHC.noSrcSpan
+ then markManyOptional pa
+ else markMany pa
+ [GHC.L _ GHC.HsForAllTy{}] -> markMany pa
+ [GHC.L _ GHC.HsQualTy{}] -> markMany pa
+ [_] -> markManyOptional pa
+ _ -> markMany pa
+
+ parenIfNeeded'' pa =
+ ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set?
+ (markMany pa)
+ (parenIfNeeded' pa)
+
+ parenIfNeeded pa =
+ case ts of
+ [GHC.L _ GHC.HsParTy{}] -> markOptional pa
+ _ -> parenIfNeeded'' pa
+
+ -- -------------
+
+ parenIfNeeded GHC.AnnOpenP
+
+ unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts
+
+ parenIfNeeded GHC.AnnCloseP
+
+ ifInContext (Set.singleton NoDarrow)
+ (return ())
+ (if null ts && (l == GHC.noSrcSpan)
+ then markOptional GHC.AnnDarrow
+ else mark GHC.AnnDarrow)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ConDecl GHC.GhcPs) where
+ markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx
+ dets _) = do
+ case mqtvs of
+ [] -> return ()
+ bndrs -> do
+ mark GHC.AnnForall
+ mapM_ markLocated bndrs
+ mark GHC.AnnDot
+
+ case mctx of
+ Just ctx -> do
+ setContext (Set.fromList [NoDarrow]) $ markLocated ctx
+ unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow
+ Nothing -> return ()
+
+ case dets of
+ GHC.InfixCon _ _ -> return ()
+ _ -> setContext (Set.singleton PrefixOp) $ markLocated ln
+
+ markHsConDeclDetails False False [ln] dets
+
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar
+ markTrailingSemi
+{-
+ | ConDeclH98
+ { con_ext :: XConDeclH98 pass
+ , con_name :: Located (IdP pass)
+
+ , con_forall :: Bool -- ^ True <=> explicit user-written forall
+ -- e.g. data T a = forall b. MkT b (b->a)
+ -- con_ex_tvs = {b}
+ -- False => con_ex_tvs is empty
+ , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only
+ , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+ , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon
+
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+ }
+
+-}
+ markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do
+ setContext (Set.singleton PrefixOp) $ markListIntercalate lns
+ mark GHC.AnnDcolon
+ annotationsToComments [GHC.AnnOpenP]
+ markLocated (GHC.L l (ResTyGADTHook forall qvars))
+ markMaybe mbCxt
+ markHsConDeclDetails False True lns args
+ markLocated typ
+ markManyOptional GHC.AnnCloseP
+ markTrailingSemi
+{-
+ = ConDeclGADT
+ { con_g_ext :: XConDeclGADT pass
+ , con_names :: [Located (IdP pass)]
+
+ -- The next four fields describe the type after the '::'
+ -- See Note [GADT abstract syntax]
+ , con_forall :: Located Bool -- ^ True <=> explicit forall
+ -- False => hsq_explicit is empty
+ , con_qvars :: LHsQTyVars pass
+ -- Whether or not there is an /explicit/ forall, we still
+ -- need to capture the implicitly-bound type/kind variables
+
+ , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+ , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon
+ , con_res_ty :: LHsType pass -- ^ Result type
+
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+ }
+
+-}
+
+ markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _)
+ = error "hit extension point in ConDecl"
+ markAST _ (GHC.XConDecl _)
+ = error "hit extension point in ConDecl"
+
+-- ResTyGADT has a SrcSpan for the original sigtype, we need to create
+-- a type for exactPC and annotatePC
+data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs]
+ deriving (Typeable)
+deriving instance Data (ResTyGADTHook)
+
+instance GHC.Outputable ResTyGADTHook where
+ ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs
+
+
+-- WildCardAnon exists because the GHC anonymous wildcard type is defined as
+-- = AnonWildCard (PostRn name Name)
+-- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but
+-- the instance doing this is parameterised on name, so we cannot put a value in
+-- for the (PostRn name Name) field. This is used instead.
+data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable)
+
+instance Annotate WildCardAnon where
+ markAST l WildCardAnon = do
+ markExternal l GHC.AnnVal "_"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate ResTyGADTHook where
+ markAST _ (ResTyGADTHook forall bndrs) = do
+ unless (null bndrs) $ do
+ when forall $ mark GHC.AnnForall
+ mapM_ markLocated bndrs
+ when forall $ mark GHC.AnnDot
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.Located (GHC.Pat GHC.GhcPs))) where
+ markAST _ (GHC.HsRecField n e punFlag) = do
+ unsetContext Intercalate $ markLocated n
+ unless punFlag $ do
+ mark GHC.AnnEqual
+ unsetContext Intercalate $ markLocated e
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+
+-- instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where
+-- markAST _ (GHC.HsRecField n e punFlag) = do
+-- unsetContext Intercalate $ markLocated n
+-- unless punFlag $ do
+-- mark GHC.AnnEqual
+-- unsetContext Intercalate $ markLocated e
+-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+
+instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where
+ markAST _ (GHC.HsRecField n e punFlag) = do
+ unsetContext Intercalate $ markLocated n
+ unless punFlag $ do
+ mark GHC.AnnEqual
+ unsetContext Intercalate $ markLocated e
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where
+
+ markAST _ (ls,rs) = do
+ mapM_ markLocated ls
+ mark GHC.AnnRarrow
+ mapM_ markLocated rs
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.CType where
+ markAST _ (GHC.CType src mh f) = do
+ -- markWithString GHC.AnnOpen src
+ markAnnOpen src ""
+ case mh of
+ Nothing -> return ()
+ Just (GHC.Header srcH _h) ->
+ -- markWithString GHC.AnnHeader srcH
+ markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "")
+ -- markWithString GHC.AnnVal (fst f)
+ markSourceText (fst f) (GHC.unpackFS $ snd f)
+ markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+stringLiteralToString :: GHC.StringLiteral -> String
+stringLiteralToString (GHC.StringLiteral st fs) =
+ case st of
+ GHC.NoSourceText -> GHC.unpackFS fs
+ GHC.SourceText src -> src
diff --git a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs
index a810324..4fffc08 100644
--- a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs
+++ b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs
@@ -819,8 +819,7 @@ instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where
-- ---------------------------------------------------------------------
-markFamEqn :: (GHC.HasOccName (GHC.IdP pass),
- Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)
+markFamEqn :: (Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)
=> GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2)
-> Annotated ()
markFamEqn (GHC.FamEqn _ ln pats fixity rhs) = do
@@ -2398,10 +2397,10 @@ instance Annotate (GHC.TyClDecl GHC.GhcPs) where
= error "extension hit for TyClDecl"
markAST _ (GHC.XTyClDecl _)
= error "extension hit for TyClDecl"
-
+
-- ---------------------------------------------------------------------
-markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)
+markTyClass :: (Annotate a, Annotate ast)
=> GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated ()
markTyClass fixity ln tyVars = do
-- There may be arbitrary parens around parts of the constructor
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
index 829d988..0e78b4b 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -449,7 +449,7 @@ getSrcSpan :: Delta GHC.SrcSpan
getSrcSpan = asks curSrcSpan
#if __GLASGOW_HASKELL__ > 806
-withSrcSpanDelta :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b
+withSrcSpanDelta :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b
withSrcSpanDelta (GHC.dL->GHC.L l a) =
#else
withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b
diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
index 0dd67f2..2d65665 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
@@ -12,6 +12,7 @@
module Language.Haskell.GHC.ExactPrint.Parsers (
-- * Utility
Parser
+ , ParseResult
, withDynFlags
, CppOptions(..)
, defaultCppOptions
@@ -58,13 +59,21 @@ import GHC.Paths (libdir)
import qualified ApiAnnotation as GHC
import qualified DynFlags as GHC
+#if __GLASGOW_HASKELL__ > 808
+import qualified ErrUtils as GHC
+#endif
import qualified FastString as GHC
import qualified GHC as GHC hiding (parseModule)
import qualified HeaderInfo as GHC
import qualified Lexer as GHC
import qualified MonadUtils as GHC
+#if __GLASGOW_HASKELL__ <= 808
import qualified Outputable as GHC
+#endif
import qualified Parser as GHC
+#if __GLASGOW_HASKELL__ > 808
+import qualified RdrHsSyn as GHC
+#endif
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
@@ -89,18 +98,20 @@ parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w)
-> FilePath
-> GHC.P w
-> String
- -> Either (GHC.SrcSpan, String) (Anns, w)
+ -> ParseResult w
#else
parseWith :: Annotate w
=> GHC.DynFlags
-> FilePath
-> GHC.P (GHC.Located w)
-> String
- -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)
+ -> ParseResult (GHC.Located w)
#endif
parseWith dflags fileName parser s =
case runParser parser dflags fileName s of
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 808
+ GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags)
+#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m)
#else
GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m)
@@ -108,6 +119,22 @@ parseWith dflags fileName parser s =
GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod)
where as = relativiseApiAnns pmod apianns
+
+#if __GLASGOW_HASKELL__ > 808
+parseWithECP :: (GHC.DisambECP w, Annotate (GHC.Body w GHC.GhcPs))
+ => GHC.DynFlags
+ -> FilePath
+ -> GHC.P GHC.ECP
+ -> String
+ -> ParseResult (GHC.Located w)
+parseWithECP dflags fileName parser s =
+ -- case runParser ff dflags fileName s of
+ case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of
+ GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags)
+ GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod)
+ where as = relativiseApiAnns pmod apianns
+#endif
+
-- ---------------------------------------------------------------------
runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
@@ -138,12 +165,21 @@ parseFile = runParser GHC.parseModule
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ > 808
+type ParseResult a = Either GHC.ErrorMessages (Anns, a)
+#else
+type ParseResult a = Either (GHC.SrcSpan, String) (Anns, a)
+#endif
+
type Parser a = GHC.DynFlags -> FilePath -> String
- -> Either (GHC.SrcSpan, String)
- (Anns, a)
+ -> ParseResult a
parseExpr :: Parser (GHC.LHsExpr GhcPs)
+#if __GLASGOW_HASKELL__ > 808
+parseExpr df fp = parseWithECP df fp GHC.parseExpression
+#else
parseExpr df fp = parseWith df fp GHC.parseExpression
+#endif
parseImport :: Parser (GHC.LImportDecl GhcPs)
parseImport df fp = parseWith df fp GHC.parseImport
@@ -176,8 +212,7 @@ parsePattern df fp = parseWith df fp GHC.parsePattern
-- @
--
-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs')
-parseModule
- :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))
+parseModule :: FilePath -> IO (ParseResult GHC.ParsedSource)
parseModule = parseModuleWithCpp defaultCppOptions normalLayout
@@ -189,32 +224,29 @@ parseModule = parseModuleWithCpp defaultCppOptions normalLayout
parseModuleFromString
:: FilePath
-> String
- -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))
+ -> IO (ParseResult GHC.ParsedSource)
parseModuleFromString fp s = ghcWrapper $ do
dflags <- initDynFlagsPure fp s
return $ parseModuleFromStringInternal dflags fp s
-- | Internal part of 'parseModuleFromString'.
-parseModuleFromStringInternal
- :: GHC.DynFlags
- -> FilePath
- -> String
- -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)
+parseModuleFromStringInternal :: Parser GHC.ParsedSource
parseModuleFromStringInternal dflags fileName str =
let (str1, lp) = stripLinePragmas str
res = case runParser GHC.parseModule dflags fileName str1 of
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 808
+ GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags)
+#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m)
#else
GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m)
#endif
- GHC.POk x pmod -> Right $ (mkApiAnns x, lp, dflags, pmod)
+ GHC.POk x pmod -> Right (mkApiAnns x, lp, dflags, pmod)
in postParseTransform res normalLayout
parseModuleWithOptions :: DeltaOptions
-> FilePath
- -> IO (Either (GHC.SrcSpan, String)
- (Anns, GHC.ParsedSource))
+ -> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions opts fp =
parseModuleWithCpp defaultCppOptions opts fp
@@ -224,7 +256,7 @@ parseModuleWithCpp
:: CppOptions
-> DeltaOptions
-> FilePath
- -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))
+ -> IO (ParseResult GHC.ParsedSource)
parseModuleWithCpp cpp opts fp = do
res <- parseModuleApiAnnsWithCpp cpp fp
return $ postParseTransform res opts
@@ -239,7 +271,11 @@ parseModuleApiAnnsWithCpp
-> FilePath
-> IO
( Either
+#if __GLASGOW_HASKELL__ > 808
+ GHC.ErrorMessages
+#else
(GHC.SrcSpan, String)
+#endif
(GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
)
parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do
@@ -261,7 +297,11 @@ parseModuleApiAnnsWithCppInternal
-> FilePath
-> m
( Either
+#if __GLASGOW_HASKELL__ > 808
+ GHC.ErrorMessages
+#else
(GHC.SrcSpan, String)
+#endif
(GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
)
parseModuleApiAnnsWithCppInternal cppOptions dflags file = do
@@ -282,7 +322,9 @@ parseModuleApiAnnsWithCppInternal cppOptions dflags file = do
return (contents1,lp,dflags)
return $
case parseFile dflags' file fileContents of
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 808
+ GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags)
+#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m))
#else
GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m))
diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
index 07ec259..2e5cc38 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
@@ -26,11 +26,18 @@ import qualified Lexer as GHC
import qualified MonadUtils as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
+#if __GLASGOW_HASKELL__ > 808
+import qualified Fingerprint as GHC
+import qualified ToolSettings as GHC
+#endif
import SrcLoc (mkSrcSpan, mkSrcLoc)
import FastString (mkFastString)
+#if __GLASGOW_HASKELL__ > 808
+#else
import Control.Exception
+#endif
import Data.List hiding (find)
import Data.Maybe
#if __GLASGOW_HASKELL__ <= 800
@@ -121,7 +128,9 @@ getCppTokensAsComments cppOptions sourceFile = do
#else
$ map (tokComment . commentToAnnotation . fst) cppCommentToks
#endif
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 808
+ GHC.PFailed pst -> parseError flags2 pst
+#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ sspan err -> parseError flags2 sspan err
#else
GHC.PFailed sspan err -> parseError flags2 sspan err
@@ -180,7 +189,9 @@ tokeniseOriginalSrc startLoc flags buf = do
let src = stripPreprocessorDirectives buf
case GHC.lexTokenStream src startLoc flags of
GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 808
+ GHC.PFailed pst -> parseError flags pst
+#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ sspan err -> parseError flags sspan err
#else
GHC.PFailed sspan err -> parseError flags sspan err
@@ -249,12 +260,25 @@ injectCppOptions CppOptions{..} dflags =
mkInclude = ("-include" ++)
+#if __GLASGOW_HASKELL__ > 808
+addOptP :: String -> GHC.DynFlags -> GHC.DynFlags
+addOptP f = alterToolSettings $ \s -> s
+ { GHC.toolSettings_opt_P = f : GHC.toolSettings_opt_P s
+ , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s)
+ }
+alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags
+alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) }
+
+fingerprintStrings :: [String] -> GHC.Fingerprint
+fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss
+
+#else
addOptP :: String -> GHC.DynFlags -> GHC.DynFlags
addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s})
alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags
alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) }
-
+#endif
-- ---------------------------------------------------------------------
-- | Get the preprocessor directives as comment tokens from the
@@ -276,9 +300,18 @@ getPreprocessorAsComments srcFile = do
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ > 808
+parseError :: (GHC.MonadIO m) => GHC.DynFlags -> GHC.PState -> m b
+parseError dflags pst = do
+ let
+ -- (warns,errs) = GHC.getMessages pst dflags
+ -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
+ GHC.throwErrors (GHC.getErrorMessages pst dflags)
+#else
parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b
parseError dflags sspan err = do
throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
+#endif
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
index 7afabbb..01e53a4 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
@@ -314,7 +314,7 @@ putUnallocatedComments cs = modify (\s -> s { apComments = cs } )
-- ---------------------------------------------------------------------
#if __GLASGOW_HASKELL__ > 806
-withSrcSpanPretty :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b
+withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b
withSrcSpanPretty (GHC.dL->GHC.L l a) action = do
#else
withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
index f16091c..9931c7b 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -281,7 +281,9 @@ decl2Sig _ = []
-- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl'
wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.NoExtField s)
+#elif __GLASGOW_HASKELL__ > 804
wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s)
#else
wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)
@@ -291,7 +293,9 @@ wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)
-- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl'
wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.NoExtField s)
+#elif __GLASGOW_HASKELL__ > 804
wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s)
#else
wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)
@@ -543,7 +547,9 @@ balanceComments' first second = do
-- 'GHC.FunBind', these need to be pushed down from the top level to the last
-- 'GHC.Match' if that 'GHC.Match' needs to be manipulated.
balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m ()
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do
+#elif __GLASGOW_HASKELL__ > 804
balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do
#elif __GLASGOW_HASKELL__ > 710
balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do
@@ -1145,7 +1151,9 @@ hsDeclsGeneric t = q t
-- ---------------------------------
lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+ lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do
+#elif __GLASGOW_HASKELL__ > 804
lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do
#elif __GLASGOW_HASKELL__ > 710
lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do
@@ -1230,7 +1238,9 @@ replaceDeclsValbinds :: (Monad m)
=> GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]
-> TransformT m (GHC.HsLocalBinds GhcPs)
replaceDeclsValbinds _ [] = do
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+ return (GHC.EmptyLocalBinds GHC.NoExtField)
+#elif __GLASGOW_HASKELL__ > 804
return (GHC.EmptyLocalBinds GHC.noExt)
#else
return (GHC.EmptyLocalBinds)
@@ -1244,7 +1254,9 @@ replaceDeclsValbinds (GHC.HsValBinds _b) new
logTr "replaceDecls HsLocalBinds"
let decs = GHC.listToBag $ concatMap decl2Bind new
let sigs = concatMap decl2Sig new
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+ return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs))
+#elif __GLASGOW_HASKELL__ > 804
return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))
#else
return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
@@ -1261,7 +1273,9 @@ replaceDeclsValbinds (GHC.EmptyLocalBinds) new
newSigs = map decl2Sig new
let decs = GHC.listToBag $ concat newBinds
let sigs = concat newSigs
-#if __GLASGOW_HASKELL__ > 804
+#if __GLASGOW_HASKELL__ > 808
+ return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs))
+#elif __GLASGOW_HASKELL__ > 804
return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))
#else
return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
index f875a67..b03e6a8 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -43,6 +43,10 @@ module Language.Haskell.GHC.ExactPrint.Types
, GhcRn
, GhcTc
+#if __GLASGOW_HASKELL__ > 804
+ , noExt
+#endif
+
-- * Internal Types
, LayoutStartCol(..)
, declFun
@@ -190,6 +194,15 @@ type GhcRn = GHC.GhcRn
type GhcTc = GHC.GhcTc
#endif
+
+#if __GLASGOW_HASKELL__ > 808
+noExt :: GHC.NoExtField
+noExt = GHC.NoExtField
+#elif __GLASGOW_HASKELL__ > 804
+noExt :: GHC.NoExt
+noExt = GHC.noExt
+#endif
+
-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.
#if __GLASGOW_HASKELL__ > 806
mkAnnKey :: (Constraints a) => a -> AnnKey
@@ -390,6 +403,9 @@ declFun f (GHC.L l de) =
GHC.DerivD _ d -> f (GHC.L l d)
GHC.ValD _ d -> f (GHC.L l d)
GHC.SigD _ d -> f (GHC.L l d)
+#if __GLASGOW_HASKELL__ > 808
+ GHC.KindSigD _ d -> f (GHC.L l d)
+#endif
GHC.DefD _ d -> f (GHC.L l d)
GHC.ForD _ d -> f (GHC.L l d)
GHC.WarningD _ d -> f (GHC.L l d)
diff --git a/tests/PrepareHackage.hs b/tests/PrepareHackage.hs
index 553b01a..b8ddea2 100644
--- a/tests/PrepareHackage.hs
+++ b/tests/PrepareHackage.hs
@@ -1,17 +1,17 @@
{-# LANGUAGE OverloadedStrings #-} --
import Data.Char
-import Data.Monoid
+-- import Data.Monoid
import System.Directory
import System.FilePath.Posix
-import System.IO
+-- import System.IO
import Test.CommonUtils
import Turtle hiding (FilePath,(<.>))
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
-import qualified GHC.IO.Handle.Text as GHC
+-- import qualified GHC.IO.Handle.Text as GHC
import Test.HUnit
@@ -75,15 +75,15 @@ cleanPackage dir = do
-- ---------------------------------------------------------------------
-- | The computation 'writeFile' @file str@ function writes the string @str@,
-- to the file @file@.
-writeFileUtf8 :: FilePath -> String -> IO ()
-writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt)
+-- writeFileUtf8 :: FilePath -> String -> IO ()
+-- writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt)
-- ---------------------------------------------------------------------
-allCabalPackagesTest :: IO [Text]
-allCabalPackagesTest
- = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"]
- -- = return ["airship"]
+-- allCabalPackagesTest :: IO [Text]
+-- allCabalPackagesTest
+-- = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"]
+-- -- = return ["airship"]
allCabalPackages :: IO [Text]
@@ -107,8 +107,8 @@ cleanupWhiteSpace file = do
tabWidth :: Int
tabWidth = 8
-nonBreakingSpace :: Char
-nonBreakingSpace = '\xa0'
+-- nonBreakingSpace :: Char
+-- nonBreakingSpace = '\xa0'
cleanupOneLine :: String -> String
cleanupOneLine str = str'
diff --git a/tests/Roundtrip.hs b/tests/Roundtrip.hs
index e16ac8b..09e7c19 100644
--- a/tests/Roundtrip.hs
+++ b/tests/Roundtrip.hs
@@ -143,7 +143,7 @@ mkParserTest fp =
writeError fp
throwIO e
case r1 of
- Left (ParseFailure _ s) -> do
+ Left (ParseFailure s) -> do
writeParseFail fp s
exitFailure
Right r -> do
diff --git a/tests/Test.hs b/tests/Test.hs
index 0d358cb..b8da36b 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -28,12 +28,14 @@ import Test.HUnit
-- ---------------------------------------------------------------------
-data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88
+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810
deriving (Eq, Ord, Show)
ghcVersion :: GHCVersion
ghcVersion =
-#if __GLASGOW_HASKELL__ > 806
+#if __GLASGOW_HASKELL__ > 808
+ GHC810
+#elif __GLASGOW_HASKELL__ > 806
GHC88
#elif __GLASGOW_HASKELL__ > 804
GHC86
@@ -54,12 +56,13 @@ testDirs =
GHC710 -> ["ghc710-only","ghc710", "vect"]
GHC80 -> [ "ghc710", "ghc80", "vect"]
GHC82 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "vect"]
- GHC84 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ]
- GHC86 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ]
- GHC88 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ]
+ GHC84 -> ["pre-ghc86", "pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ]
+ GHC86 -> ["pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ]
+ GHC88 -> ["pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ]
+ GHC810 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810" ]
- -- GHC88 -> ["ghc88"]
- -- GHC88 -> ["ghc88-copied"]
+ -- GHC810 -> ["ghc810"]
+ -- GHC810 -> ["ghc810-copied"]
-- ---------------------------------------------------------------------
@@ -199,48 +202,17 @@ tr = hSilence [stderr] $ do
tt' :: IO (Counts,Int)
tt' = runTestText (putTextToHandle stdout True) $ TestList [
+ -- mkParserTest "ghc80" "C.hs"
+ -- mkParserTest "ghc80" "T10267.hs"
+ -- , mkParserTest "ghc80" "T10946.hs"
+ -- mkParserTest "ghc82" "T13050.hs"
+ -- mkParserTest "ghc84" "arrowfail003.hs"
+ -- mkParserTest "ghc810" "T17296.hs"
- -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"
- -- mkPrettyRoundtrip "ghc86" "mdo.hs"
-
- -- mkParserTest "ghc88" "DumpParsedast.hs"
- -- mkParserTest "ghc88-copied" "T15365.hs"
- -- mkPrettyRoundtrip "ghc88-copied" "T15365.hs"
- -- mkParserTest "ghc88-copied" "T4437.hs"
-
- -- mkParserTest "ghc88-copied" "TH_recover_warns.hs"
- -- mkPrettyRoundtrip "ghc88-copied" "TH_recover_warns.hs"
-
- -- mkParserTest "ghc88-copied" "TH_recursiveDoImport.hs"
- -- mkPrettyRoundtrip "ghc88-copied" "TH_recursiveDoImport.hs"
-
- -- mkParserTest "ghc88-copied" "dsrun010.hs"
- -- mkPrettyRoundtrip "ghc88-copied" "dsrun010.hs"
-
- -- mkParserTest "ghc88" "Internal.hs"
- -- mkParserTest "ghc88" "Main.hs"
- mkParserTest "ghc88" "PersistUniqueTest.hs"
-
- -- ---------------------------------------------------------------
- -- mkParserTest "ghc710" "Roles.hs"
- -- ---------------------------------------------------------------
-
+ mkPrettyRoundtrip "ghc810" "T16326_Compile1.hs"
+ -- mkPrettyRoundtrip "ghc810" "saks029.hs"
-
-
- -- mkParserTest "ghc86" "deriving-via-compile.hs"
- -- mkParserTest "ghc88" "ClassParens.hs"
-
-
- -- mkParserTest "pre-ghc86" "TensorTests.hs"
- -- , mkParserTest "pre-ghc86" "Webhook.hs"
- -- , mkParserTest "ghc710" "RdrNames.hs"
-
- -- mkPrettyRoundtrip "ghc86" "BinDU.hs"
- -- , mkPrettyRoundtrip "ghc86" "Dial.hs"
-
- -- mkParserTest "ghc84" "Types.hs"
- -- , mkPrettyRoundtrip "ghc80" "export-type.hs"
+ -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"
-- Needs GHC changes
-- mkParserTest "failing" "CtorOp.hs"
diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs
index b502426..f668021 100644
--- a/tests/Test/Common.hs
+++ b/tests/Test/Common.hs
@@ -21,6 +21,9 @@ module Test.Common (
, genTest
, noChange
, mkDebugOutput
+#if __GLASGOW_HASKELL__ > 808
+ , showErrorMessages
+#endif
) where
@@ -34,13 +37,12 @@ import Language.Haskell.GHC.ExactPrint.Types
import qualified ApiAnnotation as GHC
import qualified DynFlags as GHC
--- import qualified FastString as GHC
+#if __GLASGOW_HASKELL__ > 808
+import qualified Bag as GHC
+import qualified ErrUtils as GHC
+#endif
import qualified GHC as GHC hiding (parseModule)
--- import qualified Lexer as GHC
import qualified MonadUtils as GHC
--- import qualified Parser as GHC
--- import qualified SrcLoc as GHC
--- import qualified StringBuffer as GHC
#if __GLASGOW_HASKELL__ <= 710
#else
@@ -79,7 +81,7 @@ data RoundtripReport =
, inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))]
}
-data ParseFailure = ParseFailure GHC.SrcSpan String
+data ParseFailure = ParseFailure String
data ReportType =
Success
@@ -115,7 +117,7 @@ mkParsingTest tester dir fp =
writeHsPP = writeFile (basename <.> "hspp")
writeIncons s = writeFile (basename <.> "incons") (showGhc s)
in
- TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id
+ TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id
<$> tester basename
writeFailure (debugTxt r)
forM_ (inconsistent r) writeIncons
@@ -137,7 +139,11 @@ genTest f origFile expectedFile = do
let pristine = expected
case res of
- Left (ss, m) -> return . Left $ ParseFailure ss m
+#if __GLASGOW_HASKELL__ > 808
+ Left m -> return . Left $ ParseFailure (showErrorMessages m)
+#else
+ Left (_ss, m) -> return . Left $ ParseFailure m
+#endif
Right (apianns, injectedComments, dflags, pmod) -> do
(printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments)
#if __GLASGOW_HASKELL__ <= 710
@@ -221,3 +227,9 @@ getModSummaryForFile fileName = do
[] -> return Nothing
fs -> return (Just (snd $ head fs))
+-- ---------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ > 808
+showErrorMessages :: GHC.ErrorMessages -> String
+showErrorMessages m = show $ GHC.bagToList m
+#endif
diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs
index 2c0c192..11a676a 100644
--- a/tests/Test/NoAnnotations.hs
+++ b/tests/Test/NoAnnotations.hs
@@ -82,11 +82,19 @@ prettyRoundtripTest :: FilePath -> IO Report
prettyRoundtripTest origFile = do
res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile
case res of
- Left (ss, m) -> return . Left $ ParseFailure ss m
+#if __GLASGOW_HASKELL__ > 808
+ Left m -> return . Left $ ParseFailure (showErrorMessages m)
+#else
+ Left (_ss, m) -> return . Left $ ParseFailure m
+#endif
Right (apianns, injectedComments, _dflags, parsed) -> do
res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments)
case res2 of
- Left (ss, m) -> return . Left $ ParseFailure ss m
+#if __GLASGOW_HASKELL__ > 808
+ Left m -> return . Left $ ParseFailure (showErrorMessages m)
+#else
+ Left (_ss, m) -> return . Left $ ParseFailure m
+#endif
Right (_anns', parsed') -> do
let
originalStructure = astStructure parsed []
@@ -110,7 +118,7 @@ prettyRoundtripTest origFile = do
runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource
-> [Comment]
- -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))
+ -> IO (ParseResult GHC.ParsedSource)
runPrettyRoundTrip origFile !anns !parsedOrig _cs = do
let !newAnns = addAnnotationsForPretty [] parsedOrig mempty
let comments = case Map.lookup GHC.noSrcSpan (snd anns) of
@@ -126,7 +134,7 @@ runPrettyRoundTrip origFile !anns !parsedOrig _cs = do
parseString :: FilePath -> String -> Anns -> GHC.ParsedSource
- -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))
+ -> IO (ParseResult GHC.ParsedSource)
parseString origFile src newAnns origParsed = do
tmpDir <- getTemporaryDirectory
let workDir = tmpDir </> "ghc-exactprint" </> "noannotations"
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
index 43369aa..96a71a2 100644
--- a/tests/Test/Transform.hs
+++ b/tests/Test/Transform.hs
@@ -72,7 +72,7 @@ mkTestMod suffix dir f fp =
expected = basename <.> suffix
writeFailure = writeFile (basename <.> "out")
in
- TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id
+ TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id
<$> genTest f basename expected
writeFailure (debugTxt r)
assertBool fp (status r == Success))
@@ -141,7 +141,7 @@ changeLocalDecls2 ans (GHC.L l p) = do
-- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
modifyAnnsT (captureOrderAnnKey newAnnKey decls)
#if __GLASGOW_HASKELL__ > 804
- let binds = (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt (GHC.listToBag $ [GHC.L ld decl])
+ let binds = (GHC.HsValBinds noExt (GHC.ValBinds noExt (GHC.listToBag $ [GHC.L ld decl])
[GHC.L ls sig]))
#else
let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])
@@ -157,7 +157,7 @@ changeLocalDecls2 ans (GHC.L l p) = do
return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds))))
#else
bindSpan <- uniqueSrcSpanT
- return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L bindSpan binds))))
+ return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L bindSpan binds))))
#endif
replaceLocalBinds x = return x
-- putStrLn $ "log:" ++ intercalate "\n" w
@@ -205,8 +205,8 @@ changeLocalDecls ans (GHC.L l p) = do
-- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
modifyAnnsT (captureOrder m decls)
#if __GLASGOW_HASKELL__ > 804
- let binds' = (GHC.HsValBinds GHC.noExt
- (GHC.ValBinds GHC.noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)
+ let binds' = (GHC.HsValBinds noExt
+ (GHC.ValBinds noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)
(GHC.L ls sig:sigs)))
#else
let binds' = (GHC.HsValBinds
@@ -220,7 +220,7 @@ changeLocalDecls ans (GHC.L l p) = do
#elif __GLASGOW_HASKELL__ <= 804
return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds'))))
#else
- return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L lb binds'))))
+ return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L lb binds'))))
#endif
replaceLocalBinds x = return x
-- putStrLn $ "log:" ++ intercalate "\n" w
@@ -326,7 +326,7 @@ rename newNameStr spans a
#elif __GLASGOW_HASKELL__ <= 804
| cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName))
#else
- | cond ln = GHC.L ln (GHC.HsVar GHC.noExt (GHC.L ln newName))
+ | cond ln = GHC.L ln (GHC.HsVar noExt (GHC.L ln newName))
#endif
replaceHsVar x = x
@@ -335,11 +335,11 @@ rename newNameStr spans a
#if __GLASGOW_HASKELL__ > 806
replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
replacePat (GHC.dL->GHC.L ln (GHC.VarPat {}))
- | cond ln = GHC.cL ln (GHC.VarPat GHC.noExt (GHC.cL ln newName))
+ | cond ln = GHC.cL ln (GHC.VarPat noExt (GHC.cL ln newName))
#elif __GLASGOW_HASKELL__ > 804
replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
replacePat (GHC.L ln (GHC.VarPat {}))
- | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))
+ | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName))
#elif __GLASGOW_HASKELL__ > 802
replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
replacePat (GHC.L ln (GHC.VarPat {}))
@@ -364,7 +364,7 @@ rename newNameStr spans a
-- #elif __GLASGOW_HASKELL__ <= 804
-- | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))
-- #else
--- | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))
+-- | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName))
-- #endif
-- replacePat x = x
@@ -414,7 +414,7 @@ changeLetIn1 ans parsed
#elif __GLASGOW_HASKELL__ <= 804
in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr)
#else
- in (GHC.HsLet GHC.noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr)
+ in (GHC.HsLet noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr)
#endif
replace x = x
@@ -563,12 +563,14 @@ addLocaLDecl6 ans lp = do
[d1,d2] <- hsDecls lp
balanceComments d1 d2
-#if __GLASGOW_HASKELL__ <= 710
- let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1
-#elif __GLASGOW_HASKELL__ <= 804
+#if __GLASGOW_HASKELL__ > 808
+ let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1
+#elif __GLASGOW_HASKELL__ > 804
+ let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1
+#elif __GLASGOW_HASKELL__ > 710
let GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1
#else
- let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1
+ let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1
#endif
balanceComments m1 m2
@@ -688,7 +690,7 @@ rmDecl5 ans lp = do
#elif __GLASGOW_HASKELL__ <= 804
return (GHC.HsLet (GHC.L l lb') expr)
#else
- return (GHC.HsLet GHC.noExt (GHC.L l lb') expr)
+ return (GHC.HsLet noExt (GHC.L l lb') expr)
#endif
go x = return x
@@ -790,8 +792,8 @@ addHiding1 ans (GHC.L l p) = do
n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))
n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))
#if __GLASGOW_HASKELL__ > 804
- v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1)))
- v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2)))
+ v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1)))
+ v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2)))
#elif __GLASGOW_HASKELL__ > 800
v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1)))
v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2)))
@@ -824,8 +826,8 @@ addHiding2 ans (GHC.L l p) = do
n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))
n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))
#if __GLASGOW_HASKELL__ > 804
- v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1)))
- v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2)))
+ v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1)))
+ v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2)))
#elif __GLASGOW_HASKELL__ > 800
v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1)))
v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2)))
diff --git a/tests/examples/ghc810/T16326_Compile1.hs b/tests/examples/ghc810/T16326_Compile1.hs
new file mode 100755
index 0000000..afd3b6a
--- /dev/null
+++ b/tests/examples/ghc810/T16326_Compile1.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module T16326_Compile1 where
+
+import Data.Kind
+
+type DApply a (b :: a -> Type) (f :: forall (x :: a) -> b x) (x :: a) =
+ f x
+
+type DComp a
+ (b :: a -> Type)
+ (c :: forall (x :: a). b x -> Type)
+ (f :: forall (x :: a). forall (y :: b x) -> c y)
+ (g :: forall (x :: a) -> b x)
+ (x :: a) =
+ f (g x)
+
+-- Ensure that ElimList has a CUSK, beuas it is
+-- is used polymorphically its RHS (c.f. #16344)
+type family ElimList (a :: Type)
+ (p :: [a] -> Type)
+ (s :: [a])
+ (pNil :: p '[])
+ (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs))
+ :: p s where
+ forall a p pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)).
+ ElimList a p '[] pNil pCons =
+ pNil
+ forall a p x xs pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)).
+ ElimList a p (x:xs) pNil pCons =
+ pCons x xs (ElimList a p xs pNil pCons)
+
+data Proxy' :: forall k -> k -> Type where
+ MkProxy' :: forall k (a :: k). Proxy' k a
+
+type family Proxy2' ∷ ∀ k → k → Type where
+ Proxy2' = Proxy'
+
diff --git a/tests/examples/ghc810/T17296.hs b/tests/examples/ghc810/T17296.hs
new file mode 100755
index 0000000..2d21433
--- /dev/null
+++ b/tests/examples/ghc810/T17296.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module T17296 where
+
+import Data.Foldable
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+import System.IO
+
+data family Foo1 :: Type -> Type
+data instance Foo1 Bool = Foo1Bool
+data instance Foo1 (Maybe a)
+
+data family Foo2 :: k -> Type
+data instance Foo2 Bool = Foo2Bool
+data instance Foo2 (Maybe a)
+data instance Foo2 :: Char -> Type
+data instance Foo2 :: (Char -> Char) -> Type where
+
+data family Foo3 :: k
+data instance Foo3
+data instance Foo3 Bool = Foo3Bool
+data instance Foo3 (Maybe a)
+data instance Foo3 :: Char -> Type
+data instance Foo3 :: (Char -> Char) -> Type where
+
+$(do let test :: Name -> Q ()
+ test n = do i <- reify n
+ runIO $ do hPutStrLn stderr $ pprint i
+ hPutStrLn stderr ""
+ hFlush stderr
+
+ traverse_ test [''Foo1, ''Foo2, ''Foo3]
+ pure [])
+
diff --git a/tests/examples/ghc810/T3391.hs b/tests/examples/ghc810/T3391.hs
new file mode 100755
index 0000000..d85d384
--- /dev/null
+++ b/tests/examples/ghc810/T3391.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -v0 #-}
+
+-- We should only generate one set of generic to/from functions
+-- for T, despite the multiple chunks caused by the TH splices
+-- See #3391
+
+module T3391 where
+
+data T = MkT
+
+$(return [])
+
+$(return [])
+
diff --git a/tests/examples/ghc810/TH_scope.hs b/tests/examples/ghc810/TH_scope.hs
new file mode 100755
index 0000000..e985560
--- /dev/null
+++ b/tests/examples/ghc810/TH_scope.hs
@@ -0,0 +1,10 @@
+-- Test for #2188
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module TH_scope where
+
+f g = [d| f :: Int
+ f = g
+ g :: Int
+ g = 4 |]
+
diff --git a/tests/examples/ghc810/TH_unresolvedInfix.hs b/tests/examples/ghc810/TH_unresolvedInfix.hs
new file mode 100755
index 0000000..dcad738
--- /dev/null
+++ b/tests/examples/ghc810/TH_unresolvedInfix.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoStarIsType #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import TH_unresolvedInfix_Lib
+import Language.Haskell.TH
+
+--------------------------------------------------------------------------------
+-- Expressions --
+--------------------------------------------------------------------------------
+exprs = [
+-------------- Completely-unresolved bindings
+ $( n +? (n *? n) ),
+ $( (n +? n) *? n ),
+ $( n +? (n +? n) ),
+ $( (n +? n) +? n ),
+ -- VarE version
+ $( uInfixE n plus2 (uInfixE n plus2 n) ),
+ $( uInfixE (uInfixE n plus2 n) plus2 n ),
+ $( uInfixE n plus3 (uInfixE n plus3 n) ),
+ $( uInfixE (uInfixE n plus3 n) plus3 n ),
+
+--------------- Completely-resolved bindings
+ $( n +! (n *! n) ),
+ $( (n +! n) *! n ),
+ $( n +! (n +! n) ),
+ $( (n +! n) +! n ),
+
+-------------- Mixed resolved/unresolved
+ $( (n +! n) *? (n +? n) ),
+ $( (n +? n) *? (n +! n) ),
+ $( (n +? n) *! (n +! n) ),
+ $( (n +? n) *! (n +? n) ),
+
+-------------- Parens
+ $( ((parensE ((n +? n) *? n)) +? n) *? n ),
+ $( (parensE (n +? n)) *? (parensE (n +? n)) ),
+ $( parensE ((n +? n) *? (n +? n)) ),
+
+-------------- Sections
+ $( infixE (Just $ n +? n) plus Nothing ) N,
+ -- see B.hs for the (non-compiling) other version of the above
+ $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N
+ ]
+
+--------------------------------------------------------------------------------
+-- Patterns --
+--------------------------------------------------------------------------------
+patterns = [
+-------------- Completely-unresolved patterns
+ case N :+ (N :* N) of
+ [p1|unused|] -> True,
+ case N :+ (N :* N) of
+ [p2|unused|] -> True,
+ case (N :+ N) :+ N of
+ [p3|unused|] -> True,
+ case (N :+ N) :+ N of
+ [p4|unused|] -> True,
+-------------- Completely-resolved patterns
+ case N :+ (N :* N) of
+ [p5|unused|] -> True,
+ case (N :+ N) :* N of
+ [p6|unused|] -> True,
+ case N :+ (N :+ N) of
+ [p7|unused|] -> True,
+ case (N :+ N) :+ N of
+ [p8|unused|] -> True,
+-------------- Mixed resolved/unresolved
+ case ((N :+ N) :* N) :+ N of
+ [p9|unused|] -> True,
+ case N :+ (N :* (N :+ N)) of
+ [p10|unused|] -> True,
+ case (N :+ N) :* (N :+ N) of
+ [p11|unused|] -> True,
+ case (N :+ N) :* (N :+ N) of
+ [p12|unused|] -> True,
+-------------- Parens
+ case (N :+ (N :* N)) :+ (N :* N) of
+ [p13|unused|] -> True,
+ case (N :+ N) :* (N :+ N) of
+ [p14|unused|] -> True,
+ case (N :+ (N :* N)) :+ N of
+ [p15|unused|] -> True
+ ]
+
+--------------------------------------------------------------------------------
+-- Types --
+--------------------------------------------------------------------------------
+
+-------------- Completely-unresolved types
+_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) )
+_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int )
+_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) )
+_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int )
+-------------- Completely-resolved types
+_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) )
+_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int )
+_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) )
+_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int )
+-------------- Mixed resolved/unresolved
+_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) )
+_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) )
+_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) )
+_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) )
+-------------- Parens
+_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int )
+_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) )
+_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) )
+
+main = do
+ mapM_ print exprs
+ mapM_ print patterns
+ -- check that there are no Parens or UInfixes in the output
+ runQ [|N :* N :+ N|] >>= print
+ runQ [|(N :* N) :+ N|] >>= print
+ runQ [p|N :* N :+ N|] >>= print
+ runQ [p|(N :* N) :+ N|] >>= print
+ runQ [t|Int * Int + Int|] >>= print
+ runQ [t|(Int * Int) + Int|] >>= print
+
+ -- pretty-printing of unresolved infix expressions
+ let ne = ConE $ mkName "N"
+ np = ConP (mkName "N") []
+ nt = ConT (mkName "Int")
+ plusE = ConE (mkName ":+")
+ plusP = (mkName ":+")
+ plusT = (mkName "+")
+ putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne)))
+ putStrLn $ pprint (ParensE ne)
+ putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np)))
+ putStrLn $ pprint (ParensP np)
+ putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt)))
+ putStrLn $ pprint (ParensT nt)
+
diff --git a/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs b/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs
new file mode 100755
index 0000000..c65c58d
--- /dev/null
+++ b/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoStarIsType #-}
+
+module TH_unresolvedInfix_Lib where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Quote
+
+infixl 6 :+
+infixl 7 :*
+
+data Tree = N
+ | Tree :+ Tree
+ | Tree :* Tree
+
+-- custom instance, including redundant parentheses
+instance Show Tree where
+ show N = "N"
+ show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")"
+ show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")"
+
+-- VarE versions
+infixl 6 +:
+infixl 7 *:
+(+:) = (:+)
+(*:) = (:*)
+
+n = conE (mkName "N")
+plus = conE (mkName ":+")
+times = conE (mkName ":*")
+
+a +? b = uInfixE a plus b
+a *? b = uInfixE a times b
+a +! b = infixApp a plus b
+a *! b = infixApp a times b
+
+plus2 = varE (mkName "+:")
+times2 = varE (mkName "*:")
+plus3 = conE ('(:+))
+
+
+--------------------------------------------------------------------------------
+-- Patterns --
+--------------------------------------------------------------------------------
+-- The only way to test pattern splices is using QuasiQuotation
+mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined
+p = conP (mkName "N") []
+plus' = mkName ":+"
+times' = mkName ":*"
+
+a ^+? b = uInfixP a plus' b
+a ^*? b = uInfixP a times' b
+a ^+! b = infixP a plus' b
+a ^*! b = infixP a times' b
+
+-------------- Completely-unresolved patterns
+p1 = mkQQ ( p ^+? (p ^*? p) )
+p2 = mkQQ ( (p ^+? p) ^*? p )
+p3 = mkQQ ( p ^+? (p ^+? p) )
+p4 = mkQQ ( (p ^+? p) ^+? p )
+-------------- Completely-resolved patterns
+p5 = mkQQ ( p ^+! (p ^*! p) )
+p6 = mkQQ ( (p ^+! p) ^*! p )
+p7 = mkQQ ( p ^+! (p ^+! p) )
+p8 = mkQQ ( (p ^+! p) ^+! p )
+-------------- Mixed resolved/unresolved
+p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) )
+p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) )
+p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) )
+p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) )
+-------------- Parens
+p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p )
+p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )
+p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )
+
+--------------------------------------------------------------------------------
+-- Types --
+--------------------------------------------------------------------------------
+
+infixl 6 +
+infixl 7 *
+data (+) a b = Plus a b
+data (*) a b = Times a b
+
+int = conT (mkName "Int")
+tyPlus = mkName "+"
+tyTimes = mkName "*"
+
+a $+? b = uInfixT a tyPlus b
+a $*? b = uInfixT a tyTimes b
+a $+! b = infixT a tyPlus b
+a $*! b = infixT a tyTimes b
+
diff --git a/tests/examples/ghc810/mod181.hs b/tests/examples/ghc810/mod181.hs
new file mode 100755
index 0000000..f7185b8
--- /dev/null
+++ b/tests/examples/ghc810/mod181.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+-- If 'ImportQualifiedPost' is enabled 'qualified' can appear in
+-- postpositive position.
+
+import Prelude qualified
+
+main = Prelude.undefined
+
diff --git a/tests/examples/ghc810/saks029.hs b/tests/examples/ghc810/saks029.hs
new file mode 100755
index 0000000..d0178b4
--- /dev/null
+++ b/tests/examples/ghc810/saks029.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE PolyKinds, DataKinds, RankNTypes, TypeFamilies #-}
+
+module SAKS_029 where
+
+import Data.Kind
+import Data.Proxy
+import Data.Type.Bool
+
+type IfK :: forall j m n. forall (e :: Proxy (j :: Bool)) -> m -> n -> If j m n
+type family IfK e f g where
+ IfK (_ :: Proxy True) f _ = f
+ IfK (_ :: Proxy False) _ g = g
+
diff --git a/tests/examples/ghc810/saks032.hs b/tests/examples/ghc810/saks032.hs
new file mode 100755
index 0000000..06c683b
--- /dev/null
+++ b/tests/examples/ghc810/saks032.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, RankNTypes #-}
+
+module SAKS_032 where
+
+import Data.Kind
+import Data.Proxy
+
+type Const :: Type -> forall k. k -> Type
+data Const a b = Const a
+
+type F :: Type -> Type -> forall k. k -> Type
+type family F a b :: forall k. k -> Type where
+ F () () = Proxy
+ F a b = Const (a,b)
+
+type F1 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type
+type family F1 a b
+
+type F2 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type
+type family F2 a b :: forall r2. (r1, r2) -> Type
+
diff --git a/tests/examples/ghc84/arrowfail003.hs b/tests/examples/pre-ghc810/arrowfail003.hs
index 3954c66..3954c66 100755
--- a/tests/examples/ghc84/arrowfail003.hs
+++ b/tests/examples/pre-ghc810/arrowfail003.hs