summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlanZimmerman <>2018-07-11 21:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-07-11 21:23:00 (GMT)
commitacc46b7da4e695bf357c5fb5f311382686c1d105 (patch)
treebc910d39de1e7435ede8d8fbb6b8c28ac36f01c3
parentb6934f22d6668ed1ee60bca7a5382e4288426984 (diff)
version 0.5.7.0HEAD0.5.7.0master
-rw-r--r--ChangeLog2
-rw-r--r--ghc-exactprint.cabal47
-rw-r--r--src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs1
-rw-r--r--src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs2800
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Lookup.hs5
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Pretty.hs13
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Transform.hs252
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Types.hs21
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Utils.hs2
-rw-r--r--tests/Test.hs59
-rw-r--r--tests/Test/Transform.hs92
-rw-r--r--tests/examples/ghc710/GADTContext.hs13
-rw-r--r--tests/examples/ghc710/OveridingPrimitives.hs1
-rw-r--r--tests/examples/ghc80/GADTContext.hs37
-rw-r--r--tests/examples/ghc86/Arith.hs145
-rw-r--r--tests/examples/ghc86/BadTelescope.hs9
-rw-r--r--tests/examples/ghc86/BadTelescope2.hs14
-rw-r--r--tests/examples/ghc86/BadTelescope3.hs9
-rw-r--r--tests/examples/ghc86/BadTelescope4.hs13
-rw-r--r--tests/examples/ghc86/Boot1.hs7
-rw-r--r--tests/examples/ghc86/Dep3.hs26
-rw-r--r--tests/examples/ghc86/GADT.hs22
-rw-r--r--tests/examples/ghc86/HashTab.hs341
-rw-r--r--tests/examples/ghc86/KindEqualities2.hs43
-rw-r--r--tests/examples/ghc86/LiftedConstructors.hs25
-rw-r--r--tests/examples/ghc86/Parser.hs166
-rw-r--r--tests/examples/ghc86/RAE_T32a.hs35
-rw-r--r--tests/examples/ghc86/RAE_T32b.hs23
-rw-r--r--tests/examples/ghc86/Rae31.hs24
-rw-r--r--tests/examples/ghc86/RaeBlogPost.hs63
-rw-r--r--tests/examples/ghc86/RenamingStar.hs5
-rw-r--r--tests/examples/ghc86/ST.hs62
-rw-r--r--tests/examples/ghc86/SlidingTypeSyn.hs14
-rw-r--r--tests/examples/ghc86/T10134a.hs11
-rw-r--r--tests/examples/ghc86/T10279.hs12
-rw-r--r--tests/examples/ghc86/T10321.hs14
-rw-r--r--tests/examples/ghc86/T10638.hs33
-rw-r--r--tests/examples/ghc86/T10689a.hs115
-rw-r--r--tests/examples/ghc86/T10819.hs28
-rw-r--r--tests/examples/ghc86/T10891.hs41
-rw-r--r--tests/examples/ghc86/T10934.hs38
-rw-r--r--tests/examples/ghc86/T11142.hs10
-rw-r--r--tests/examples/ghc86/T11484.hs11
-rw-r--r--tests/examples/ghc86/T12478_5.hs18
-rw-r--r--tests/examples/ghc86/T14164.hs11
-rw-r--r--tests/examples/ghc86/T14650.hs77
-rw-r--r--tests/examples/ghc86/T2632.hs15
-rw-r--r--tests/examples/ghc86/T3263-2.hs39
-rw-r--r--tests/examples/ghc86/T3391.hs15
-rw-r--r--tests/examples/ghc86/T3572.hs12
-rw-r--r--tests/examples/ghc86/T3927b.hs76
-rw-r--r--tests/examples/ghc86/T4056.hs17
-rw-r--r--tests/examples/ghc86/T4169.hs15
-rw-r--r--tests/examples/ghc86/T4170.hs14
-rw-r--r--tests/examples/ghc86/T5217.hs11
-rw-r--r--tests/examples/ghc86/T6018th.hs121
-rw-r--r--tests/examples/ghc86/T6062.hs4
-rw-r--r--tests/examples/ghc86/T8455.hs7
-rw-r--r--tests/examples/ghc86/T8759a.hs7
-rw-r--r--tests/examples/ghc86/T8807.hs11
-rw-r--r--tests/examples/ghc86/T9367.hs5
-rw-r--r--tests/examples/ghc86/T9632.hs11
-rw-r--r--tests/examples/ghc86/T9662.hs54
-rw-r--r--tests/examples/ghc86/T9824.hs7
-rw-r--r--tests/examples/ghc86/TH_abstractFamily.hs13
-rw-r--r--tests/examples/ghc86/TH_bracket1.hs9
-rw-r--r--tests/examples/ghc86/TH_bracket2.hs10
-rw-r--r--tests/examples/ghc86/TH_bracket3.hs12
-rw-r--r--tests/examples/ghc86/TH_class1.hs9
-rw-r--r--tests/examples/ghc86/TH_dataD1.hs12
-rw-r--r--tests/examples/ghc86/TH_localname.hs5
-rw-r--r--tests/examples/ghc86/TH_lookupName.hs37
-rw-r--r--tests/examples/ghc86/TH_ppr1.hs38
-rw-r--r--tests/examples/ghc86/TH_raiseErr1.hs6
-rw-r--r--tests/examples/ghc86/TH_recover.hs13
-rw-r--r--tests/examples/ghc86/TH_reifyDecl1.hs88
-rw-r--r--tests/examples/ghc86/TH_reifyDecl2.hs12
-rw-r--r--tests/examples/ghc86/TH_reifyInstances.hs51
-rw-r--r--tests/examples/ghc86/TH_reifyMkName.hs16
-rw-r--r--tests/examples/ghc86/TH_repE1.hs32
-rw-r--r--tests/examples/ghc86/TH_repE2.hs37
-rw-r--r--tests/examples/ghc86/TH_repE3.hs20
-rw-r--r--tests/examples/ghc86/TH_repGuard.hs35
-rw-r--r--tests/examples/ghc86/TH_repGuardOutput.hs30
-rw-r--r--tests/examples/ghc86/TH_repPatSig.hs19
-rw-r--r--tests/examples/ghc86/TH_repPatSigTVar.hs13
-rw-r--r--tests/examples/ghc86/TH_repPrim.hs34
-rw-r--r--tests/examples/ghc86/TH_repPrim2.hs34
-rw-r--r--tests/examples/ghc86/TH_repPrimOutput.hs23
-rw-r--r--tests/examples/ghc86/TH_repPrimOutput2.hs23
-rw-r--r--tests/examples/ghc86/TH_scope.hs10
-rw-r--r--tests/examples/ghc86/TH_sections.hs11
-rw-r--r--tests/examples/ghc86/TH_spliceD2.hs7
-rw-r--r--tests/examples/ghc86/TH_spliceDecl1.hs12
-rw-r--r--tests/examples/ghc86/TH_spliceDecl2.hs13
-rw-r--r--tests/examples/ghc86/TH_spliceDecl3.hs13
-rw-r--r--tests/examples/ghc86/TH_spliceE1.hs8
-rw-r--r--tests/examples/ghc86/TH_spliceE3.hs26
-rw-r--r--tests/examples/ghc86/TH_spliceE4.hs13
-rw-r--r--tests/examples/ghc86/TH_spliceE5_Lib.hs10
-rw-r--r--tests/examples/ghc86/TH_spliceE5_prof_Lib.hs10
-rw-r--r--tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs10
-rw-r--r--tests/examples/ghc86/TH_spliceExpr1.hs11
-rw-r--r--tests/examples/ghc86/TH_tf1.hs23
-rw-r--r--tests/examples/ghc86/TH_tf3.hs13
-rw-r--r--tests/examples/ghc86/TH_unresolvedInfix.hs142
-rw-r--r--tests/examples/ghc86/TH_unresolvedInfix2.hs18
-rw-r--r--tests/examples/ghc86/TensorTests.hs (renamed from tests/examples/ghc82/TensorTests.hs)2
-rw-r--r--tests/examples/ghc86/Test.hs410
-rw-r--r--tests/examples/ghc86/Test12417.hs20
-rw-r--r--tests/examples/ghc86/TupleN.hs11
-rw-r--r--tests/examples/ghc86/UnicodeSyntax.hs243
-rw-r--r--tests/examples/ghc86/Webhook.hs176
-rw-r--r--tests/examples/ghc86/deriving-via-compile.hs460
-rw-r--r--tests/examples/ghc86/determ004.hs311
-rw-r--r--tests/examples/ghc86/dynamic-paper.hs341
-rw-r--r--tests/examples/ghc86/dynbrk005.hs6
-rw-r--r--tests/examples/ghc86/ffi1.hs12
-rw-r--r--tests/examples/ghc86/ghci006.hs9
-rw-r--r--tests/examples/ghc86/haddockA026.hs10
-rw-r--r--tests/examples/ghc86/haddockA027.hs11
-rw-r--r--tests/examples/ghc86/haddockA031.hs8
-rw-r--r--tests/examples/ghc86/haddockC026.hs10
-rw-r--r--tests/examples/ghc86/haddockC027.hs25
-rw-r--r--tests/examples/ghc86/haddockC031.hs8
-rw-r--r--tests/examples/ghc86/mdo.hs40
-rw-r--r--tests/examples/ghc86/mkGADTVars.hs9
-rw-r--r--tests/examples/ghc86/overloadedrecflds_generics.hs50
-rw-r--r--tests/examples/pre-ghc86/BadTelescope.hs (renamed from tests/examples/ghc80/BadTelescope.hs)0
-rw-r--r--tests/examples/pre-ghc86/BadTelescope2.hs (renamed from tests/examples/ghc80/BadTelescope2.hs)0
-rw-r--r--tests/examples/pre-ghc86/BadTelescope3.hs (renamed from tests/examples/ghc80/BadTelescope3.hs)0
-rw-r--r--tests/examples/pre-ghc86/BadTelescope4.hs (renamed from tests/examples/ghc80/BadTelescope4.hs)0
-rw-r--r--tests/examples/pre-ghc86/Dep3.hs (renamed from tests/examples/ghc80/Dep3.hs)0
-rw-r--r--tests/examples/pre-ghc86/KindEqualities2.hs (renamed from tests/examples/ghc80/KindEqualities2.hs)0
-rw-r--r--tests/examples/pre-ghc86/LiftedConstructors.hs (renamed from tests/examples/ghc710/LiftedConstructors.hs)0
-rw-r--r--tests/examples/pre-ghc86/RAE_T32a.hs (renamed from tests/examples/ghc80/RAE_T32a.hs)0
-rw-r--r--tests/examples/pre-ghc86/RAE_T32b.hs (renamed from tests/examples/ghc80/RAE_T32b.hs)0
-rw-r--r--tests/examples/pre-ghc86/Rae31.hs (renamed from tests/examples/ghc80/Rae31.hs)0
-rw-r--r--tests/examples/pre-ghc86/RaeBlogPost.hs (renamed from tests/examples/ghc80/RaeBlogPost.hs)0
-rw-r--r--tests/examples/pre-ghc86/RenamingStar.hs (renamed from tests/examples/ghc80/RenamingStar.hs)0
-rw-r--r--tests/examples/pre-ghc86/SlidingTypeSyn.hs (renamed from tests/examples/ghc710/SlidingTypeSyn.hs)0
-rw-r--r--tests/examples/pre-ghc86/T10134a.hs (renamed from tests/examples/ghc80/T10134a.hs)0
-rw-r--r--tests/examples/pre-ghc86/T10321.hs (renamed from tests/examples/ghc80/T10321.hs)0
-rw-r--r--tests/examples/pre-ghc86/T10689a.hs (renamed from tests/examples/ghc80/T10689a.hs)0
-rw-r--r--tests/examples/pre-ghc86/T10934.hs (renamed from tests/examples/ghc80/T10934.hs)0
-rw-r--r--tests/examples/pre-ghc86/T11142.hs (renamed from tests/examples/ghc80/T11142.hs)0
-rw-r--r--tests/examples/pre-ghc86/T3927b.hs (renamed from tests/examples/ghc80/T3927b.hs)0
-rw-r--r--tests/examples/pre-ghc86/T9632.hs (renamed from tests/examples/ghc80/T9632.hs)0
-rw-r--r--tests/examples/pre-ghc86/TensorTests.hs43
-rw-r--r--tests/examples/pre-ghc86/UnicodeSyntax.hs (renamed from tests/examples/ghc80/UnicodeSyntax.hs)0
-rw-r--r--tests/examples/pre-ghc86/Vect.hs (renamed from tests/examples/ghc710/Vect.hs)0
-rw-r--r--tests/examples/pre-ghc86/Webhook.hs (renamed from tests/examples/ghc80/Webhook.hs)0
-rw-r--r--tests/examples/pre-ghc86/determ004.hs (renamed from tests/examples/ghc80/determ004.hs)0
-rw-r--r--tests/examples/pre-ghc86/dynamic-paper.hs (renamed from tests/examples/ghc80/dynamic-paper.hs)0
-rw-r--r--tests/examples/pre-ghc86/mkGADTVars.hs (renamed from tests/examples/ghc80/mkGADTVars.hs)0
-rw-r--r--tests/examples/pre-ghc86/overloadedrecflds_generics.hs (renamed from tests/examples/ghc80/overloadedrecflds_generics.hs)0
-rw-r--r--tests/examples/vect/DiophantineVect.hs (renamed from tests/examples/ghc710/DiophantineVect.hs)0
157 files changed, 8324 insertions, 123 deletions
diff --git a/ChangeLog b/ChangeLog
index ab4f398..fcbb025 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,5 @@
+2018-07-11 v0.5.7.0
+ * Include support for GHC 8.6.1 alpha 1
2018-03-11 v0.5.6.1
* Relax base constraints so tests can configure with GHC 8.4.1
2018-01-27 v0.5.6.0
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index f9b2556..19efc7c 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -1,5 +1,5 @@
name: ghc-exactprint
-version: 0.5.6.1
+version: 0.5.7.0
synopsis: ExactPrint for GHC
description: Using the API Annotations available from GHC 7.10.2, this
library provides a means to round trip any code that can
@@ -29,7 +29,7 @@ author: Alan Zimmerman, Matthew Pickering
maintainer: alan.zimm@gmail.com
category: Development
build-type: Simple
-tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2
+tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.4.3
extra-source-files: ChangeLog
src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs
tests/examples/failing/*.hs
@@ -38,6 +38,9 @@ extra-source-files: ChangeLog
tests/examples/ghc80/*.hs
tests/examples/ghc82/*.hs
tests/examples/ghc84/*.hs
+ tests/examples/ghc86/*.hs
+ tests/examples/pre-ghc86/*.hs
+ tests/examples/vect/*.hs
tests/examples/transform/*.hs
tests/examples/failing/*.hs.bad
tests/examples/transform/*.hs.expected
@@ -80,7 +83,7 @@ library
-- other-modules:
-- other-extensions:
GHC-Options: -Wall
- build-depends: base >=4.7 && <4.12
+ build-depends: base >=4.7 && <4.13
, bytestring >= 0.10.6
, containers >= 0.5
, directory >= 1.2
@@ -94,16 +97,19 @@ library
build-depends: ghc-boot
hs-source-dirs: src
- if impl (ghc > 8.2.2)
- hs-source-dirs: src-ghc84
+ if impl (ghc > 8.4.3)
+ 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)
@@ -117,16 +123,19 @@ Test-Suite test
else
hs-source-dirs: tests
- if impl (ghc > 8.2.2)
- hs-source-dirs: src-ghc84
+ if impl (ghc > 8.4.3)
+ 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
@@ -138,7 +147,7 @@ Test-Suite test
if impl (ghc < 7.10.2)
buildable: False
Build-depends: HUnit >= 1.2
- , base < 4.12
+ , base < 4.13
, bytestring
, containers >= 0.5
, Diff
@@ -154,7 +163,7 @@ Test-Suite test
if flag (dev)
build-depends: free
else
- build-depends: ghc-exactprint >= 0.5.4
+ build-depends: ghc-exactprint
if impl (ghc >= 7.11)
build-depends: ghc-boot
diff --git a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs
index d81bdc1..8353072 100644
--- a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs
+++ b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs
@@ -2503,6 +2503,7 @@ instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (ResTyGADTHook name) where
markAST _ (ResTyGADTHook bndrs) = do
+ markManyOptional GHC.AnnOpenP
unless (null bndrs) $ do
mark GHC.AnnForall
mapM_ markLocated bndrs
diff --git a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs
new file mode 100644
index 0000000..a810324
--- /dev/null
+++ b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs
@@ -0,0 +1,2800 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+-- | '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 Control.Monad.Identity
+import Data.Data
+import Data.Maybe
+
+import qualified Data.Set as Set
+
+import Debug.Trace
+
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+{-# ANN module "HLint: ignore Redundant do" #-}
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+-- ---------------------------------------------------------------------
+
+class Data ast => Annotate ast where
+ markAST :: GHC.SrcSpan -> ast -> Annotated ()
+
+-- ---------------------------------------------------------------------
+
+-- | Construct a syntax tree which represent which KeywordIds must appear
+-- where.
+annotate :: (Annotate ast) => GHC.Located ast -> Annotated ()
+annotate = markLocated
+
+-- ---------------------------------------------------------------------
+
+-- | Constructs a syntax tree which contains information about which
+-- annotations are required by each element.
+markLocated :: (Annotate ast) => GHC.Located ast -> Annotated ()
+markLocated ast =
+ case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of
+ Just d -> markLHsDecl d
+ Nothing -> withLocated ast markAST
+
+-- ---------------------------------------------------------------------
+
+-- |When adding missing annotations, do not put a preceding space in front of a list
+markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated ()
+markListNoPrecedingSpace intercal ls =
+ case ls of
+ [] -> return ()
+ (l:ls') -> do
+ if intercal
+ then do
+ if null ls'
+ then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l
+ else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l
+ markListIntercalate ls'
+ else do
+ setContext (Set.singleton NoPrecedingSpace) $ markLocated l
+ mapM_ markLocated ls'
+
+-- ---------------------------------------------------------------------
+
+
+-- |Mark a list, with the given keyword as a list item separator
+markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markListIntercalate ls = markListIntercalateWithFun markLocated ls
+
+-- ---------------------------------------------------------------------
+
+markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated ()
+markListWithContexts ctxInitial ctxRest ls =
+ case ls of
+ [] -> return ()
+ [x] -> setContextLevel ctxInitial 2 $ markLocated x
+ (x:xs) -> do
+ setContextLevel ctxInitial 2 $ markLocated x
+ setContextLevel ctxRest 2 $ mapM_ markLocated xs
+
+-- ---------------------------------------------------------------------
+
+-- Context for only if just one, else first item, middle ones, and last one
+markListWithContexts' :: Annotate ast
+ => ListContexts
+ -> [GHC.Located ast] -> Annotated ()
+markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls =
+ case ls of
+ [] -> return ()
+ [x] -> setContextLevel ctxOnly level $ markLocated x
+ (x:xs) -> do
+ setContextLevel ctxInitial level $ markLocated x
+ go xs
+ where
+ level = 2
+ go [] = return ()
+ go [x] = setContextLevel ctxLast level $ markLocated x
+ go (x:xs) = do
+ setContextLevel ctxMiddle level $ markLocated x
+ go xs
+
+
+-- ---------------------------------------------------------------------
+
+markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markListWithLayout ls =
+ setLayoutFlag $ markList ls
+
+-- ---------------------------------------------------------------------
+
+markList :: Annotate ast => [GHC.Located ast] -> Annotated ()
+markList ls =
+ setContext (Set.singleton NoPrecedingSpace)
+ $ markListWithContexts' listContexts' ls
+
+markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()
+markLocalBindsWithLayout binds = markHsLocalBinds binds
+
+-- ---------------------------------------------------------------------
+
+-- |This function is used to get around shortcomings in the GHC AST for 7.10.1
+markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated ()
+markLocatedFromKw kw (GHC.L l a) = do
+ -- Note: l is needed so that the pretty printer can make something up
+ ss <- getSrcSpanForKw l kw
+ AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a))
+ markLocated (GHC.L ss' a)
+
+-- ---------------------------------------------------------------------
+
+markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()
+markMaybe Nothing = return ()
+markMaybe (Just ast) = markLocated ast
+
+-- ---------------------------------------------------------------------
+-- Managing lists which have been separated, e.g. Sigs and Binds
+
+prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())]
+prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsModule GHC.GhcPs) where
+ markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do
+
+ case mmn of
+ Nothing -> return ()
+ Just (GHC.L ln mn) -> do
+ mark GHC.AnnModule
+ markExternal ln GHC.AnnVal (GHC.moduleNameString mn)
+
+ forM_ mdepr markLocated
+ forM_ mexp markLocated
+
+ mark GHC.AnnWhere
+
+ markOptional GHC.AnnOpenC -- Possible '{'
+ markManyOptional GHC.AnnSemi -- possible leading semis
+ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps
+
+ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs
+
+ markOptional GHC.AnnCloseC -- Possible '}'
+
+ markEOF
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.WarningTxt where
+ markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do
+ markAnnOpen txt "{-# WARNING"
+ mark GHC.AnnOpenS
+ markListIntercalate lss
+ mark GHC.AnnCloseS
+ markWithString GHC.AnnClose "#-}"
+
+ markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do
+ markAnnOpen txt "{-# DEPRECATED"
+ mark GHC.AnnOpenS
+ markListIntercalate lss
+ mark GHC.AnnCloseS
+ markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.StringLiteral where
+ markAST l (GHC.StringLiteral src fs) = do
+ markExternalSourceText l src (show (GHC.unpackFS fs))
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.SourceText,GHC.FastString) where
+ markAST l (src,fs) = do
+ markExternalSourceText l src (show (GHC.unpackFS fs))
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LIE GHC.GhcPs] where
+ markAST _ ls = do
+ inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl
+ mark GHC.AnnOpenP -- '('
+ -- Can't use markListIntercalate, there can be trailing commas, but only in imports.
+ markListIntercalateWithFunLevel markLocated 2 ls
+
+ mark GHC.AnnCloseP -- ')'
+
+instance Annotate (GHC.IE GHC.GhcPs) where
+ markAST _ ie = do
+
+ case ie of
+ GHC.IEVar _ ln -> markLocated ln
+
+ GHC.IEThingAbs _ ln -> do
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+
+ GHC.IEThingWith _ ln wc ns _lfs -> do
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ mark GHC.AnnOpenP
+ case wc of
+ GHC.NoIEWildcard ->
+ unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+ $ markListIntercalate ns
+ GHC.IEWildcard n -> do
+ setContext (Set.fromList [PrefixOp,Intercalate])
+ $ mapM_ markLocated (take n ns)
+ mark GHC.AnnDotdot
+ case drop n ns of
+ [] -> return ()
+ ns' -> do
+ mark GHC.AnnComma
+ unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])
+ $ markListIntercalate ns'
+ mark GHC.AnnCloseP
+
+ (GHC.IEThingAll _ ln) -> do
+ setContext (Set.fromList [PrefixOp]) $ markLocated ln
+ mark GHC.AnnOpenP
+ mark GHC.AnnDotdot
+ mark GHC.AnnCloseP
+
+ (GHC.IEModuleContents _ (GHC.L lm mn)) -> do
+ mark GHC.AnnModule
+ markExternal lm GHC.AnnVal (GHC.moduleNameString mn)
+
+ -- Only used in Haddock mode so we can ignore them.
+ (GHC.IEGroup {}) -> return ()
+
+ (GHC.IEDoc {}) -> return ()
+
+ (GHC.IEDocNamed {}) -> return ()
+ 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
+ canParen = isSym
+ doNormalRdrName = do
+ let str' = case str of
+ -- TODO: unicode support?
+ "forall" -> if spanLength l == 1 then "∀" else str
+ _ -> str
+
+ let
+ markParen :: GHC.AnnKeywordId -> Annotated ()
+ markParen pa = do
+ if canParen
+ then ifInContext (Set.singleton PrefixOp)
+ (mark pa) -- '('
+ (markOptional pa)
+ else if isSym
+ then ifInContext (Set.singleton PrefixOpDollar)
+ (mark pa)
+ (markOptional pa)
+ else markOptional pa
+
+ 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
+ markExternal l GHC.AnnVal str
+ "★" -> do -- Note: unicode star
+ markExternal l GHC.AnnVal str
+ ":" -> do
+ -- Note: The OccName for ":" has the following attributes (via occAttributes)
+ -- (d, Data DataSym Sym Val )
+ -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
+ doNormalRdrName
+ -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName
+ ('(':',':_) -> do
+ mark GHC.AnnOpenP
+ let cnt = length $ filter (==',') str
+ replicateM_ cnt (mark GHC.AnnCommaTuple)
+ mark GHC.AnnCloseP -- ')'
+ _ -> do
+ let isSym' = isSymRdr (GHC.nameRdrName n')
+ when isSym' $ mark GHC.AnnOpenP -- '('
+ markWithString GHC.AnnVal str
+ when isSym $ mark GHC.AnnCloseP -- ')'
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.ImportDecl GHC.GhcPs) where
+ markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do
+
+ -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
+ mark GHC.AnnImport
+
+ -- "{-# SOURCE" and "#-}"
+ case msrc of
+ GHC.SourceText _txt -> do
+ markAnnOpen msrc "{-# SOURCE"
+ markWithString GHC.AnnClose "#-}"
+ GHC.NoSourceText -> return ()
+ when safeflag (mark GHC.AnnSafe)
+ when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)
+ case mpkg of
+ Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) ->
+ markWithString GHC.AnnPackageName srcPkg
+ _ -> return ()
+
+ markLocated modname
+
+ case GHC.ideclAs imp of
+ Nothing -> return ()
+ Just mn -> do
+ mark GHC.AnnAs
+ markLocated mn
+
+ case hiding of
+ Nothing -> return ()
+ Just (isHiding,lie) -> do
+ if isHiding
+ then setContext (Set.singleton HasHiding) $
+ markLocated lie
+ else markLocated lie
+ markTrailingSemi
+
+ markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.ModuleName where
+ markAST l mname =
+ markExternal l GHC.AnnVal (GHC.moduleNameString mname)
+
+-- ---------------------------------------------------------------------
+
+markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated ()
+markLHsDecl (GHC.L l decl) =
+ case decl of
+ GHC.TyClD _ d -> markLocated (GHC.L l d)
+ GHC.InstD _ d -> markLocated (GHC.L l d)
+ GHC.DerivD _ d -> markLocated (GHC.L l d)
+ GHC.ValD _ d -> markLocated (GHC.L l d)
+ GHC.SigD _ d -> markLocated (GHC.L l d)
+ GHC.DefD _ d -> markLocated (GHC.L l d)
+ GHC.ForD _ d -> markLocated (GHC.L l d)
+ GHC.WarningD _ d -> markLocated (GHC.L l d)
+ GHC.AnnD _ d -> markLocated (GHC.L l d)
+ GHC.RuleD _ d -> markLocated (GHC.L l d)
+ GHC.SpliceD _ d -> markLocated (GHC.L l d)
+ GHC.DocD _ d -> markLocated (GHC.L l d)
+ GHC.RoleAnnotD _ d -> markLocated (GHC.L l d)
+ GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x
+
+instance Annotate (GHC.HsDecl GHC.GhcPs) where
+ markAST l d = markLHsDecl (GHC.L l d)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where
+ markAST _ (GHC.RoleAnnotDecl _ ln mr) = do
+ mark GHC.AnnType
+ mark GHC.AnnRole
+ 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 bndrs lhs rhs) = do
+ markLocated ln
+ setContext (Set.singleton ExplicitNeverActive) $ markActivation l act
+
+ unless (null bndrs) $ do
+ mark GHC.AnnForall
+ mapM_ markLocated bndrs
+ mark GHC.AnnDot
+
+ markLocated lhs
+ mark GHC.AnnEqual
+ markLocated rhs
+ inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi
+ markTrailingSemi
+
+ 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
+
+ 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 _ ln pats fixity rhs) = do
+ markTyClass fixity ln pats
+ mark GHC.AnnEqual
+ markLocated rhs
+markFamEqn (GHC.XFamEqn _) = error "got XFamEqn"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where
+
+ markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln pats fixity
+ defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do
+ case GHC.dd_ND defn of
+ GHC.NewType -> mark GHC.AnnNewtype
+ GHC.DataType -> mark GHC.AnnData
+ mark GHC.AnnInstance
+
+ markLocated ctx
+
+ markTyClass fixity ln pats
+
+ case (GHC.dd_kindSig defn) of
+ Just s -> do
+ mark GHC.AnnDcolon
+ markLocated s
+ Nothing -> return ()
+ if isGadt $ GHC.dd_cons defn
+ then mark GHC.AnnWhere
+ else mark GHC.AnnEqual
+ markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs)
+ markTrailingSemi
+
+{-
+newtype DataFamInstDecl pass
+ = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
+
+type FamInstEqn pass rhs
+ = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+
+data FamEqn pass pats rhs
+ = FamEqn
+ { feqn_ext :: XCFamEqn pass pats rhs
+ , feqn_tycon :: Located (IdP pass)
+ , feqn_pats :: pats
+ , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , feqn_rhs :: rhs
+ }
+-}
+
+ 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
+ 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
+ markListIntercalate lns
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+
+ markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do
+ when isDefault $ mark GHC.AnnDefault
+ setContext (Set.singleton PrefixOp) $ markListIntercalate ns
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+
+ markAST _ (GHC.IdSig {}) =
+ traceM "warning: Introduced after renaming"
+
+ markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do
+ let fixstr = case fdir of
+ GHC.InfixL -> "infixl"
+ GHC.InfixR -> "infixr"
+ GHC.InfixN -> "infix"
+ markWithString GHC.AnnInfix fixstr
+ markSourceText src (show v)
+ setContext (Set.singleton InfixOp) $ markListIntercalate lns
+ markTrailingSemi
+
+ markAST l (GHC.InlineSig _ ln inl) = do
+ markAnnOpen (GHC.inl_src inl) "{-# INLINE"
+ markActivation l (GHC.inl_act inl)
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+ markAST l (GHC.SpecSig _ ln typs inl) = do
+ markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ markActivation l (GHC.inl_act inl)
+ markLocated ln
+ mark GHC.AnnDcolon -- '::'
+ markListIntercalateWithFunLevel markLHsSigType 2 typs
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+
+ markAST _ (GHC.SpecInstSig _ src typ) = do
+ markAnnOpen src "{-# SPECIALISE"
+ mark GHC.AnnInstance
+ markLHsSigType typ
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+
+ markAST _ (GHC.MinimalSig _ src formula) = do
+ markAnnOpen src "{-# MINIMAL"
+ markLocated formula
+ markWithString GHC.AnnClose "#-}"
+ markTrailingSemi
+
+ markAST _ (GHC.SCCFunSig _ src ln ml) = do
+ markAnnOpen src "{-# SCC"
+ markLocated ln
+ markMaybe ml
+ markWithString GHC.AnnClose "#-}"
+ markTrailingSemi
+
+ markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do
+ markAnnOpen src "{-# COMPLETE"
+ markListIntercalate ns
+ case mlns of
+ Nothing -> return ()
+ Just _ -> do
+ mark GHC.AnnDcolon
+ markMaybe mlns
+ markWithString GHC.AnnClose "#-}" -- '#-}'
+ markTrailingSemi
+
+ -- -----------------------------------
+ markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _))
+ = error "hit extension for Sig"
+ markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _))
+ = error "hit extension for Sig"
+ markAST _ (GHC.FixSig _ (GHC.XFixitySig _))
+ = error "hit extension for Sig"
+ markAST _ (GHC.XSig _)
+ = error "hit extension for Sig"
+
+-- --------------------------------------------------------------------
+
+markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated ()
+markLHsSigType (GHC.HsIB _ typ) = markLocated typ
+markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x
+
+instance Annotate [GHC.LHsSigType GHC.GhcPs] where
+ markAST _ ls = do
+ -- mark GHC.AnnDeriving
+ -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it
+ -- is a HsTyVar. So for round trip pretty printing we need to take this into
+ -- account.
+ let marker = case ls of
+ [] -> markManyOptional
+ [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t)
+ then markMany
+ else markManyOptional
+ _ -> markMany -- Need parens if more than one entry
+ marker GHC.AnnOpenP
+ markListIntercalateWithFun markLHsSigType ls
+ marker GHC.AnnCloseP
+
+-- --------------------------------------------------------------------
+
+instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
+ markAST _ (GHC.Var x) = do
+ setContext (Set.singleton PrefixOp) $ markLocated x
+ inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls
+ markAST _ (GHC.And ls) = do
+ markListIntercalateWithFunLevel markLocated 2 ls
+ inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ markAST _ (GHC.Parens x) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated x
+ mark GHC.AnnCloseP -- ')'
+ inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where
+ markAST _l (GHC.UserTyVar _ n) = do
+ markLocated n
+
+ markAST _ (GHC.KindedTyVar _ n ty) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated n
+ mark GHC.AnnDcolon -- '::'
+ markLocated ty
+ mark GHC.AnnCloseP -- '('
+
+ markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsType GHC.GhcPs) where
+ markAST loc ty = do
+ markType loc ty
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
+ where
+
+ -- markType :: GHC.SrcSpan -> ast -> Annotated ()
+ markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated ()
+ markType _ (GHC.HsForAllTy _ tvs typ) = do
+ mark GHC.AnnForall
+ mapM_ markLocated tvs
+ mark GHC.AnnDot
+ markLocated typ
+
+ markType _ (GHC.HsQualTy _ cxt typ) = do
+ markLocated cxt
+ markLocated typ
+
+ markType _ (GHC.HsTyVar _ promoted name) = do
+ when (promoted == GHC.Promoted) $ 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.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
+ mark GHC.AnnOpenP -- '('
+ markLocated t
+ mark GHC.AnnDcolon -- '::'
+ markLocated k
+ mark GHC.AnnCloseP -- ')'
+
+ markType l (GHC.HsSpliceTy _ s) = do
+ markAST l s
+
+ markType _ (GHC.HsDocTy _ t ds) = do
+ markLocated t
+ markLocated ds
+
+ markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do
+ case mt of
+ GHC.NoSourceText -> return ()
+ GHC.SourceText src -> do
+ markWithString GHC.AnnOpen src
+ markWithString GHC.AnnClose "#-}"
+ case str of
+ GHC.SrcLazy -> mark GHC.AnnTilde
+ GHC.SrcStrict -> mark GHC.AnnBang
+ GHC.NoSrcStrict -> return ()
+
+ markLocated t
+
+ markType _ (GHC.HsRecTy _ cons) = do
+ mark GHC.AnnOpenC -- '{'
+ markListIntercalate cons
+ mark GHC.AnnCloseC -- '}'
+
+ markType _ (GHC.HsExplicitListTy _ promoted ts) = do
+ when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenS -- "["
+ markListIntercalate ts
+ mark GHC.AnnCloseS -- ']'
+
+ markType _ (GHC.HsExplicitTupleTy _ ts) = do
+ mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenP
+ markListIntercalate ts
+ mark GHC.AnnCloseP
+
+ markType l (GHC.HsTyLit _ lit) = do
+ case lit of
+ (GHC.HsNumTy s v) ->
+ markExternalSourceText l s (show v)
+ (GHC.HsStrTy s v) ->
+ markExternalSourceText l s (show v)
+
+ markType l (GHC.HsWildCardTy _) = 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.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)
+ 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 ty pat) = do
+ markLocated pat
+ mark GHC.AnnDcolon
+ markLHsSigWcType ty
+
+ markPat _ GHC.CoPat {} =
+ traceM "warning: CoPat introduced after renaming"
+
+ 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
+ mapM_ markLocated stmts
+ markOptional GHC.AnnCloseC
+ inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+ inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
+ markTrailingSemi
+
+ markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- Note: We never have a located ParStmtBlock, so have nothing to hang the
+-- annotation on. This means there is no pushing of context from the parent ParStmt.
+instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where
+ markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do
+ markListIntercalate stmts
+ markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where
+ markAST _ lb = markHsLocalBinds lb
+
+-- ---------------------------------------------------------------------
+
+markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()
+markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) =
+ applyListAnnotationsLayout
+ (prepareListAnnotation (GHC.bagToList binds)
+ ++ prepareListAnnotation sigs
+ )
+markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds
+markHsLocalBinds GHC.EmptyLocalBinds{} = return ()
+
+markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension"
+markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension"
+markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension"
+
+-- ---------------------------------------------------------------------
+
+markMatchGroup :: (Annotate body)
+ => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body)
+ -> Annotated ()
+markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _)
+ = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches
+markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance (Annotate body)
+ => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where
+ markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsExpr GHC.GhcPs) where
+ markAST loc expr = do
+ markExpr loc expr
+ inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
+ -- TODO: If the AnnComma is not needed, revert to markAST
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+ where
+ markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do
+ ifInContext (Set.singleton PrefixOp)
+ (setContext (Set.singleton PrefixOp) $ markLocated n)
+ (ifInContext (Set.singleton InfixOp)
+ (setContext (Set.singleton InfixOp) $ markLocated n)
+ (markLocated n)
+ )
+
+ markExpr l (GHC.HsRecFld _ f) = markAST l f
+
+ markExpr l (GHC.HsOverLabel _ _ fs)
+ = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)
+
+
+ markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) =
+ markAST l n
+ markExpr l (GHC.HsOverLit _ ov) = markAST l ov
+ markExpr l (GHC.HsLit _ lit) = markAST l lit
+
+ markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do
+ setContext (Set.singleton LambdaExpr) $ do
+ -- TODO: Change this, HsLam binds do not need obey layout rules.
+ -- And will only ever have a single match
+ markLocated match
+ markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match"
+
+ markExpr l (GHC.HsLamCase _ match) = do
+ mark GHC.AnnLam
+ mark GHC.AnnCase
+ markOptional GHC.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 typ e) = do
+ setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e
+ mark GHC.AnnDcolon
+ markLHsSigWcType typ
+
+ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do
+ mark GHC.AnnOpenS -- '['
+ case seqInfo of
+ GHC.From e -> do
+ markLocated e
+ mark GHC.AnnDotdot
+ GHC.FromTo e1 e2 -> do
+ markLocated e1
+ mark GHC.AnnDotdot
+ markLocated e2
+ GHC.FromThen e1 e2 -> do
+ markLocated e1
+ mark GHC.AnnComma
+ markLocated e2
+ mark GHC.AnnDotdot
+ GHC.FromThenTo e1 e2 e3 -> do
+ markLocated e1
+ mark GHC.AnnComma
+ markLocated e2
+ mark GHC.AnnDotdot
+ markLocated e3
+ mark GHC.AnnCloseS -- ']'
+
+ markExpr _ (GHC.HsSCC _ src csFStr e) = do
+ markAnnOpen src "{-# SCC"
+ let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
+ markWithStringOptional GHC.AnnVal txt
+ markWithString GHC.AnnValStr txt
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+
+ markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do
+ -- markWithString GHC.AnnOpen src -- "{-# CORE"
+ markAnnOpen src "{-# CORE"
+ -- markWithString GHC.AnnVal (GHC.sl_st csFStr)
+ markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+ -- TODO: make monomorphic
+ markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do
+ mark GHC.AnnSimpleQuote
+ setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v)
+ markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do
+ mark GHC.AnnThTyQuote
+ markLocatedFromKw GHC.AnnName (GHC.L l v)
+ markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do
+ markWithString GHC.AnnOpen "[d|"
+ markOptional GHC.AnnOpenC
+ setContext (Set.singleton NoAdvanceLine)
+ $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds
+ markOptional GHC.AnnCloseC
+ mark GHC.AnnCloseQ -- "|]"
+ -- Introduced after the renamer
+ markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) =
+ traceM "warning: DecBrG introduced after renamer"
+ markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do
+ mark GHC.AnnOpenEQ -- "[|"
+ markOptional GHC.AnnOpenE -- "[e|"
+ markLocated e
+ mark GHC.AnnCloseQ -- "|]"
+ markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do
+ markWithString GHC.AnnOpen "[||"
+ markWithStringOptional GHC.AnnOpenE "[e||"
+ markLocated e
+ markWithString GHC.AnnClose "||]"
+ markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do
+ markWithString GHC.AnnOpen "[t|"
+ markLocated e
+ mark GHC.AnnCloseQ -- "|]"
+ markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do
+ markWithString GHC.AnnOpen "[p|"
+ markLocated e
+ mark GHC.AnnCloseQ -- "|]"
+
+ markExpr _ (GHC.HsRnBracketOut {}) =
+ traceM "warning: HsRnBracketOut introduced after renamer"
+ markExpr _ (GHC.HsTcBracketOut {}) =
+ traceM "warning: HsTcBracketOut introduced after renamer"
+
+ markExpr l (GHC.HsSpliceE _ e) = markAST l e
+
+ markExpr _ (GHC.HsProc _ p c) = do
+ mark GHC.AnnProc
+ markLocated p
+ mark GHC.AnnRarrow
+ markLocated c
+
+ markExpr _ (GHC.HsStatic _ e) = do
+ mark GHC.AnnStatic
+ markLocated e
+
+ markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do
+ -- isRightToLeft True => right-to-left (f -< arg)
+ -- False => left-to-right (arg >- f)
+ if isRightToLeft
+ then do
+ markLocated e1
+ case o of
+ GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail
+ GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail
+ else do
+ markLocated e2
+ case o of
+ GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail
+ GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail
+
+ if isRightToLeft
+ then markLocated e2
+ else markLocated e1
+
+ markExpr _ (GHC.HsArrForm _ e _ cs) = do
+ markWithString GHC.AnnOpenB "(|"
+ markLocated e
+ mapM_ markLocated cs
+ markWithString GHC.AnnCloseB "|)"
+
+ markExpr _ (GHC.HsTick {}) = return ()
+ markExpr _ (GHC.HsBinTick {}) = return ()
+
+ markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do
+ -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+ markAnnOpen src "{-# GENERATED"
+ markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING
+
+ let
+ markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v)
+ markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s
+
+ markOne 1 v1 s1 -- INTEGER
+ markOffset GHC.AnnColon 0 -- ':'
+ markOne 2 v2 s2 -- INTEGER
+ mark GHC.AnnMinus -- '-'
+ markOne 3 v3 s3 -- INTEGER
+ markOffset GHC.AnnColon 1 -- ':'
+ markOne 4 v4 s4 -- INTEGER
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+
+ markExpr l (GHC.EWildPat _) = do
+ ifInContext (Set.fromList [InfixOp])
+ (do mark GHC.AnnBackquote
+ markWithString GHC.AnnVal "_"
+ mark GHC.AnnBackquote)
+ (markExternal l GHC.AnnVal "_")
+
+ markExpr _ (GHC.EAsPat _ ln e) = do
+ markLocated ln
+ mark GHC.AnnAt
+ markLocated e
+
+ markExpr _ (GHC.EViewPat _ e1 e2) = do
+ markLocated e1
+ mark GHC.AnnRarrow
+ markLocated e2
+
+ markExpr _ (GHC.ELazyPat _ e) = do
+ mark GHC.AnnTilde
+ markLocated e
+
+ markExpr _ (GHC.HsAppType ty e) = do
+ markLocated e
+ markInstead GHC.AnnAt AnnTypeApp
+ markLHsWcType ty
+
+ markExpr _ (GHC.HsWrap {}) =
+ traceM "warning: HsWrap introduced after renaming"
+ markExpr _ (GHC.HsUnboundVar {}) =
+ traceM "warning: HsUnboundVar introduced after renaming"
+
+ markExpr _ (GHC.HsConLikeOut{}) =
+ traceM "warning: HsConLikeOut introduced after type checking"
+
+ markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension"
+ markExpr _ (GHC.XExpr _) = error "markExpr got extension"
+
+-- ---------------------------------------------------------------------
+
+markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated ()
+markLHsWcType (GHC.HsWC _ ty) = do
+ markLocated ty
+markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsLit GHC.GhcPs) where
+ markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where
+ markAST _ (GHC.HsRecField lbl expr punFlag) = do
+ unsetContext Intercalate $ markLocated lbl
+ when (punFlag == False) $ do
+ mark GHC.AnnEqual
+ unsetContext Intercalate $ markLocated expr
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where
+ markAST _ (GHC.Unambiguous _ n) = markLocated n
+ markAST _ (GHC.Ambiguous _ n) = markLocated n
+ markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+-- |Used for declarations that need to be aligned together, e.g. in a
+-- do or let .. in statement/expr
+instance Annotate [GHC.ExprLStmt GHC.GhcPs] where
+ markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsTupArg GHC.GhcPs) where
+ markAST _ (GHC.Present _ (GHC.L l e)) = do
+ markLocated (GHC.L l e)
+ inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma)
+
+ markAST _ (GHC.Missing _) = do
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+ markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsCmdTop GHC.GhcPs) where
+ markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd
+ markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x
+
+instance Annotate (GHC.HsCmd GHC.GhcPs) where
+ markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do
+ -- isRightToLeft True => right-to-left (f -< arg)
+ -- False => left-to-right (arg >- f)
+ if isRightToLeft
+ then do
+ markLocated e1
+ case o of
+ GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail
+ GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail
+ else do
+ markLocated e2
+ case o of
+ GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail
+ GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail
+
+ if isRightToLeft
+ then markLocated e2
+ else markLocated e1
+
+ markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do
+ -- The AnnOpen should be marked for a prefix usage, not for a postfix one,
+ -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm
+
+ let isPrefixOp = case fixity of
+ GHC.Infix -> False
+ GHC.Prefix -> True
+ when isPrefixOp $ mark GHC.AnnOpenB -- "(|"
+
+ -- This may be an infix operation
+ applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp)
+ (Set.singleton InfixOp) (Set.singleton InfixOp))
+ (prepareListAnnotation [e]
+ ++ prepareListAnnotation cs)
+ when isPrefixOp $ mark GHC.AnnCloseB -- "|)"
+
+ markAST _ (GHC.HsCmdApp _ e1 e2) = do
+ markLocated e1
+ markLocated e2
+
+ markAST l (GHC.HsCmdLam _ match) = do
+ setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match
+
+ markAST _ (GHC.HsCmdPar _ e) = do
+ mark GHC.AnnOpenP
+ markLocated e
+ mark GHC.AnnCloseP -- ')'
+
+ markAST l (GHC.HsCmdCase _ e1 matches) = do
+ mark GHC.AnnCase
+ markLocated e1
+ mark GHC.AnnOf
+ markOptional GHC.AnnOpenC
+ setContext (Set.singleton CaseAlt) $ do
+ markMatchGroup l matches
+ markOptional GHC.AnnCloseC
+
+ markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do
+ mark GHC.AnnIf
+ markLocated e1
+ markOffset GHC.AnnSemi 0
+ mark GHC.AnnThen
+ markLocated e2
+ markOffset GHC.AnnSemi 1
+ mark GHC.AnnElse
+ markLocated e3
+
+ markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do
+ mark GHC.AnnLet
+ markOptional GHC.AnnOpenC
+ markLocalBindsWithLayout binds
+ markOptional GHC.AnnCloseC
+ mark GHC.AnnIn
+ markLocated e
+
+ markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do
+ mark GHC.AnnDo
+ markOptional GHC.AnnOpenC
+ markListWithLayout es
+ markOptional GHC.AnnCloseC
+
+ markAST _ (GHC.HsCmdWrap {}) =
+ traceM "warning: HsCmdWrap introduced after renaming"
+
+ markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where
+ markAST _ ls = mapM_ markLocated ls
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.TyClDecl GHC.GhcPs) where
+
+ markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi
+
+ markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do
+ -- There may be arbitrary parens around parts of the constructor that are
+ -- infix.
+ -- Turn these into comments so that they feed into the right place automatically
+ -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+ mark GHC.AnnType
+
+ markTyClass fixity ln tyvars
+ mark GHC.AnnEqual
+ markLocated typ
+ markTrailingSemi
+
+ markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity
+ (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do
+ if nd == GHC.DataType
+ then mark GHC.AnnData
+ else mark GHC.AnnNewtype
+ markMaybe mctyp
+ markLocated ctx
+ markTyClass fixity ln tyVars
+ case mk of
+ Nothing -> return ()
+ Just k -> do
+ mark GHC.AnnDcolon
+ markLocated k
+ if isGadt cons
+ then mark GHC.AnnWhere
+ else unless (null cons) $ mark GHC.AnnEqual
+ markOptional GHC.AnnWhere
+ markOptional GHC.AnnOpenC
+ setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace)
+ $ markListWithContexts' listContexts cons
+ markOptional GHC.AnnCloseC
+ setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs
+ markTrailingSemi
+
+ -- -----------------------------------
+
+ markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds
+ sigs meths ats atdefs docs) = do
+ mark GHC.AnnClass
+ markLocated ctx
+
+ markTyClass fixity ln tyVars
+
+ unless (null fds) $ do
+ mark GHC.AnnVbar
+ markListIntercalateWithFunLevel markLocated 2 fds
+ mark GHC.AnnWhere
+ markOptional GHC.AnnOpenC -- '{'
+ markInside GHC.AnnSemi
+ -- AZ:TODO: we end up with both the tyVars and the following body of the
+ -- class defn in annSortKey for the class. This could cause problems when
+ -- changing things.
+ setContext (Set.singleton InClassDecl) $
+ applyListAnnotationsLayout
+ (prepareListAnnotation sigs
+ ++ prepareListAnnotation (GHC.bagToList meths)
+ ++ prepareListAnnotation ats
+ ++ prepareListAnnotation atdefs
+ ++ prepareListAnnotation docs
+ )
+ markOptional GHC.AnnCloseC -- '}'
+ markTrailingSemi
+{-
+ | 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"
+
+-- ---------------------------------------------------------------------
+
+markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)
+ => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated ()
+markTyClass fixity ln tyVars = do
+ -- There may be arbitrary parens around parts of the constructor
+ -- Turn these into comments so that they feed into the right place automatically
+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+ let markParens = if fixity == GHC.Infix && length tyVars > 2
+ then markMany
+ else markManyOptional
+ if fixity == GHC.Prefix
+ then do
+ markManyOptional GHC.AnnOpenP
+ setContext (Set.singleton PrefixOp) $ markLocated ln
+ -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars
+ setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars
+ when (length tyVars >= 2) $ do
+ markParens GHC.AnnCloseP
+ setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars
+ markManyOptional GHC.AnnCloseP
+ else do
+ case tyVars of
+ (x:y:xs) -> do
+ markParens GHC.AnnOpenP
+ markLocated x
+ setContext (Set.singleton InfixOp) $ markLocated ln
+ markLocated y
+ markParens GHC.AnnCloseP
+ mapM_ markLocated xs
+ markManyOptional GHC.AnnCloseP
+ _ -> error $ "markTyClass: Infix op without operands"
+
+-- ---------------------------------------------------------------------
+
+instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where
+ markAST _ ds = mapM_ markLocated ds
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where
+ markAST _ (GHC.HsDerivingClause _ mstrategy 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 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
+
+ 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 (GHC.HsQTvs _ bndrs) fixity typ) = do
+ mark GHC.AnnType
+ mark GHC.AnnInstance
+ markTyClass 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.LPat GHC.GhcPs)) where
+ markAST _ (GHC.HsRecField n e punFlag) = do
+ unsetContext Intercalate $ markLocated n
+ unless punFlag $ do
+ mark GHC.AnnEqual
+ unsetContext Intercalate $ markLocated e
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+
+instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where
+ markAST _ (GHC.HsRecField n e punFlag) = do
+ unsetContext Intercalate $ markLocated n
+ unless punFlag $ do
+ mark GHC.AnnEqual
+ unsetContext Intercalate $ markLocated e
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where
+
+ markAST _ (ls,rs) = do
+ mapM_ markLocated ls
+ mark GHC.AnnRarrow
+ mapM_ markLocated rs
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
+
+-- ---------------------------------------------------------------------
+
+instance Annotate GHC.CType where
+ markAST _ (GHC.CType src mh f) = do
+ -- markWithString GHC.AnnOpen src
+ markAnnOpen src ""
+ case mh of
+ Nothing -> return ()
+ Just (GHC.Header srcH _h) ->
+ -- markWithString GHC.AnnHeader srcH
+ markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "")
+ -- markWithString GHC.AnnVal (fst f)
+ markSourceText (fst f) (GHC.unpackFS $ snd f)
+ markWithString GHC.AnnClose "#-}"
+
+-- ---------------------------------------------------------------------
+
+stringLiteralToString :: GHC.StringLiteral -> String
+stringLiteralToString (GHC.StringLiteral st fs) =
+ case st of
+ GHC.NoSourceText -> GHC.unpackFS fs
+ GHC.SourceText src -> src
diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
index 385824e..78fcbfe 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
@@ -122,7 +122,9 @@ keywordToString kw =
(G GHC.AnnStatic ) -> "static"
(G GHC.AnnThen ) -> "then"
(G GHC.AnnTilde ) -> "~"
+#if __GLASGOW_HASKELL__ <= 804
(G GHC.AnnTildehsh ) -> "~#"
+#endif
(G GHC.AnnType ) -> "type"
(G GHC.AnnUnit ) -> "()"
(G GHC.AnnUsing ) -> "using"
@@ -151,6 +153,9 @@ keywordToString kw =
#if __GLASGOW_HASKELL__ >= 800
AnnTypeApp -> "@"
#endif
+#if __GLASGOW_HASKELL__ > 804
+ (G GHC.AnnVia) -> "via"
+#endif
#if __GLASGOW_HASKELL__ <= 710
-- | Tries to find a unicode equivalent to a 'KeywordId'.
diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
index 642e755..3ac79cd 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
@@ -210,6 +210,9 @@ addPrettyAnnotation ann = do
dp = case ann of
(G GHC.AnnAs) -> tellKd (ann,DP (0,1))
(G GHC.AnnAt) -> tellKd (ann,DP (0,0))
+#if __GLASGOW_HASKELL__ >= 806
+ (G GHC.AnnAnyclass) -> tellKd (ann,DP (0,1))
+#endif
(G GHC.AnnBackquote) -> tellKd (ann,DP (0,1))
(G GHC.AnnBang) -> tellKd (ann,DP (0,1))
(G GHC.AnnBy) -> tellKd (ann,DP (0,1))
@@ -217,6 +220,9 @@ addPrettyAnnotation ann = do
(G GHC.AnnClass) -> tellKd (ann,DP (0,1))
(G GHC.AnnClose) -> tellKd (ann,DP (0,1))
(G GHC.AnnCloseC) -> tellKd (ann,DP (0,0))
+#if __GLASGOW_HASKELL__ >= 802
+ (G GHC.AnnCloseQ) -> tellKd (ann,DP (0,1))
+#endif
(G GHC.AnnDcolon) -> tellKd (ann,DP (0,1))
(G GHC.AnnDeriving) -> tellKd (ann,DP (0,1))
(G GHC.AnnDo) -> tellKd (ann,DP (0,1))
@@ -234,6 +240,7 @@ addPrettyAnnotation ann = do
(G GHC.AnnLam) -> tellKd (ann,DP (0,1))
(G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator
(G GHC.AnnModule) -> tellKd (ann,DP (0,1))
+ (G GHC.AnnNewtype) -> tellKd (ann,DP (0,1))
(G GHC.AnnOf) -> tellKd (ann,DP (0,1))
(G GHC.AnnOpenC) -> tellKd (ann,DP (0,0))
(G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1))
@@ -242,6 +249,9 @@ addPrettyAnnotation ann = do
(G GHC.AnnRarrow) -> tellKd (ann,DP (0,1))
(G GHC.AnnRole) -> tellKd (ann,DP (0,1))
(G GHC.AnnSafe) -> tellKd (ann,DP (0,1))
+#if __GLASGOW_HASKELL__ >= 806
+ (G GHC.AnnStock) -> tellKd (ann,DP (0,1))
+#endif
(G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1))
(G GHC.AnnThIdSplice) -> tellKd (ann,DP (0,1))
(G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1))
@@ -253,6 +263,9 @@ addPrettyAnnotation ann = do
(G GHC.AnnVal) -> tellKd (ann,DP (0,1))
(G GHC.AnnValStr) -> tellKd (ann,DP (0,1))
(G GHC.AnnVbar) -> tellKd (ann,DP (0,1))
+#if __GLASGOW_HASKELL__ >= 806
+ (G GHC.AnnVia) -> tellKd (ann,DP (0,1))
+#endif
(G GHC.AnnWhere) -> tellKd (ann,DP (1,2))
#if __GLASGOW_HASKELL__ >= 800
AnnTypeApp -> tellKd (ann,DP (0,1))
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
index 909f435..c9ee237 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -250,27 +250,43 @@ captureOrderAnnKey parentKey ls ans = ans'
-- nothing to any annotations that may be attached to either of the elements.
-- It is used as a utility function in 'replaceDecls'
decl2Bind :: GHC.LHsDecl name -> [GHC.LHsBind name]
+#if __GLASGOW_HASKELL__ > 804
+decl2Bind (GHC.L l (GHC.ValD _ s)) = [GHC.L l s]
+#else
decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s]
+#endif
decl2Bind _ = []
-- |Pure function to convert a 'GHC.LSig' to a 'GHC.LHsBind'. This does
-- nothing to any annotations that may be attached to either of the elements.
-- It is used as a utility function in 'replaceDecls'
decl2Sig :: GHC.LHsDecl name -> [GHC.LSig name]
+#if __GLASGOW_HASKELL__ > 804
+decl2Sig (GHC.L l (GHC.SigD _ s)) = [GHC.L l s]
+#else
decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s]
+#endif
decl2Sig _ = []
-- ---------------------------------------------------------------------
-- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl'
wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs
+#if __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)
+#endif
-- ---------------------------------------------------------------------
-- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl'
wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs
+#if __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)
+#endif
-- ---------------------------------------------------------------------
@@ -458,7 +474,11 @@ balanceComments first second = do
-- logTr $ "balanceComments entered"
-- logDataWithAnnsTr "first" first
case cast first :: Maybe (GHC.LHsDecl GhcPs) of
- Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do
+#if __GLASGOW_HASKELL__ > 804
+ Just (GHC.L l (GHC.ValD _ fb@(GHC.FunBind{}))) -> do
+#else
+ Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do
+#endif
balanceCommentsFB (GHC.L l fb) second
_ -> case cast first :: Maybe (GHC.LHsBind GhcPs) of
Just fb'@(GHC.L _ (GHC.FunBind{})) -> do
@@ -493,10 +513,12 @@ 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__ <= 710
-balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do
-#else
+#if __GLASGOW_HASKELL__ > 804
+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do
+#elif __GLASGOW_HASKELL__ > 710
balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do
+#else
+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do
#endif
-- logTr $ "balanceCommentsFB entered"
balanceComments' (last matches) second
@@ -646,7 +668,9 @@ instance HasDecls GHC.ParsedSource where
-- ---------------------------------------------------------------------
instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _ (GHC.L _ lb)))) = do
+#elif __GLASGOW_HASKELL__ >= 804
hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do
#elif __GLASGOW_HASKELL__ >= 800
hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do
@@ -657,8 +681,15 @@ instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where
#endif
decls <- hsDeclsValBinds lb
orderedDecls d decls
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) = return []
+ hsDecls (GHC.L _ (GHC.XMatch _)) = return []
+#endif
-#if __GLASGOW_HASKELL__ >= 804
+
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) []
+#elif __GLASGOW_HASKELL__ >= 804
replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) []
#else
replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) []
@@ -684,13 +715,17 @@ instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where
binds'' <- replaceDeclsValbinds (GHC.unLoc binds) []
let binds' = GHC.L (GHC.getLoc binds) binds''
#endif
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds')))
+#elif __GLASGOW_HASKELL__ >= 804
return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds')))
#else
return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
#endif
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) newBinds
+#elif __GLASGOW_HASKELL__ >= 804
replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds
#else
replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds
@@ -704,7 +739,11 @@ instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where
#else
case GHC.unLoc binds of
#endif
+#if __GLASGOW_HASKELL__ > 804
+ GHC.EmptyLocalBinds{} -> do
+#else
GHC.EmptyLocalBinds -> do
+#endif
let
addWhere mkds =
case Map.lookup (mkAnnKey m) mkds of
@@ -729,25 +768,37 @@ instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where
let binds' = GHC.L (GHC.getLoc binds) binds''
#endif
-- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'
-#if __GLASGOW_HASKELL__ >= 804
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds')))
+#elif __GLASGOW_HASKELL__ >= 804
return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds')))
#else
return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
#endif
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) _ = error "replaceDecls"
+ replaceDecls (GHC.L _ (GHC.XMatch _)) _ = error "replaceDecls"
+#endif
-- ---------------------------------------------------------------------
instance HasDecls (GHC.LHsExpr GhcPs) where
-#if __GLASGOW_HASKELL__ <= 710
- hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do
-#else
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls ls@(GHC.L _ (GHC.HsLet _ (GHC.L _ decls) _ex)) = do
+#elif __GLASGOW_HASKELL__ > 710
hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do
+#else
+ hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do
#endif
ds <- hsDeclsValBinds decls
orderedDecls ls ds
hsDecls _ = return []
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls e@(GHC.L l (GHC.HsLet x decls ex)) newDecls
+#else
replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls
+#endif
= do
logTr "replaceDecls HsLet"
modifyAnnsT (captureOrder e newDecls)
@@ -757,12 +808,25 @@ instance HasDecls (GHC.LHsExpr GhcPs) where
decls'' <- replaceDeclsValbinds (GHC.unLoc decls) newDecls
let decls' = GHC.L (GHC.getLoc decls) decls''
#endif
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.L l (GHC.HsLet x decls' ex))
+#else
return (GHC.L l (GHC.HsLet decls' ex))
+#endif
+
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls (GHC.L l (GHC.HsPar x e)) newDecls
+#else
replaceDecls (GHC.L l (GHC.HsPar e)) newDecls
+#endif
= do
logTr "replaceDecls HsPar"
e' <- replaceDecls e newDecls
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.L l (GHC.HsPar x e'))
+#else
return (GHC.L l (GHC.HsPar e'))
+#endif
replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GhcPs) undefined for:" ++ showGhc old
-- ---------------------------------------------------------------------
@@ -772,7 +836,11 @@ instance HasDecls (GHC.LHsExpr GhcPs) where
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
-- idempotent.
hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
+#if __GLASGOW_HASKELL__ > 804
+hsDeclsPatBindD (GHC.L l (GHC.ValD _ d)) = hsDeclsPatBind (GHC.L l d)
+#else
hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d)
+#endif
hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
-- | Extract the immediate declarations for a 'GHC.PatBind'. This
@@ -780,10 +848,12 @@ hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
-- idempotent.
hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
-#if __GLASGOW_HASKELL__ <= 710
-hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do
-#else
+#if __GLASGOW_HASKELL__ > 804
+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ _ (GHC.GRHSs _ _grhs (GHC.L _ lb)) _)) = do
+#elif __GLASGOW_HASKELL__ > 710
hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do
+#else
+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do
#endif
decls <- hsDeclsValBinds lb
orderedDecls d decls
@@ -797,9 +867,15 @@ hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
-- idempotent.
replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs]
-> TransformT m (GHC.LHsDecl GhcPs)
+#if __GLASGOW_HASKELL__ > 804
+replaceDeclsPatBindD (GHC.L l (GHC.ValD x d)) newDecls = do
+ (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls
+ return (GHC.L l (GHC.ValD x d'))
+#else
replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do
(GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls
return (GHC.L l (GHC.ValD d'))
+#endif
replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x
-- | Replace the immediate declarations for a 'GHC.PatBind'. This
@@ -808,7 +884,11 @@ replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc
-- idempotent.
replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs]
-> TransformT m (GHC.LHsBind GhcPs)
+#if __GLASGOW_HASKELL__ > 804
+replaceDeclsPatBind p@(GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds) b)) newDecls
+#else
replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls
+#endif
= do
logTr "replaceDecls PatBind"
-- Need to throw in a fresh where clause if the binds were empty,
@@ -818,7 +898,11 @@ replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) new
#else
case GHC.unLoc binds of
#endif
+#if __GLASGOW_HASKELL__ > 804
+ GHC.EmptyLocalBinds{} -> do
+#else
GHC.EmptyLocalBinds -> do
+#endif
let
addWhere mkds =
case Map.lookup (mkAnnKey p) mkds of
@@ -839,33 +923,55 @@ replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) new
binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls
let binds' = GHC.L (GHC.getLoc binds) binds''
#endif
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds') b))
+#else
return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d))
+#endif
replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
-- ---------------------------------------------------------------------
instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where
-#if __GLASGOW_HASKELL__ <= 710
- hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do
-#else
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls ls@(GHC.L _ (GHC.LetStmt _ (GHC.L _ lb))) = do
+#elif __GLASGOW_HASKELL__ > 710
hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do
+#else
+ hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do
#endif
decls <- hsDeclsValBinds lb
orderedDecls ls decls
-#if __GLASGOW_HASKELL__ <= 710
- hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e
-#else
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls (GHC.L _ (GHC.LastStmt _ e _ _)) = hsDecls e
+#elif __GLASGOW_HASKELL__ >= 804
+ hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e
+#elif __GLASGOW_HASKELL__ > 800
+ hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e
+#elif __GLASGOW_HASKELL__ > 710
hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e
-#endif
-#if __GLASGOW_HASKELL__ <= 710
- hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e
#else
+ hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e
+#endif
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls (GHC.L _ (GHC.BindStmt _ _pat e _ _)) = hsDecls e
+#elif __GLASGOW_HASKELL__ > 710
hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e
+#else
+ hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e
#endif
+#if __GLASGOW_HASKELL__ > 804
+ hsDecls (GHC.L _ (GHC.BodyStmt _ e _ _)) = hsDecls e
+#else
hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsDecls e
+#endif
hsDecls _ = return []
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls s@(GHC.L l (GHC.LetStmt x lb)) newDecls
+#else
replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls
+#endif
= do
modifyAnnsT (captureOrder s newDecls)
#if __GLASGOW_HASKELL__ <= 710
@@ -874,34 +980,55 @@ instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where
lb'' <- replaceDeclsValbinds (GHC.unLoc lb) newDecls
let lb' = GHC.L (GHC.getLoc lb) lb''
#endif
- return (GHC.L l (GHC.LetStmt lb'))
-#if __GLASGOW_HASKELL__ <= 710
- replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.L l (GHC.LetStmt x lb'))
+#else
+ return (GHC.L l (GHC.LetStmt lb'))
+#endif
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls (GHC.L l (GHC.LastStmt x e d se)) newDecls
= do
e' <- replaceDecls e newDecls
- return (GHC.L l (GHC.LastStmt e' se))
-#else
+ return (GHC.L l (GHC.LastStmt x e' d se))
+#elif __GLASGOW_HASKELL__ > 710
replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls
= do
e' <- replaceDecls e newDecls
return (GHC.L l (GHC.LastStmt e' d se))
+#else
+ replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.LastStmt e' se))
#endif
-#if __GLASGOW_HASKELL__ <= 710
- replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls
= do
e' <- replaceDecls e newDecls
- return (GHC.L l (GHC.BindStmt pat e' a b))
-#else
+ return (GHC.L l (GHC.BindStmt x pat e' a b))
+#elif __GLASGOW_HASKELL__ > 710
replaceDecls (GHC.L l (GHC.BindStmt pat e a b c)) newDecls
= do
e' <- replaceDecls e newDecls
return (GHC.L l (GHC.BindStmt pat e' a b c))
+#else
+ replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.BindStmt pat e' a b))
#endif
+#if __GLASGOW_HASKELL__ > 804
+ replaceDecls (GHC.L l (GHC.BodyStmt x e a b)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.BodyStmt x e' a b))
+#else
replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls
= do
e' <- replaceDecls e newDecls
return (GHC.L l (GHC.BodyStmt e' a b c))
+#endif
replaceDecls x _newDecls = return x
-- =====================================================================
@@ -947,9 +1074,15 @@ hasDeclsSybTransform workerHasDecls workerBind t = trf t
= workerBind b
lhsbind x = return x
+#if __GLASGOW_HASKELL__ > 804
+ lvald (GHC.L l (GHC.ValD x d)) = do
+ (GHC.L _ d') <- lhsbind (GHC.L l d)
+ return (GHC.L l (GHC.ValD x d'))
+#else
lvald (GHC.L l (GHC.ValD d)) = do
(GHC.L _ d') <- lhsbind (GHC.L l d)
return (GHC.L l (GHC.ValD d'))
+#endif
lvald x = return x
-- ---------------------------------------------------------------------
@@ -982,10 +1115,12 @@ hsDeclsGeneric t = q t
-- ---------------------------------
lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
-#if __GLASGOW_HASKELL__ <= 710
- lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do
-#else
+#if __GLASGOW_HASKELL__ > 804
+ lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do
+#elif __GLASGOW_HASKELL__ > 710
lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do
+#else
+ lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do
#endif
dss <- mapM hsDecls matches
return (concat dss)
@@ -995,7 +1130,11 @@ hsDeclsGeneric t = q t
-- ---------------------------------
+#if __GLASGOW_HASKELL__ > 804
+ lhsbindd (GHC.L l (GHC.ValD _ d)) = lhsbind (GHC.L l d)
+#else
lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d)
+#endif
lhsbindd _ = return []
-- ---------------------------------
@@ -1032,6 +1171,17 @@ orderedDecls parent decls = do
-- context in the AST.
hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
hsDeclsValBinds lb = case lb of
+#if __GLASGOW_HASKELL__ > 804
+ GHC.HsValBinds _ (GHC.ValBinds _ bs sigs) -> do
+ let
+ bds = map wrapDecl (GHC.bagToList bs)
+ sds = map wrapSig sigs
+ return (bds ++ sds)
+ GHC.HsValBinds _ (GHC.XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
+ GHC.HsIPBinds {} -> return []
+ GHC.EmptyLocalBinds {} -> return []
+ GHC.XHsLocalBindsLR {} -> return []
+#else
GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do
let
bds = map wrapDecl (GHC.bagToList bs)
@@ -1040,6 +1190,7 @@ hsDeclsValBinds lb = case lb of
GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"
GHC.HsIPBinds _ -> return []
GHC.EmptyLocalBinds -> return []
+#endif
-- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with
-- care, as this does not manage the declaration order, the
@@ -1049,22 +1200,45 @@ replaceDeclsValbinds :: (Monad m)
=> GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]
-> TransformT m (GHC.HsLocalBinds GhcPs)
replaceDeclsValbinds _ [] = do
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.EmptyLocalBinds GHC.noExt)
+#else
return (GHC.EmptyLocalBinds)
+#endif
+#if __GLASGOW_HASKELL__ > 804
+replaceDeclsValbinds (GHC.HsValBinds _ _b) new
+#else
replaceDeclsValbinds (GHC.HsValBinds _b) new
+#endif
= do
logTr "replaceDecls HsLocalBinds"
let decs = GHC.listToBag $ concatMap decl2Bind new
let sigs = concatMap decl2Sig new
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))
+#else
return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
-replaceDeclsValbinds (GHC.HsIPBinds _b) _new = error "undefined replaceDecls HsIPBinds"
+#endif
+replaceDeclsValbinds (GHC.HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds"
+#if __GLASGOW_HASKELL__ > 804
+replaceDeclsValbinds (GHC.EmptyLocalBinds _) new
+#else
replaceDeclsValbinds (GHC.EmptyLocalBinds) new
+#endif
= do
logTr "replaceDecls HsLocalBinds"
let newBinds = map decl2Bind new
newSigs = map decl2Sig new
let decs = GHC.listToBag $ concat newBinds
let sigs = concat newSigs
+#if __GLASGOW_HASKELL__ > 804
+ return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))
+#else
return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
+#endif
+#if __GLASGOW_HASKELL__ > 804
+replaceDeclsValbinds (GHC.XHsLocalBindsLR _) _ = error "replaceDeclsValbinds. XHsLocalBindsLR"
+#endif
-- ---------------------------------------------------------------------
@@ -1080,7 +1254,11 @@ modifyValD :: forall m t. (HasTransform m)
-> Decl
-> (Match -> [Decl] -> m ([Decl], Maybe t))
-> m (Decl,Maybe t)
+#if __GLASGOW_HASKELL__ > 804
+modifyValD p pb@(GHC.L ss (GHC.ValD _ (GHC.PatBind {} ))) f =
+#else
modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f =
+#endif
if ss == p
then do
ds <- liftT $ hsDeclsPatBindD pb
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
index a3ff4b2..152a843 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -355,6 +355,25 @@ data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContex
-- ---------------------------------------------------------------------
declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b
+
+#if __GLASGOW_HASKELL__ > 804
+declFun f (GHC.L l de) =
+ case de of
+ GHC.TyClD _ d -> f (GHC.L l d)
+ GHC.InstD _ d -> f (GHC.L l d)
+ GHC.DerivD _ d -> f (GHC.L l d)
+ GHC.ValD _ d -> f (GHC.L l d)
+ GHC.SigD _ d -> f (GHC.L l d)
+ GHC.DefD _ d -> f (GHC.L l d)
+ GHC.ForD _ d -> f (GHC.L l d)
+ GHC.WarningD _ d -> f (GHC.L l d)
+ GHC.AnnD _ d -> f (GHC.L l d)
+ GHC.RuleD _ d -> f (GHC.L l d)
+ GHC.SpliceD _ d -> f (GHC.L l d)
+ GHC.DocD _ d -> f (GHC.L l d)
+ GHC.RoleAnnotD _ d -> f (GHC.L l d)
+ GHC.XHsDecl _ -> error "declFun:XHsDecl"
+#else
declFun f (GHC.L l de) =
case de of
GHC.TyClD d -> f (GHC.L l d)
@@ -374,7 +393,7 @@ declFun f (GHC.L l de) =
#if __GLASGOW_HASKELL__ < 711
GHC.QuasiQuoteD d -> f (GHC.L l d)
#endif
-
+#endif
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
index aed8d96..c195340 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -263,7 +263,9 @@ isListComp :: GHC.HsStmtContext name -> Bool
isListComp cts = case cts of
GHC.ListComp -> True
GHC.MonadComp -> True
+#if __GLASGOW_HASKELL__ <= 804
GHC.PArrComp -> True
+#endif
GHC.DoExpr -> False
GHC.MDoExpr -> False
diff --git a/tests/Test.hs b/tests/Test.hs
index b7e96d6..3921890 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -28,11 +28,14 @@ import Test.HUnit
-- ---------------------------------------------------------------------
-data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 deriving (Eq, Ord, Show)
+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86
+ deriving (Eq, Ord, Show)
ghcVersion :: GHCVersion
ghcVersion =
-#if __GLASGOW_HASKELL__ > 802
+#if __GLASGOW_HASKELL__ > 804
+ GHC86
+#elif __GLASGOW_HASKELL__ > 802
GHC84
#elif __GLASGOW_HASKELL__ > 800
GHC82
@@ -46,13 +49,15 @@ ghcVersion =
testDirs :: [FilePath]
testDirs =
case ghcVersion of
- GHC710 -> ["ghc710-only","ghc710"]
- GHC80 -> ["ghc710", "ghc80"]
- GHC82 -> ["ghc710", "ghc80", "ghc82"]
- GHC84 -> ["ghc710", "ghc80", "ghc82", "ghc84" ]
- -- GHC84 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc84-copied"]
- -- GHC84 -> ["ghc84-copied"]
- -- GHC84 -> ["ghc84"]
+ 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" ]
+
+ -- GHC86 -> [ "ghc710", "ghc80", "ghc82", "ghc84"]
+ -- GHC86 -> ["ghc86-copied"]
+ -- GHC86 -> ["ghc86"]
-- ---------------------------------------------------------------------
@@ -192,39 +197,21 @@ tr = hSilence [stderr] $ do
tt' :: IO (Counts,Int)
tt' = runTestText (putTextToHandle stdout True) $ TestList [
- -- mkPrettyRoundtrip "ghc80" "Zwaluw.hs"
- -- mkPrettyRoundtrip "ghc80" "pmc007.hs"
- -- mkPrettyRoundtrip "ghc80" "MultiQuote.hs"
- -- mkPrettyRoundtrip "ghc80" "T10689a.hs"
-- mkPrettyRoundtrip "ghc82" "TensorTests.hs"
- -- mkParserTest "ghc84" "Main.hs"
- -- mkParserTest "ghc84" "Types.hs"
- -- , mkPrettyRoundtrip "ghc80" "BundleExport.hs"
- -- , mkPrettyRoundtrip "ghc80" "ExportSyntax.hs"
- -- , mkPrettyRoundtrip "ghc80" "export-class.hs"
- -- , mkPrettyRoundtrip "ghc80" "export-syntax.hs"
- -- , mkPrettyRoundtrip "ghc80" "export-type.hs"
-
- -- mkPrettyRoundtrip "ghc84" "Main.hs"
- -- mkPrettyRoundtrip "ghc84" "Types.hs"
+ mkParserTest "ghc710" "GADTContext.hs"
- mkPrettyRoundtrip "ghc80" "Vta1.hs"
- , mkPrettyRoundtrip "ghc80" "Vta2.hs"
+ -- mkParserTest "ghc86" "deriving-via-compile.hs"
+ -- mkParserTest "pre-ghc86" "TensorTests.hs"
+ -- , mkParserTest "pre-ghc86" "Webhook.hs"
+ -- , mkParserTest "ghc710" "RdrNames.hs"
- -- mkParserTest "ghc80" "BundleExport.hs"
+ -- mkPrettyRoundtrip "ghc86" "BinDU.hs"
+ -- , mkPrettyRoundtrip "ghc86" "Dial.hs"
- -- , mkParserTest "ghc710" "TypeOperators.hs"
- -- , mkParserTest "ghc80" "TestUtils.hs"
-
- -- mkParserTest "ghc84" "Functors.hs"
- -- , mkParserTest "ghc80" "MonadT.hs"
-
- -- mkParserTest "ghc80" "SemicolonIf.hs"
- -- mkParserTest "ghc80" "T10689a.hs"
- -- mkParserTest "ghc80" "MonadT.hs"
- -- mkParserTest "ghc710" "Ann01.hs"
+ -- mkParserTest "ghc84" "Types.hs"
+ -- , mkPrettyRoundtrip "ghc80" "export-type.hs"
-- Needs GHC changes
-- mkParserTest "failing" "CtorOp.hs"
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
index d685449..c6bfb72 100644
--- a/tests/Test/Transform.hs
+++ b/tests/Test/Transform.hs
@@ -95,8 +95,13 @@ changeWhereIn3a ans (GHC.L l p) = do
-- prior local decl. So it adds a "where" annotation.
changeLocalDecls2 :: Changer
changeLocalDecls2 ans (GHC.L l p) = do
+#if __GLASGOW_HASKELL__ > 804
+ Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
+ Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")
+#else
Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")
+#endif
let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns
-- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns
@@ -110,8 +115,10 @@ changeLocalDecls2 ans (GHC.L l p) = do
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do
#elif __GLASGOW_HASKELL__ <= 802
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do
-#else
+#elif __GLASGOW_HASKELL__ <= 804
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do
+#else
+ replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do
#endif
newSpan <- uniqueSrcSpanT
let
@@ -132,16 +139,24 @@ changeLocalDecls2 ans (GHC.L l p) = do
let decls = [s,d]
-- 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])
+ [GHC.L ls sig]))
+#else
let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])
[GHC.L ls sig]))
+#endif
#if __GLASGOW_HASKELL__ <= 710
return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds)))
#elif __GLASGOW_HASKELL__ <= 802
bindSpan <- uniqueSrcSpanT
return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds))))
-#else
+#elif __GLASGOW_HASKELL__ <= 804
bindSpan <- uniqueSrcSpanT
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))))
#endif
replaceLocalBinds x = return x
-- putStrLn $ "log:" ++ intercalate "\n" w
@@ -152,8 +167,13 @@ changeLocalDecls2 ans (GHC.L l p) = do
-- | Add a local declaration with signature to LocalDecl
changeLocalDecls :: Changer
changeLocalDecls ans (GHC.L l p) = do
+#if __GLASGOW_HASKELL__ > 804
+ Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
+ Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")
+#else
Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")
+#endif
let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns
-- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns
@@ -167,8 +187,10 @@ changeLocalDecls ans (GHC.L l p) = do
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do
#elif __GLASGOW_HASKELL__ <= 802
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do
-#else
+#elif __GLASGOW_HASKELL__ <= 804
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do
+#else
+ replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do
#endif
a1 <- getAnnsT
a' <- case sigs of
@@ -181,15 +203,23 @@ changeLocalDecls ans (GHC.L l p) = do
let decls = s:d:oldDecls
-- 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)
+ (GHC.L ls sig:sigs)))
+#else
let binds' = (GHC.HsValBinds
(GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)
(GHC.L ls sig:sigs)))
+#endif
#if __GLASGOW_HASKELL__ <= 710
return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds')))
#elif __GLASGOW_HASKELL__ <= 802
return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds'))))
-#else
+#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'))))
#endif
replaceLocalBinds x = return x
-- putStrLn $ "log:" ++ intercalate "\n" w
@@ -289,22 +319,26 @@ rename newNameStr spans a
replaceRdr x = x
replaceHsVar :: GHC.LHsExpr GhcPs -> GHC.LHsExpr GhcPs
- replaceHsVar (GHC.L ln (GHC.HsVar _))
+ replaceHsVar (GHC.L ln (GHC.HsVar{}))
#if __GLASGOW_HASKELL__ <= 710
| cond ln = GHC.L ln (GHC.HsVar newName)
-#else
+#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))
#endif
replaceHsVar x = x
#if __GLASGOW_HASKELL__ > 802
replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
#endif
- replacePat (GHC.L ln (GHC.VarPat _))
+ replacePat (GHC.L ln (GHC.VarPat {}))
#if __GLASGOW_HASKELL__ <= 710
| cond ln = GHC.L ln (GHC.VarPat newName)
-#else
+#elif __GLASGOW_HASKELL__ <= 804
| cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))
+#else
+ | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName))
#endif
replacePat x = x
@@ -334,16 +368,27 @@ changeLetIn1 ans parsed
replace :: GHC.HsExpr GhcPs -> GHC.HsExpr GhcPs
#if __GLASGOW_HASKELL__ <= 710
replace (GHC.HsLet localDecls expr@(GHC.L _ _))
-#else
+#elif __GLASGOW_HASKELL__ <= 804
replace (GHC.HsLet (GHC.L lb localDecls) expr@(GHC.L _ _))
+#else
+ replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _))
#endif
=
+#if __GLASGOW_HASKELL__ > 804
+ let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls
+ bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls
+#else
let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls
bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls
+#endif
#if __GLASGOW_HASKELL__ <= 710
in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr)
-#else
+#elif __GLASGOW_HASKELL__ <= 802
in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr)
+#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)
#endif
replace x = x
@@ -494,8 +539,10 @@ addLocaLDecl6 ans lp = do
#if __GLASGOW_HASKELL__ <= 710
let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1
-#else
+#elif __GLASGOW_HASKELL__ <= 804
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
#endif
balanceComments m1 m2
@@ -601,8 +648,10 @@ rmDecl5 ans lp = do
go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs)
#if __GLASGOW_HASKELL__ <= 710
go (GHC.HsLet lb expr) = do
-#else
+#elif __GLASGOW_HASKELL__ <= 804
go (GHC.HsLet (GHC.L l lb) expr) = do
+#else
+ go (GHC.HsLet _ (GHC.L l lb) expr) = do
#endif
decs <- hsDeclsValBinds lb
let dec = last decs
@@ -610,8 +659,10 @@ rmDecl5 ans lp = do
lb' <- replaceDeclsValbinds lb [dec]
#if __GLASGOW_HASKELL__ <= 710
return (GHC.HsLet lb' expr)
-#else
+#elif __GLASGOW_HASKELL__ <= 804
return (GHC.HsLet (GHC.L l lb') expr)
+#else
+ return (GHC.HsLet GHC.noExt (GHC.L l lb') expr)
#endif
go x = return x
@@ -671,9 +722,12 @@ rmTypeSig1 ans lp = do
#if __GLASGOW_HASKELL__ <= 710
(GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1
s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p)))
-#else
+#elif __GLASGOW_HASKELL__ <= 804
(GHC.L l (GHC.SigD (GHC.TypeSig names typ))) = s1
s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ)))
+#else
+ (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1
+ s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ)))
#endif
replaceDecls lp (s1':d1:d2)
@@ -709,7 +763,10 @@ addHiding1 ans (GHC.L l p) = do
[GHC.L li imp1,imp2] = GHC.hsmodImports p
n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))
n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))
-#if __GLASGOW_HASKELL__ > 800
+#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)))
+#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)))
#else
@@ -740,7 +797,10 @@ addHiding2 ans (GHC.L l p) = do
Just (_,GHC.L lh ns) = GHC.ideclHiding imp1
n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))
n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))
-#if __GLASGOW_HASKELL__ > 800
+#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)))
+#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)))
#else
diff --git a/tests/examples/ghc710/GADTContext.hs b/tests/examples/ghc710/GADTContext.hs
deleted file mode 100644
index 02b92ac..0000000
--- a/tests/examples/ghc710/GADTContext.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StandaloneDeriving #-}
-
-data StackItem a where
- Snum :: forall a. Fractional a => a -> StackItem a
- Sop :: OpDesc -> StackItem a
-deriving instance Show a => Show (StackItem a)
-
--- AZ added to test Trac #10399
-data MaybeDefault v where
- SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
- SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v -> a -> MaybeDefault [a])
diff --git a/tests/examples/ghc710/OveridingPrimitives.hs b/tests/examples/ghc710/OveridingPrimitives.hs
index 212e9da..dd9ddb0 100644
--- a/tests/examples/ghc710/OveridingPrimitives.hs
+++ b/tests/examples/ghc710/OveridingPrimitives.hs
@@ -4,3 +4,4 @@
(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts)
(~#) = cascadeW
infixr 0 ~#
+
diff --git a/tests/examples/ghc80/GADTContext.hs b/tests/examples/ghc80/GADTContext.hs
new file mode 100644
index 0000000..53230fe
--- /dev/null
+++ b/tests/examples/ghc80/GADTContext.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+data StackItem a where
+ Snum :: forall a. Fractional a => a -> StackItem a
+ Sop :: OpDesc -> StackItem a
+deriving instance Show a => Show (StackItem a)
+
+type MPI = ?mpi_secret :: MPISecret
+
+mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)
+
+data MaybeDefault v where
+ SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
+ SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
+ -> a -> MaybeDefault [a])
+ TestParens :: (forall v . (Eq v) => MaybeDefault v)
+ TestParens2 :: (forall v . ((Eq v)) => MaybeDefault v)
+ TestParens3 :: (forall v . (((Eq v)) => (MaybeDefault v)))
+ TestParens4 :: (forall v . (((Eq v)) => (MaybeDefault v -> MaybeDefault v)))
+
+data T a where
+ K1 :: forall a. Ord a => { x :: [a], y :: Int } -> T a
+ K2 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> T a
+ K3 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> (T a)
+ K4 :: (forall a. Ord a => { x :: [a], y :: Int } -> T a)
+
+[t| Map.Map T.Text $tc |]
+
+bar $( [p| x |] ) = x
diff --git a/tests/examples/ghc86/Arith.hs b/tests/examples/ghc86/Arith.hs
new file mode 100644
index 0000000..f516d3a
--- /dev/null
+++ b/tests/examples/ghc86/Arith.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Arith where
+
+data E a b = E (a -> b) (b -> a)
+
+eqRefl :: E a a
+eqRefl = E id id
+
+-- just to construct unique strings
+data W
+data M a
+
+-- terms
+data Var a where
+ VarW :: Var W
+ VarM :: Var (M a)
+
+-- expose s in the type level making sure it is a string
+data Abs s e1 where
+ Abs :: (Var s) -> e1 -> Abs (Var s) e1
+
+data App e1 e2 = App e1 e2
+data Lit = Lit
+
+data TyBase = TyBase
+data TyArr t1 t2 = TyArr t1 t2
+
+-- (x:ty) in G
+data IN g p where
+ INOne :: IN (g,(x,ty)) (x,ty)
+ INShift :: IN g0 (x,ty) -> IN (g0,a) (x,ty)
+
+data INEX g x where
+ INEX :: IN g (x,v) -> INEX g x
+
+
+-- G1 subseteq G2
+type SUP g1 g2 = forall a. IN g1 a -> IN g2 a
+
+-- typing derivations
+data DER g a ty where
+ DVar :: IN (g,g0) ((Var a),ty) -> DER (g,g0) (Var a) ty -- the g,g0 makes sure that env is non-empty
+ DApp :: DER g a1 (TyArr ty1 ty2) ->
+ DER g a2 ty1 -> DER g (App a1 a2) ty2
+ DAbs :: DER (g,(Var a,ty1)) e ty2 ->
+ DER g (Abs (Var a) e) (TyArr ty1 ty2)
+ DLit :: DER g Lit TyBase
+
+-- G |- \x.x : a -> a
+test1 :: DER g (Abs (Var W) (Var W)) (TyArr ty ty)
+test1 = DAbs (DVar INOne)
+
+-- G |- (\x.x) Lit : Lit
+test2 :: DER g (App (Abs (Var W) (Var W)) Lit) TyBase
+test2 = DApp (DAbs (DVar INOne)) DLit
+
+-- G |- \x.\y. x y : (C -> C) -> C -> C
+test3 :: DER g (Abs (Var W) (Abs (Var (M W)) (App (Var W) (Var (M W))))) (TyArr (TyArr ty ty) (TyArr ty ty))
+test3 = DAbs (DAbs (DApp (DVar (INShift INOne)) (DVar INOne)))
+
+data ISVAL e where
+ ISVALAbs :: ISVAL (Abs (Var v) e)
+ ISVALLit :: ISVAL Lit
+
+data React e1 e2 where
+ SUBSTReact :: React (Abs (Var y) e) v
+
+-- evaluation
+data EDER e1 e2 where
+ -- EVar :: IN (a,val) -> ISVAL val -> EDER c a val
+ EApp1 :: EDER e1 e1' -> EDER (App e1 e2) (App e1' e2)
+ EApp2 :: ISVAL v1 -> EDER e2 e2' -> EDER (App v1 e2) (App v1 e2')
+ EAppAbs :: ISVAL v2 -> React (Abs (Var v) e) v2 -> EDER (App (Abs (Var v) e) v2) e1
+
+-- (\x.x) 3 -> 3
+-- test4 :: EDER (App (Abs (Var W) (Var W)) Lit) Lit
+-- test4 = EAppAbs ISVALLit SUBSTEqVar
+
+
+-- existential
+data REDUCES e1 where
+ REDUCES :: EDER e1 e2 -> REDUCES e1
+
+-- data WFEnv x c g where
+-- WFOne :: ISVAL v -> DER g v ty -> WFEnv (Var x) (c,(Var x,v)) (g,(Var x,ty))
+-- WFShift :: WFEnv v c0 g0 -> WFEnv v (c0,(y,y1)) (g0,(z,z1))
+
+-- data WFENVWRAP c g where
+-- WFENVWRAP :: (forall v ty . IN g (v,ty) -> WFEnv v c g) -> WFENVWRAP c g
+
+
+-- data INEXVAL c x where
+-- INEXVAL :: IN c (x,v) -> ISVAL v -> INEXVAL c x
+
+-- -- the first cool theorem!
+-- fromTEnvToEnv :: IN g (x,ty) -> WFEnv x c g -> INEXVAL c x
+-- fromTEnvToEnv INOne (WFOne isv _) = INEXVAL INOne isv
+-- fromTEnvToEnv (INShift ind1) (WFShift ind2) =
+-- case (fromTEnvToEnv ind1 ind2) of
+-- INEXVAL i isv -> INEXVAL (INShift i) isv
+
+
+data ISLAMBDA v where ISLAMBDA :: ISLAMBDA (Abs (Var x) e)
+data ISLIT v where ISLIT :: ISLIT Lit
+
+data EXISTAbs where
+ EXISTSAbs :: (Abs (Var x) e) -> EXISTAbs
+
+bot = bot
+
+canFormsLam :: ISVAL v -> DER g v (TyArr ty1 ty2) -> ISLAMBDA v
+canFormsLam ISVALAbs _ = ISLAMBDA
+-- canFormsLam ISVALLit _ = bot <== unfortunately I cannot catch this ... requires some exhaustiveness check :-(
+
+canFormsLit :: ISVAL v -> DER g v TyBase -> ISLIT v
+canFormsLit ISVALLit _ = ISLIT
+
+data NULL
+
+progress :: DER NULL e ty -> Either (ISVAL e) (REDUCES e)
+
+progress (DAbs prem) = Left ISVALAbs
+progress (DLit) = Left ISVALLit
+-- progress (DVar iw) = bot <== here is the cool trick! I cannot even wite this down!
+progress (DApp e1 e2) =
+ case (progress e1) of
+ Right (REDUCES r1) -> Right (REDUCES (EApp1 r1))
+ Left isv1 -> case (progress e2) of
+ Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2))
+ Left isv2 -> case (canFormsLam isv1 e1) of
+ ISLAMBDA -> Right (REDUCES (EAppAbs isv2 SUBSTReact))
+
+
+-- case fromTEnvToEnv iw (f iw) of
+-- INEXVAL i isv -> Right (REDUCES (EVar i isv))
+-- progress (WFENVWRAP f) (DApp e1 e2) =
+-- case (progress (WFENVWRAP f) e1) of
+-- Right (REDUCES r1) -> Right (REDUCES (EApp1 r1))
+-- Left isv1 -> case (progress (WFENVWRAP f) e2) of
+-- Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2))
+-- Left isv2 -> case (canFormsLam isv1 e1) of
+-- ISLAMBDA -> EAppAbs isv2 e1
+
diff --git a/tests/examples/ghc86/BadTelescope.hs b/tests/examples/ghc86/BadTelescope.hs
new file mode 100644
index 0000000..7819c4f
--- /dev/null
+++ b/tests/examples/ghc86/BadTelescope.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeInType #-}
+
+module BadTelescope where
+
+import Data.Kind
+
+data SameKind :: k -> k -> Type
+
+data X a k (b :: k) (c :: SameKind a b)
diff --git a/tests/examples/ghc86/BadTelescope2.hs b/tests/examples/ghc86/BadTelescope2.hs
new file mode 100644
index 0000000..78d1a37
--- /dev/null
+++ b/tests/examples/ghc86/BadTelescope2.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeInType, ExplicitForAll #-}
+
+module BadTelescope2 where
+
+import Data.Kind
+import Data.Proxy
+
+data SameKind :: k -> k -> Type
+
+foo :: forall a k (b :: k). SameKind a b
+foo = undefined
+
+bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d
+bar = undefined
diff --git a/tests/examples/ghc86/BadTelescope3.hs b/tests/examples/ghc86/BadTelescope3.hs
new file mode 100644
index 0000000..468c646
--- /dev/null
+++ b/tests/examples/ghc86/BadTelescope3.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeInType, ExplicitForAll #-}
+
+module BadTelescope3 where
+
+import Data.Kind
+
+data SameKind :: k -> k -> Type
+
+type S a k (b :: k) = SameKind a b
diff --git a/tests/examples/ghc86/BadTelescope4.hs b/tests/examples/ghc86/BadTelescope4.hs
new file mode 100644
index 0000000..a2d82fd
--- /dev/null
+++ b/tests/examples/ghc86/BadTelescope4.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ExistentialQuantification, TypeInType #-}
+module BadTelescope4 where
+
+import Data.Proxy
+import Data.Kind
+
+data SameKind :: k -> k -> Type
+
+data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
+
+data Borked a (b :: k) = forall (c :: k). B (Proxy c)
+ -- this last one is OK. But there was a bug involving renaming
+ -- that failed here, so the test case remains.
diff --git a/tests/examples/ghc86/Boot1.hs b/tests/examples/ghc86/Boot1.hs
new file mode 100644
index 0000000..bf17059
--- /dev/null
+++ b/tests/examples/ghc86/Boot1.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE RankNTypes #-}
+module Boot where
+
+import A
+
+data Data = forall n. Class n => D n
+
diff --git a/tests/examples/ghc86/Dep3.hs b/tests/examples/ghc86/Dep3.hs
new file mode 100644
index 0000000..f22f9f8
--- /dev/null
+++ b/tests/examples/ghc86/Dep3.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-}
+
+module Dep3 where
+
+import Data.Kind
+import GHC.Exts ( Constraint )
+
+type Star1 = Type
+
+data Id1 (a :: Star1) where
+ Id1 :: a -> Id1 a
+
+data Id1' :: Star1 -> Type where
+ Id1' :: a -> Id1' a
+
+type family Star2 x where
+ Star2 x = Type
+
+data Id2a (a :: Star2 Constraint) = Id2a a
+
+
+data Id2 (a :: Star2 Constraint) where
+ Id2 :: a -> Id2 a
+
+data Id2' :: Star2 Constraint -> Type where
+ Id2' :: a -> Id2' a
diff --git a/tests/examples/ghc86/GADT.hs b/tests/examples/ghc86/GADT.hs
new file mode 100644
index 0000000..521f803
--- /dev/null
+++ b/tests/examples/ghc86/GADT.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE RankNTypes #-}
+
+data Empty
+data NonEmpty
+
+data SafeList x y where
+ Nil :: SafeList x Empty
+ Cons:: Eq x => x -> SafeList x y -> SafeList x NonEmpty
+ One :: Eq x => x -> SafeList x Empty -> SafeList x NonEmpty
+
+safeHead :: SafeList x NonEmpty -> x
+safeHead (Cons x _) = x
+
+foo = Cons 3 (Cons 6 (Cons 9 Nil))
+
+
+data Dict x where
+ DictN :: Num x => x -> Dict x
+ DictE :: Eq x => x -> Dict x
+
+data Exist where
+ Exist :: forall a. a -> Exist
diff --git a/tests/examples/ghc86/HashTab.hs b/tests/examples/ghc86/HashTab.hs
new file mode 100644
index 0000000..72663bd
--- /dev/null
+++ b/tests/examples/ghc86/HashTab.hs
@@ -0,0 +1,341 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.HashTable
+-- Copyright : (c) The University of Glasgow 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- An implementation of extensible hash tables, as described in
+-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,
+-- pp. 446--457. The implementation is also derived from the one
+-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).
+--
+-----------------------------------------------------------------------------
+
+module Data.HashTab (
+ -- * Basic hash table operations
+ HashTable, new, insert, delete, lookup, update,
+ -- * Converting to and from lists
+ fromList, toList,
+ -- * Hash functions
+ -- $hash_functions
+ hashInt, hashString,
+ prime,
+ -- * Diagnostics
+ longestChain
+ ) where
+
+-- This module is imported by Data.Typeable, which is pretty low down in the
+-- module hierarchy, so don't import "high-level" modules
+
+-- Right now we import high-level modules with gay abandon.
+import Prelude hiding ( lookup )
+import Data.Tuple ( fst )
+import Data.Bits
+import Data.Maybe
+import Data.List ( maximumBy, partition, concat, foldl )
+import Data.Int ( Int32 )
+
+import Data.Array.Base
+import Data.Array hiding (bounds)
+import Data.Array.IO
+
+import Data.Char ( ord )
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Control.Monad ( mapM, sequence_ )
+
+
+-----------------------------------------------------------------------
+
+readHTArray :: HTArray a -> Int32 -> IO a
+readMutArray :: MutArray a -> Int32 -> IO a
+writeMutArray :: MutArray a -> Int32 -> a -> IO ()
+freezeArray :: MutArray a -> IO (HTArray a)
+thawArray :: HTArray a -> IO (MutArray a)
+newMutArray :: (Int32, Int32) -> a -> IO (MutArray a)
+#if defined(DEBUG) || defined(__NHC__)
+type MutArray a = IOArray Int32 a
+type HTArray a = MutArray a
+newMutArray = newArray
+readHTArray = readArray
+readMutArray = readArray
+writeMutArray = writeArray
+freezeArray = return
+thawArray = return
+#else
+type MutArray a = IOArray Int32 a
+type HTArray a = Array Int32 a
+newMutArray = newArray
+readHTArray arr i = return $! (unsafeAt arr (fromIntegral i))
+readMutArray arr i = unsafeRead arr (fromIntegral i)
+writeMutArray arr i x = unsafeWrite arr (fromIntegral i) x
+freezeArray = unsafeFreeze
+thawArray = unsafeThaw
+#endif
+
+newtype HashTable key val = HashTable (IORef (HT key val))
+-- TODO: the IORef should really be an MVar.
+
+data HT key val
+ = HT {
+ kcount :: !Int32, -- Total number of keys.
+ buckets :: !(HTArray [(key,val)]),
+ bmask :: !Int32,
+ hash_fn :: key -> Int32,
+ cmp :: key -> key -> Bool
+ }
+
+-- -----------------------------------------------------------------------------
+-- Sample hash functions
+
+-- $hash_functions
+--
+-- This implementation of hash tables uses the low-order /n/ bits of the hash
+-- value for a key, where /n/ varies as the hash table grows. A good hash
+-- function therefore will give an even distribution regardless of /n/.
+--
+-- If your keyspace is integrals such that the low-order bits between
+-- keys are highly variable, then you could get away with using 'id'
+-- as the hash function.
+--
+-- We provide some sample hash functions for 'Int' and 'String' below.
+
+-- | A sample hash function for 'Int', implemented as simply @(x `mod` P)@
+-- where P is a suitable prime (currently 1500007). Should give
+-- reasonable results for most distributions of 'Int' values, except
+-- when the keys are all multiples of the prime!
+--
+hashInt :: Int -> Int32
+hashInt = (`rem` prime) . fromIntegral
+
+-- | A sample hash function for 'String's. The implementation is:
+--
+-- > hashString = fromIntegral . foldr f 0
+-- > where f c m = ord c + (m * 128) `rem` 1500007
+--
+-- which seems to give reasonable results.
+--
+hashString :: String -> Int32
+hashString = fromIntegral . foldl f 0
+ where f m c = ord c + (m * 128) `rem` fromIntegral prime
+
+-- | A prime larger than the maximum hash table size
+prime :: Int32
+prime = 1500007
+
+-- -----------------------------------------------------------------------------
+-- Parameters
+
+tABLE_MAX = 1024 * 1024 :: Int32 -- Maximum size of hash table
+#if tABLE_MIN
+#else
+tABLE_MIN = 16 :: Int32
+
+hLOAD = 4 :: Int32 -- Maximum average load of a single hash bucket
+
+hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation
+#endif
+
+{- Hysteresis favors long association-list-like behavior for small tables. -}
+
+-- -----------------------------------------------------------------------------
+-- Creating a new hash table
+
+-- | Creates a new hash table. The following property should hold for the @eq@
+-- and @hash@ functions passed to 'new':
+--
+-- > eq A B => hash A == hash B
+--
+new
+ :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys
+ -> (key -> Int32) -- ^ @hash@: A hash function on keys
+ -> IO (HashTable key val) -- ^ Returns: an empty hash table
+
+new cmpr hash = do
+ -- make a new hash table with a single, empty, segment
+ let mask = tABLE_MIN-1
+ bkts' <- newMutArray (0,mask) []
+ bkts <- freezeArray bkts'
+
+ let
+ kcnt = 0
+ ht = HT { buckets=bkts, kcount=kcnt, bmask=mask,
+ hash_fn=hash, cmp=cmpr }
+
+ table <- newIORef ht
+ return (HashTable table)
+
+-- -----------------------------------------------------------------------------
+-- Inserting a key\/value pair into the hash table
+
+-- | Inserts a key\/value mapping into the hash table.
+--
+-- Note that 'insert' doesn't remove the old entry from the table -
+-- the behaviour is like an association list, where 'lookup' returns
+-- the most-recently-inserted mapping for a key in the table. The
+-- reason for this is to keep 'insert' as efficient as possible. If
+-- you need to update a mapping, then we provide 'update'.
+--
+insert :: HashTable key val -> key -> val -> IO ()
+
+insert (HashTable ref) key val = do
+ table@HT{ kcount=k, buckets=bkts, bmask=b } <- readIORef ref
+ let table1 = table{ kcount = k+1 }
+ indx = bucketIndex table key
+ bucket <- readHTArray bkts indx
+ bkts' <- thawArray bkts
+ writeMutArray bkts' indx ((key,val):bucket)
+ freezeArray bkts'
+ table2 <-
+ if tooBig k b
+ then expandHashTable table1
+ else return table1
+ writeIORef ref table2
+
+tooBig :: Int32 -> Int32 -> Bool
+tooBig k b = k-hYSTERESIS > hLOAD * b
+
+bucketIndex :: HT key val -> key -> Int32
+bucketIndex HT{ hash_fn=hash, bmask=mask } key =
+ let h = hash key
+ in (h .&. mask)
+
+expandHashTable :: HT key val -> IO (HT key val)
+expandHashTable
+ table@HT{ buckets=bkts, bmask=mask } = do
+ let
+ oldsize = mask + 1
+ newmask = mask + mask + 1
+ newsize = newmask + 1
+ --
+ if newsize > tABLE_MAX
+ then return table
+ else do
+ --
+ newbkts' <- newMutArray (0,newmask) []
+
+ let
+ table'=table{ bmask=newmask }
+ splitBucket oldindex = do
+ bucket <- readHTArray bkts oldindex
+ let (oldb,newb) = partition ((oldindex==).bucketIndex table' . fst) bucket
+ writeMutArray newbkts' oldindex oldb
+ writeMutArray newbkts' (oldindex + oldsize) newb
+ mapM_ splitBucket [0..mask]
+
+ newbkts <- freezeArray newbkts'
+
+ return ( table'{ buckets=newbkts } )
+
+-- -----------------------------------------------------------------------------
+-- Deleting a mapping from the hash table
+
+-- Remove a key from a bucket
+deleteBucket :: (key -> Bool) -> [(key,val)] -> (Int32, [(key, val)])
+deleteBucket _ [] = (0,[])
+deleteBucket del (pair@(k,_):bucket) =
+ case deleteBucket del bucket of
+ (dels, bucket') | del k -> dels' `seq` (dels', bucket')
+ | otherwise -> (dels, pair:bucket')
+ where dels' = dels + 1
+
+-- | Remove an entry from the hash table.
+delete :: HashTable key val -> key -> IO ()
+
+delete (HashTable ref) key = do
+ table@HT{ buckets=bkts, kcount=kcnt, cmp=cmpr } <- readIORef ref
+ let indx = bucketIndex table key
+ bkts' <- thawArray bkts
+ bucket <- readMutArray bkts' indx
+ let (removed,bucket') = deleteBucket (cmpr key) bucket
+ writeMutArray bkts' indx bucket'
+ freezeArray bkts'
+ writeIORef ref ( table{kcount = kcnt - removed} )
+
+-- -----------------------------------------------------------------------------
+-- Updating a mapping in the hash table
+
+-- | Updates an entry in the hash table, returning 'True' if there was
+-- already an entry for this key, or 'False' otherwise. After 'update'
+-- there will always be exactly one entry for the given key in the table.
+--
+-- 'insert' is more efficient than 'update' if you don't care about
+-- multiple entries, or you know for sure that multiple entries can't
+-- occur. However, 'update' is more efficient than 'delete' followed
+-- by 'insert'.
+update :: HashTable key val -> key -> val -> IO Bool
+
+update (HashTable ref) key val = do
+ table@HT{ kcount=k, buckets=bkts, cmp=cmpr, bmask=b } <- readIORef ref
+ let indx = bucketIndex table key
+ bkts' <- thawArray bkts
+ bucket <- readMutArray bkts' indx
+ let (deleted,bucket') = deleteBucket (cmpr key) bucket
+ k' = k + 1 - deleted
+ table1 = table{ kcount=k' }
+
+ writeMutArray bkts' indx ((key,val):bucket')
+ freezeArray bkts'
+ table2 <-
+ if tooBig k' b -- off by one from insert's resize heuristic.
+ then expandHashTable table1
+ else return table1
+ writeIORef ref table2
+ return (deleted>0)
+
+-- -----------------------------------------------------------------------------
+-- Looking up an entry in the hash table
+
+-- | Looks up the value of a key in the hash table.
+lookup :: HashTable key val -> key -> IO (Maybe val)
+
+lookup (HashTable ref) key = do
+ table@HT{ buckets=bkts, cmp=cmpr } <- readIORef ref
+ let indx = bucketIndex table key
+ bucket <- readHTArray bkts indx
+ case [ val | (key',val) <- bucket, cmpr key key' ] of
+ [] -> return Nothing
+ (v:_) -> return (Just v)
+
+-- -----------------------------------------------------------------------------
+-- Converting to/from lists
+
+-- | Convert a list of key\/value pairs into a hash table. Equality on keys
+-- is taken from the Eq instance for the key type.
+--
+fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)
+fromList hash list = do
+ table <- new (==) hash
+ sequence_ [ insert table k v | (k,v) <- list ]
+ return table
+
+-- | Converts a hash table to a list of key\/value pairs.
+--
+toList :: (Ord key, Ord val) => HashTable key val -> IO [(key,val)]
+toList (HashTable ref) = do
+ HT{ buckets=bkts, bmask=b } <- readIORef ref
+ fmap concat (mapM (readHTArray bkts) [0..b])
+
+-- -----------------------------------------------------------------------------
+-- Diagnostics
+
+-- | This function is useful for determining whether your hash function
+-- is working well for your data set. It returns the longest chain
+-- of key\/value pairs in the hash table for which all the keys hash to
+-- the same bucket. If this chain is particularly long (say, longer
+-- than 10 elements), then it might be a good idea to try a different
+-- hash function.
+--
+longestChain :: HashTable key val -> IO [(key,val)]
+longestChain (HashTable ref) = do
+ HT{ buckets=bkts, bmask=b } <- readIORef ref
+ let lengthCmp (_:x)(_:y) = lengthCmp x y
+ lengthCmp [] [] = EQ
+ lengthCmp [] _ = LT
+ lengthCmp _ [] = GT
+ fmap (maximumBy lengthCmp) (mapM (readHTArray bkts) [0..b])
+
diff --git a/tests/examples/ghc86/KindEqualities2.hs b/tests/examples/ghc86/KindEqualities2.hs
new file mode 100644
index 0000000..0d6233c
--- /dev/null
+++ b/tests/examples/ghc86/KindEqualities2.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll,
+ TemplateHaskell, UndecidableInstances, ScopedTypeVariables,
+ TypeInType #-}
+
+module KindEqualities2 where
+
+import Data.Kind
+import GHC.Exts ( Any )
+
+data Kind = Star | Arr Kind Kind
+
+data Ty :: Kind -> Type where
+ TInt :: Ty Star
+ TBool :: Ty Star
+ TMaybe :: Ty (Arr Star Star)
+ TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2
+
+
+data TyRep (k :: Kind) (t :: Ty k) where
+ TyInt :: TyRep Star TInt
+ TyBool :: TyRep Star TBool
+ TyMaybe :: TyRep (Arr Star Star) TMaybe
+ TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b)
+
+type family IK (k :: Kind)
+type instance IK Star = Type
+type instance IK (Arr k1 k2) = IK k1 -> IK k2
+
+$(return []) -- necessary because the following instances depend on the
+ -- previous ones.
+
+type family I (t :: Ty k) :: IK k
+type instance I TInt = Int
+type instance I TBool = Bool
+type instance I TMaybe = Maybe
+type instance I (TApp a b) = (I a) (I b)
+
+zero :: forall (a :: Ty 'Star). TyRep Star a -> I a
+zero TyInt = 0
+zero TyBool = False
+zero (TyApp TyMaybe TyInt) = Nothing
+
+main = print $ zero (TyApp TyMaybe TyInt)
diff --git a/tests/examples/ghc86/LiftedConstructors.hs b/tests/examples/ghc86/LiftedConstructors.hs
new file mode 100644
index 0000000..3e6bd0e
--- /dev/null
+++ b/tests/examples/ghc86/LiftedConstructors.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}
+
+give :: b -> Pattern '[b] a
+give b = Pattern (const (Just $ oneT b))
+
+
+pfail :: Pattern '[] a
+pfail = is (const False)
+
+(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a
+(/\) = mk2 (\a -> Just (a,a))
+
+data Pattern :: [Type] -> Type where
+ Nil :: Pattern '[]
+ Cons :: Maybe h -> Pattern t -> Pattern (h ': t)
+
+type Pos = '("vpos", V3 GLfloat)
+type Tag = '("tagByte", V1 Word8)
+
+-- | Alias for the 'In' type from the 'Direction' kind, allows users to write
+-- the 'BroadcastChan In a' type without enabling DataKinds.
+type In = 'In
+-- | Alias for the 'Out' type from the 'Direction' kind, allows users to write
+-- the 'BroadcastChan Out a' type without enabling DataKinds.
+type Out = 'Out
diff --git a/tests/examples/ghc86/Parser.hs b/tests/examples/ghc86/Parser.hs
new file mode 100644
index 0000000..b75f6e0
--- /dev/null
+++ b/tests/examples/ghc86/Parser.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+{-# OPTIONS_GHC
+ -Weverything
+ -fno-warn-unsafe
+ -fno-warn-implicit-prelude
+ -fno-warn-missing-import-lists
+ -fno-warn-noncanonical-monoid-instances
+ -O2
+#-}
+
+module Packed.Bytes.Parser
+ ( Parser(..)
+ , Result(..)
+ , Leftovers(..)
+ , parseStreamST
+ , any
+ , failure
+ ) where
+
+import Control.Applicative
+import Data.Primitive (ByteArray(..))
+import GHC.Int (Int(I#))
+import GHC.ST (ST(..),runST)
+import GHC.Types (TYPE)
+import GHC.Word (Word8(W8#))
+import Packed.Bytes (Bytes(..))
+import Packed.Bytes.Stream.ST (ByteStream(..))
+import Prelude hiding (any,replicate)
+
+import qualified Data.Primitive as PM
+import qualified Control.Monad
+
+import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#)
+
+type Bytes# = (# ByteArray#, Int#, Int# #)
+type Maybe# (a :: TYPE r) = (# (# #) | a #)
+type Leftovers# s = (# Bytes# , ByteStream s #)
+type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #)
+
+data Result s a = Result
+ { resultLeftovers :: !(Maybe (Leftovers s))
+ , resultValue :: !(Maybe a)
+ }
+
+data Leftovers s = Leftovers
+ { leftoversChunk :: {-# UNPACK #-} !Bytes
+ -- ^ The last chunk pulled from the stream
+ , leftoversStream :: ByteStream s
+ -- ^ The remaining stream
+ }
+
+data PureResult a = PureResult
+ { pureResultLeftovers :: {-# UNPACK #-} !Bytes
+ , pureResultValue :: !(Maybe a)
+ } deriving (Show)
+
+emptyByteArray :: ByteArray
+emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray)
+
+parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a)
+parseStreamST stream (Parser f) = ST $ \s0 ->
+ case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of
+ (# s1, r #) -> (# s1, boxResult r #)
+
+boxResult :: Result# s a -> Result s a
+boxResult (# leftovers, val #) = case val of
+ (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing
+ (# | a #) -> Result (boxLeftovers leftovers) (Just a)
+
+boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s)
+boxLeftovers (# (# #) | #) = Nothing
+boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream)
+
+instance Functor Parser where
+ fmap = mapParser
+
+-- Remember to write liftA2 by hand at some point.
+instance Applicative Parser where
+ pure = pureParser
+ (<*>) = Control.Monad.ap
+
+instance Monad Parser where
+ return = pure
+ (>>=) = bindLifted
+
+newtype Parser a = Parser
+ { getParser :: forall s.
+ Maybe# (Leftovers# s)
+ -> State# s
+ -> (# State# s, Result# s a #)
+ }
+
+nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #)
+nextNonEmpty (ByteStream f) s0 = case f s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> (# s1, (# (# #) | #) #)
+ (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of
+ 0# -> nextNonEmpty stream s1
+ _ -> (# s1, (# | (# theBytes, stream #) #) #)
+
+withNonEmpty :: forall s b.
+ Maybe# (Leftovers# s)
+ -> State# s
+ -> (State# s -> (# State# s, Result# s b #))
+ -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #))
+ -- The first argument is a Word8, not a full machine word.
+ -- The second argument is the complete,non-empty chunk
+ -- with the head byte still intact.
+ -> (# State# s, Result# s b #)
+withNonEmpty (# (# #) | #) s0 g _ = g s0
+withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of
+ 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0
+ _ -> case nextNonEmpty stream0 s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> g s1
+ (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) ->
+ f (indexWord8Array# arr1 off1) bytes1 stream1 s1
+
+-- | Consume the next byte from the input.
+any :: Parser Word8
+any = Parser go where
+ go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #)
+ go m s0 = withNonEmpty m s0
+ (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #))
+ (\theByte theBytes stream s ->
+ (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #)
+ )
+
+-- TODO: improve this
+mapParser :: (a -> b) -> Parser a -> Parser b
+mapParser f p = bindLifted p (pureParser . f)
+
+pureParser :: a -> Parser a
+pureParser a = Parser $ \leftovers0 s0 ->
+ (# s0, (# leftovers0, (# | a #) #) #)
+
+bindLifted :: Parser a -> (a -> Parser b) -> Parser b
+bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of
+ (# s1, (# leftovers1, val #) #) -> case val of
+ (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #)
+ (# | x #) -> case g x of
+ Parser k -> k leftovers1 s1
+
+-- This assumes that the Bytes is longer than the index. It also does
+-- not eliminate zero-length references to byte arrays.
+unsafeDrop# :: Int# -> Bytes# -> Bytes#
+unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #)
+
+unboxByteArray :: ByteArray -> ByteArray#
+unboxByteArray (ByteArray arr) = arr
+
+boxBytes :: Bytes# -> Bytes
+boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)
+
+failure :: Parser a
+failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #))
+
diff --git a/tests/examples/ghc86/RAE_T32a.hs b/tests/examples/ghc86/RAE_T32a.hs
new file mode 100644
index 0000000..88b7011
--- /dev/null
+++ b/tests/examples/ghc86/RAE_T32a.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds,
+ PolyKinds, TypeFamilies, GADTs, TypeInType #-}
+
+module RAE_T32a where
+
+import Data.Kind
+
+data family Sing (k :: Type) :: k -> Type
+
+data TyArr' (a :: Type) (b :: Type) :: Type
+type TyArr (a :: Type) (b :: Type) = TyArr' a b -> Type
+type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2
+data TyPi' (a :: Type) (b :: TyArr a Type) :: Type
+type TyPi (a :: Type) (b :: TyArr a Type) = TyPi' a b -> Type
+type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b
+$(return [])
+
+data MkStar (p :: Type) (x :: TyArr' p Type)
+type instance MkStar p @@ x = Type
+$(return [])
+
+data Sigma (p :: Type) (r :: TyPi p (MkStar p)) :: Type where
+ Sigma ::
+ forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a).
+ Sing Type p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r
+$(return [])
+
+data instance Sing Sigma (Sigma p r) x where
+ SSigma ::
+ forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a)
+ (sp :: Sing Type p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b).
+ Sing (Sing (r @@@ a) b) sb ->
+ Sing (Sigma p r) ('Sigma sp sr sa sb)
+
+-- I (RAE) believe this last definition is ill-typed.
diff --git a/tests/examples/ghc86/RAE_T32b.hs b/tests/examples/ghc86/RAE_T32b.hs
new file mode 100644
index 0000000..bcb7b64
--- /dev/null
+++ b/tests/examples/ghc86/RAE_T32b.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds,
+ RankNTypes, TypeOperators, TypeInType #-}
+
+module RAE_T32b where
+
+import Data.Kind
+
+data family Sing (k :: Type) :: k -> Type
+
+data TyArr (a :: Type) (b :: Type) :: Type
+type family (a :: TyArr k1 k2 -> Type) @@ (b :: k1) :: k2
+$(return [])
+
+data Sigma (p :: Type) (r :: TyArr p Type -> Type) :: Type where
+ Sigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a).
+ Sing Type p -> Sing (TyArr p Type -> Type) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r
+$(return [])
+
+data instance Sing (Sigma p r) (x :: Sigma p r) :: Type where
+ SSigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a)
+ (sp :: Sing Type p) (sr :: Sing (TyArr p Type -> Type) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b).
+ Sing (Sing (r @@ a) b) sb ->
+ Sing (Sigma p r) ('Sigma sp sr sa sb)
diff --git a/tests/examples/ghc86/Rae31.hs b/tests/examples/ghc86/Rae31.hs
new file mode 100644
index 0000000..81914ea
--- /dev/null
+++ b/tests/examples/ghc86/Rae31.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds,
+ TypeFamilies, TypeInType #-}
+
+module A where
+
+import Data.Kind
+
+data family Sing (k :: Type) :: k -> Type
+type Sing' (x :: k) = Sing k x
+data TyFun' (a :: Type) (b :: Type) :: Type
+type TyFun (a :: Type) (b :: Type) = TyFun' a b -> Type
+type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2
+data TyPi' (a :: Type) (b :: TyFun a Type) :: Type
+type TyPi (a :: Type) (b :: TyFun a Type) = TyPi' a b -> Type
+type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b
+$(return [])
+
+data A (a :: Type) (b :: a) (c :: TyFun' a Type) -- A :: forall a -> a -> a ~> Type
+type instance (@@) (A a b) c = Type
+$(return [])
+data B (a :: Type) (b :: TyFun' a Type) -- B :: forall a -> a ~> Type
+type instance (@@) (B a) b = TyPi a (A a b)
+$(return [])
+data C (a :: Type) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) Type)
diff --git a/tests/examples/ghc86/RaeBlogPost.hs b/tests/examples/ghc86/RaeBlogPost.hs
new file mode 100644
index 0000000..fdbc0d8
--- /dev/null
+++ b/tests/examples/ghc86/RaeBlogPost.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies,
+ TypeInType #-}
+{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-}
+
+module RaeBlogPost where
+
+import Data.Kind
+
+-- a Proxy type with an explicit kind
+data Proxy k (a :: k) = P
+prox :: Proxy * Bool
+prox = P
+
+prox2 :: Proxy Bool 'True
+prox2 = P
+
+-- implicit kinds still work
+data A
+data B :: A -> Type
+data C :: B a -> Type
+data D :: C b -> Type
+data E :: D c -> Type
+-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> Type
+
+-- a kind-indexed GADT
+data TypeRep (a :: k) where
+ TInt :: TypeRep Int
+ TMaybe :: TypeRep Maybe
+ TApp :: TypeRep a -> TypeRep b -> TypeRep (a b)
+
+zero :: TypeRep a -> a
+zero TInt = 0
+zero (TApp TMaybe _) = Nothing
+
+data Nat = Zero | Succ Nat
+type family a + b where
+ 'Zero + b = b
+ ('Succ a) + b = 'Succ (a + b)
+
+data Vec :: Type -> Nat -> Type where
+ Nil :: Vec a 'Zero
+ (:>) :: a -> Vec a n -> Vec a ('Succ n)
+infixr 5 :>
+
+-- promoted GADT, and using + as a "kind family":
+type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where
+ 'Nil ++ y = y
+ (h ':> t) ++ y = h ':> (t ++ y)
+
+-- datatype that mentions Type
+data U = Star (Type)
+ | Bool Bool
+
+-- kind synonym
+type Monadish = Type -> Type
+class MonadTrans (t :: Monadish -> Monadish) where
+ lift :: Monad m => m a -> t m a
+data Free :: Monadish where
+ Return :: a -> Free a
+ Bind :: Free a -> (a -> Free b) -> Free b
+
+-- yes, Type really does have type Type.
+type Star = (Type :: (Type :: (Type :: Type)))
diff --git a/tests/examples/ghc86/RenamingStar.hs b/tests/examples/ghc86/RenamingStar.hs
new file mode 100644
index 0000000..0fdea9c
--- /dev/null
+++ b/tests/examples/ghc86/RenamingStar.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeInType #-}
+
+module RenamingStar where
+
+data Foo :: Type
diff --git a/tests/examples/ghc86/ST.hs b/tests/examples/ghc86/ST.hs
new file mode 100644
index 0000000..4368bc3
--- /dev/null
+++ b/tests/examples/ghc86/ST.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+
+{-# OPTIONS_GHC -O2 #-}
+
+module Packed.Bytes.Stream.ST
+ ( ByteStream(..)
+ , empty
+ , unpack
+ , fromBytes
+ ) where
+
+import Data.Primitive (Array,ByteArray(..))
+import Data.Semigroup (Semigroup)
+import Data.Word (Word8)
+import GHC.Exts (RealWorld,State#,Int#,ByteArray#)
+import GHC.Int (Int(I#))
+import GHC.ST (ST(..))
+import Packed.Bytes (Bytes(..))
+import System.IO (Handle)
+import qualified Data.Primitive as PM
+import qualified Data.Semigroup as SG
+import qualified Packed.Bytes as B
+
+type Bytes# = (# ByteArray#, Int#, Int# #)
+
+newtype ByteStream s = ByteStream
+ (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) )
+
+fromBytes :: Bytes -> ByteStream s
+fromBytes b = ByteStream
+ (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #))
+
+nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s))
+nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> (# s1, Nothing #)
+ (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #)
+
+empty :: ByteStream s
+empty = ByteStream (\s -> (# s, (# (# #) | #) #) )
+
+boxBytes :: Bytes# -> Bytes
+boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)
+
+unboxBytes :: Bytes -> Bytes#
+unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #)
+
+unpack :: ByteStream s -> ST s [Word8]
+unpack stream = ST (unpackInternal stream)
+
+unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #)
+unpackInternal (ByteStream f) s0 = case f s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> (# s1, [] #)
+ (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of
+ (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #)
+
diff --git a/tests/examples/ghc86/SlidingTypeSyn.hs b/tests/examples/ghc86/SlidingTypeSyn.hs
new file mode 100644
index 0000000..d28f855
--- /dev/null
+++ b/tests/examples/ghc86/SlidingTypeSyn.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LiberalTypeSynonyms #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+
+
+type ( f :-> g) (r :: Type -> Type) ix = f r ix -> g r ix
+
+type ( f :--> g) b ix = f b ix -> g b ix
+
+type ((f :---> g)) b ix = f b ix -> g b ix
diff --git a/tests/examples/ghc86/T10134a.hs b/tests/examples/ghc86/T10134a.hs
new file mode 100644
index 0000000..779514f
--- /dev/null
+++ b/tests/examples/ghc86/T10134a.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+module T10134a where
+
+import GHC.TypeLits
+
+data Vec :: Nat -> Type -> Type where
+ Nil :: Vec 0 a
+ (:>) :: a -> Vec n a -> Vec (n + 1) a
diff --git a/tests/examples/ghc86/T10279.hs b/tests/examples/ghc86/T10279.hs
new file mode 100644
index 0000000..c2d00ea
--- /dev/null
+++ b/tests/examples/ghc86/T10279.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T10279 where
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+-- NB: rts-1.0 is used here because it doesn't change.
+-- You do need to pick the right version number, otherwise the
+-- error message doesn't recognize it as a source package ID,
+-- (This is OK, since it will look obviously wrong when they
+-- try to find the package in their package database.)
+blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A"))))
+
diff --git a/tests/examples/ghc86/T10321.hs b/tests/examples/ghc86/T10321.hs
new file mode 100644
index 0000000..2973e72
--- /dev/null
+++ b/tests/examples/ghc86/T10321.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T10321 where
+
+import GHC.TypeLits
+
+data Vec :: Nat -> Type -> Type where
+ Nil :: Vec 0 a
+ (:>) :: a -> Vec n a -> Vec (n + 1) a
+
+infixr 5 :>
diff --git a/tests/examples/ghc86/T10638.hs b/tests/examples/ghc86/T10638.hs
new file mode 100644
index 0000000..62af44e
--- /dev/null
+++ b/tests/examples/ghc86/T10638.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import GHC.Exts
+
+{-
+ the prim and javascript calling conventions do not support
+ headers and the static keyword.
+-}
+
+-- check that quasiquoting roundtrips successfully and that the declaration
+-- does not include the static keyword
+test1 :: String
+test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <-
+ [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |]
+ addTopDecls ds
+ case p of
+ "test1" -> return (LitE . stringL $ p)
+ _ -> error $ "unexpected value: " ++ show p
+ )
+
+-- check that constructed prim imports with the static keyword are rejected
+test2 :: String
+test2 = $(do t <- [t| Int# -> Int# |]
+ cmm_test2 <- newName "cmm_test2"
+ addTopDecls
+ [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)]
+ [| test1 |]
+ )
+
diff --git a/tests/examples/ghc86/T10689a.hs b/tests/examples/ghc86/T10689a.hs
new file mode 100644
index 0000000..bae0194
--- /dev/null
+++ b/tests/examples/ghc86/T10689a.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE TypeOperators
+ , DataKinds
+ , PolyKinds
+ , TypeFamilies
+ , GADTs
+ , UndecidableInstances
+ , RankNTypes
+ , ScopedTypeVariables
+ #-}
+
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Werror #-}
+{-# OPTIONS_GHC -O1 -fspec-constr #-}
+
+{-
+ghc-stage2: panic! (the 'impossible' happened)
+ (GHC version 7.11.20150723 for x86_64-unknown-linux):
+ Template variable unbound in rewrite rule
+-}
+
+module List (sFoldr1) where
+
+data Proxy t
+
+data family Sing (a :: k)
+
+data TyFun (a :: Type) (b :: Type)
+
+type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2
+
+data instance Sing (f :: TyFun k1 k2 -> Type) =
+ SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) }
+
+type SingFunction1 f = forall t. Sing t -> Sing (Apply f t)
+
+type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t)
+singFun2 :: Proxy f -> SingFunction2 f -> Sing f
+singFun2 _ f = SLambda (\x -> SLambda (f x))
+
+data (:$$) (j :: a) (i :: TyFun [a] [a])
+type instance Apply ((:$$) j) i = (:) j i
+
+data (:$) (l :: TyFun a (TyFun [a] [a] -> Type))
+type instance Apply (:$) l = (:$$) l
+data instance Sing (z :: [a])
+ = z ~ '[] =>
+ SNil
+ | forall (m :: a)
+ (n :: [a]). z ~ (:) m n =>
+ SCons (Sing m) (Sing n)
+
+data ErrorSym0 (t1 :: TyFun k1 k2)
+
+type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh
+
+type Let1627448493Xs f_afe9
+ x_afea
+ wild_1627448474_afeb
+ wild_1627448476_afec =
+ Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec
+type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)
+ -> Type)
+ (t_afdZ :: [a_afdP]) =
+ Foldr1 t_afdY t_afdZ
+data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)
+ -> Type)
+ (l_afe2 :: TyFun [a_afdP] a_afdP)
+type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2
+
+data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP
+ -> Type)
+ -> Type) (TyFun [a_afdP] a_afdP -> Type))
+type instance Apply Foldr1Sym0 l = Foldr1Sym1 l
+
+type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP
+ -> Type)
+ -> Type)
+ (a_afe6 :: [a_afdP]) :: a_afdP where
+ Foldr1 z_afe7 '[x_afe8] = x_afe8
+ Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec))
+ Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list"
+
+sFoldr1 ::
+ forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type)
+ (y :: [a_afdP]).
+ Sing x
+ -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y)
+sFoldr1 _ (SCons _sX SNil) = undefined
+sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476))
+ = let
+ lambda_afeC ::
+ forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec.
+ Sing f_afe9
+ -> Sing x_afea
+ -> Sing wild_1627448474_afeb
+ -> Sing wild_1627448476_afec
+ -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec)))
+ lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG
+ = let
+ sXs ::
+ Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)
+ sXs
+ = applySing
+ (applySing
+ (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF)
+ wild_1627448476_afeG
+ in
+ applySing
+ (applySing f_afeD x_afeE)
+ (applySing
+ (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD)
+ sXs)
+ in lambda_afeC sF sX sWild_1627448474 sWild_1627448476
+sFoldr1 _ SNil = undefined
+
diff --git a/tests/examples/ghc86/T10819.hs b/tests/examples/ghc86/T10819.hs
new file mode 100644
index 0000000..d3d271b
--- /dev/null
+++ b/tests/examples/ghc86/T10819.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10819 where
+
+import T10819_Lib
+
+import Language.Haskell.TH.Syntax
+
+class C a b | b -> a where
+ f :: b -> a
+
+data D = X
+
+instance C Int D where
+ f X = 2
+
+$(doSomeTH "N" (mkName "D")
+ [DerivClause Nothing [ConT (mkName "C") `AppT` ConT (mkName "Int")]])
+
+thing :: N
+thing = N X
+
+thing1 :: Int
+thing1 = f thing
+
diff --git a/tests/examples/ghc86/T10891.hs b/tests/examples/ghc86/T10891.hs
new file mode 100644
index 0000000..aff4e88
--- /dev/null
+++ b/tests/examples/ghc86/T10891.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10891 where
+
+import Language.Haskell.TH
+import System.IO
+
+class C a where
+ f :: a -> Int
+
+class C' a where
+ type F a :: *
+ type F a = a
+ f' :: a -> Int
+
+class C'' a where
+ data Fd a :: *
+
+instance C' Int where
+ type F Int = Bool
+ f' = id
+
+instance C'' Int where
+ data Fd Int = B Bool | C Char
+
+$(return [])
+
+test :: ()
+test =
+ $(let
+ display :: Name -> Q ()
+ display q = do
+ i <- reify q
+ runIO (hPutStrLn stderr (pprint i) >> hFlush stderr)
+ in do
+ display ''C
+ display ''C'
+ display ''C''
+ [| () |])
+
diff --git a/tests/examples/ghc86/T10934.hs b/tests/examples/ghc86/T10934.hs
new file mode 100644
index 0000000..be64915
--- /dev/null
+++ b/tests/examples/ghc86/T10934.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE
+ ScopedTypeVariables
+ , DataKinds
+ , GADTs
+ , RankNTypes
+ , TypeOperators
+ , PolyKinds -- Comment out PolyKinds and the bug goes away.
+ #-}
+{-# OPTIONS_GHC -O #-}
+ -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it
+
+module KeyValue where
+
+data AccValidation err a = AccFailure err | AccSuccess a
+
+data KeyValueError = MissingValue
+
+type WithKeyValueError = AccValidation [KeyValueError]
+
+missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs
+missing = rpure missingField
+ where
+ missingField :: forall x. (WithKeyValueError :. f) x
+ missingField = Compose $ AccFailure [MissingValue]
+
+data Rec :: (u -> Type) -> [u] -> Type where
+ RNil :: Rec f '[]
+ (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)
+
+newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k)
+ = Compose { getCompose :: f (g x) }
+
+type (:.) f g = Compose f g
+
+class RecApplicative rs where
+ rpure
+ :: (forall x. f x)
+ -> Rec f rs
diff --git a/tests/examples/ghc86/T11142.hs b/tests/examples/ghc86/T11142.hs
new file mode 100644
index 0000000..c73918f
--- /dev/null
+++ b/tests/examples/ghc86/T11142.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeInType, RankNTypes #-}
+
+module T11142 where
+
+import Data.Kind
+
+data SameKind :: k -> k -> Type
+
+foo :: forall b. (forall k (a :: k). SameKind a b) -> ()
+foo = undefined
diff --git a/tests/examples/ghc86/T11484.hs b/tests/examples/ghc86/T11484.hs
new file mode 100644
index 0000000..29ad9d7
--- /dev/null
+++ b/tests/examples/ghc86/T11484.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T11484 where
+
+import Data.Kind
+
+type TySyn (k :: *) (a :: k) = ()
+
+$([d| type TySyn2 (k :: *) (a :: k) = () |])
+
diff --git a/tests/examples/ghc86/T12478_5.hs b/tests/examples/ghc86/T12478_5.hs
new file mode 100644
index 0000000..5919aab
--- /dev/null
+++ b/tests/examples/ghc86/T12478_5.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module T12478_5 where
+
+import Language.Haskell.TH
+
+foo :: $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''())
+ -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''())
+foo $(conP (unboxedSumDataName 1 2) [conP '() []])
+ = $(conE (unboxedSumDataName 2 2) `appE` conE '())
+foo $(conP (unboxedSumDataName 2 2) [conP '() []])
+ = $(conE (unboxedSumDataName 2 2) `appE` conE '())
+
+foo2 :: (# () | () #)
+ -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''())
+foo2 (# () | #) = $(conE (unboxedSumDataName 2 2) `appE` conE '())
+foo2 $(conP (unboxedSumDataName 2 2) [conP '() []]) = (# | () #)
+
diff --git a/tests/examples/ghc86/T14164.hs b/tests/examples/ghc86/T14164.hs
new file mode 100644
index 0000000..ccfabc0
--- /dev/null
+++ b/tests/examples/ghc86/T14164.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeOperators #-}
+module T14164 where
+
+data G (x :: a) = GNil | GCons (G x)
+
+type family F (xs :: [a]) (g :: G (z :: a)) = (res :: [a]) | res -> a where
+ F (x:xs) GNil = x:xs
+ F (x:xs) (GCons rest) = x:F xs rest
+
diff --git a/tests/examples/ghc86/T14650.hs b/tests/examples/ghc86/T14650.hs
new file mode 100644
index 0000000..ef989cd
--- /dev/null
+++ b/tests/examples/ghc86/T14650.hs
@@ -0,0 +1,77 @@
+module MergeSort (
+ msortBy
+ ) where
+
+infixl 7 :%
+infixr 6 :&
+
+data LenList a = LL {-# UNPACK #-} !Int Bool [a]
+
+data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b
+
+data Stack a
+ = End
+ | {-# UNPACK #-} !(LenList a) :& (Stack a)
+
+msortBy :: (a -> a -> Ordering) -> [a] -> [a]
+msortBy cmp = mergeSplit End where
+ splitAsc n _ _ _ | n `seq` False = undefined
+ splitAsc n as _ [] = LL n True as :% []
+ splitAsc n as a bs@(b:bs') = case cmp a b of
+ GT -> LL n False as :% bs
+ _ -> splitAsc (n + 1) as b bs'
+
+ splitDesc n _ _ _ | n `seq` False = undefined
+ splitDesc n rs a [] = LL n True (a:rs) :% []
+ splitDesc n rs a bs@(b:bs') = case cmp a b of
+ GT -> splitDesc (n + 1) (a:rs) b bs'
+ _ -> LL n True (a:rs) :% bs
+
+ mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where
+ mergeLs nx _ ny _ | nx `seq` ny `seq` False = undefined
+ mergeLs 0 _ ny ys = if fb then ys else take ny ys
+ mergeLs _ [] ny ys = if fb then ys else take ny ys
+ mergeLs nx xs 0 _ = if fa then xs else take nx xs
+ mergeLs nx xs _ [] = if fa then xs else take nx xs
+ mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of
+ GT -> y:mergeLs nx xs (ny - 1) ys'
+ _ -> x:mergeLs (nx - 1) xs' ny ys
+
+ push ssx px@(LL nx _ _) = case ssx of
+ End -> px :% ssx
+ py@(LL ny _ _) :& ssy -> case ssy of
+ End
+ | nx >= ny -> mergeLL py px :% ssy
+ pz@(LL nz _ _) :& ssz
+ | nx >= ny || nx + ny >= nz -> case nx > nz of
+ False -> push ssy $ mergeLL py px
+ _ -> case push ssz $ mergeLL pz py of
+ pz' :% ssz' -> push (pz' :& ssz') px
+ _ -> px :% ssx
+
+ mergeAll _ px | px `seq` False = undefined
+ mergeAll ssx px@(LL nx _ xs) = case ssx of
+ End -> xs
+ py@(LL _ _ _) :& ssy -> case ssy of
+ End -> case mergeLL py px of
+ LL _ _ xys -> xys
+ pz@(LL nz _ _) :& ssz -> case nx > nz of
+ False -> mergeAll ssy $ mergeLL py px
+ _ -> case push ssz $ mergeLL pz py of
+ pz' :% ssz' -> mergeAll (pz' :& ssz') px
+
+ mergeSplit ss _ | ss `seq` False = undefined
+ mergeSplit ss [] = case ss of
+ End -> []
+ px :& ss' -> mergeAll ss' px
+ mergeSplit ss as@(a:as') = case as' of
+ [] -> mergeAll ss $ LL 1 True as
+ b:bs -> case cmp a b of
+ GT -> case splitDesc 2 [a] b bs of
+ px :% rs -> case push ss px of
+ px' :% ss' -> mergeSplit (px' :& ss') rs
+ _ -> case splitAsc 2 as b bs of
+ px :% rs -> case push ss px of
+ px' :% ss' -> mergeSplit (px' :& ss') rs
+ {-# INLINABLE mergeSplit #-}
+
diff --git a/tests/examples/ghc86/T2632.hs b/tests/examples/ghc86/T2632.hs
new file mode 100644
index 0000000..e160873
--- /dev/null
+++ b/tests/examples/ghc86/T2632.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- Trac #2632
+
+module MkData where
+
+import Language.Haskell.TH
+
+op :: Num v => v -> v -> v
+op a b = a + b
+
+decl1 = [d| func = 0 `op` 3 |]
+
+decl2 = [d| op x y = x
+ func = 0 `op` 3 |]
+
diff --git a/tests/examples/ghc86/T3263-2.hs b/tests/examples/ghc86/T3263-2.hs
new file mode 100644
index 0000000..a1f07bb
--- /dev/null
+++ b/tests/examples/ghc86/T3263-2.hs
@@ -0,0 +1,39 @@
+-- Trac #3263. New kind of warning on monadic bindings that discard a monadic result
+{-# LANGUAGE RankNTypes #-}
+
+module T3263 where
+
+import Control.Monad.Fix
+
+-- No warning
+t1 :: Monad m => m Int
+t1 = do
+ return 10
+
+-- No warning
+t2 :: Monad m => m (m Int)
+t2 = return (return 10)
+
+-- No warning
+t3 :: Monad m => m (m Int)
+t3 = do
+ return 10
+ return (return 10)
+
+-- Warning
+t4 :: forall m. Monad m => m Int
+t4 = do
+ return (return 10 :: m Int)
+ return 10
+
+-- No warning
+t5 :: forall m. Monad m => m Int
+t5 = do
+ _ <- return (return 10 :: m Int)
+ return 10
+
+-- Warning
+t6 :: forall m. MonadFix m => m Int
+t6 = mdo
+ return (return 10 :: m Int)
+ return 10
diff --git a/tests/examples/ghc86/T3391.hs b/tests/examples/ghc86/T3391.hs
new file mode 100644
index 0000000..1370ece
--- /dev/null
+++ b/tests/examples/ghc86/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 Trac #3391
+
+module T3391 where
+
+data T = MkT
+
+$(return [])
+
+$(return [])
+
diff --git a/tests/examples/ghc86/T3572.hs b/tests/examples/ghc86/T3572.hs
new file mode 100644
index 0000000..57ea829
--- /dev/null
+++ b/tests/examples/ghc86/T3572.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- Trac #3572
+
+module Main where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Ppr
+
+main = putStrLn . pprint =<< runQ [d| data Void |]
+
diff --git a/tests/examples/ghc86/T3927b.hs b/tests/examples/ghc86/T3927b.hs
new file mode 100644
index 0000000..49af0f7
--- /dev/null
+++ b/tests/examples/ghc86/T3927b.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T3927b where
+
+import Data.Proxy
+import GHC.Exts
+
+data Message
+
+data SocketType = Dealer | Push | Pull
+
+data SocketOperation = Read | Write
+
+type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where
+ Restrict a (a ': as) = ()
+ Restrict x (a ': as) = Restrict x as
+ Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!")
+
+type family Implements (t :: SocketType) :: [SocketOperation] where
+ Implements Dealer = ['Read, Write]
+ Implements Push = '[Write]
+ Implements Pull = '[ 'Read]
+
+data SockOp :: SocketType -> SocketOperation -> Type where
+ SRead :: SockOp sock 'Read
+ SWrite :: SockOp sock Write
+
+data Socket :: SocketType -> Type where
+ Socket :: proxy sock
+ -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op)
+ -> Socket sock
+
+type family Operation (op :: SocketOperation) :: Type where
+ Operation 'Read = IO Message
+ Operation Write = Message -> IO ()
+
+class Restrict 'Read (Implements t) => Readable t where
+ readSocket :: Socket t -> Operation 'Read
+ readSocket (Socket _ f) = f (SRead :: SockOp t 'Read)
+
+instance Readable Dealer
+
+type family Writable (t :: SocketType) :: Constraint where
+ Writable Dealer = ()
+ Writable Push = ()
+
+dealer :: Socket Dealer
+dealer = Socket (Proxy :: Proxy Dealer) f
+ where
+ f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op
+ f SRead = undefined
+ f SWrite = undefined
+
+push :: Socket Push
+push = Socket (Proxy :: Proxy Push) f
+ where
+ f :: Restrict op (Implements Push) => SockOp Push op -> Operation op
+ f SWrite = undefined
+
+pull :: Socket Pull
+pull = Socket (Proxy :: Proxy Pull) f
+ where
+ f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op
+ f SRead = undefined
+
+foo :: IO Message
+foo = readSocket dealer
diff --git a/tests/examples/ghc86/T4056.hs b/tests/examples/ghc86/T4056.hs
new file mode 100644
index 0000000..9938aa2
--- /dev/null
+++ b/tests/examples/ghc86/T4056.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T4056 where
+import Language.Haskell.TH
+
+astTest :: Q [Dec]
+astTest = [d|
+ class C t where
+ op :: [t] -> [t]
+ op = undefined
+ |]
+
+class D t where
+ bop :: [t] -> [t]
+ bop = undefined
+
diff --git a/tests/examples/ghc86/T4169.hs b/tests/examples/ghc86/T4169.hs
new file mode 100644
index 0000000..bb23f1c
--- /dev/null
+++ b/tests/examples/ghc86/T4169.hs
@@ -0,0 +1,15 @@
+-- Crashed GHC 6.12
+{-# LANGUAGE TemplateHaskell #-}
+
+module T4165 where
+
+import Language.Haskell.TH
+class Numeric a where
+ fromIntegerNum :: a
+ fromIntegerNum = undefined
+
+ast :: Q [Dec]
+ast = [d|
+ instance Numeric Int
+ |]
+
diff --git a/tests/examples/ghc86/T4170.hs b/tests/examples/ghc86/T4170.hs
new file mode 100644
index 0000000..5494db7
--- /dev/null
+++ b/tests/examples/ghc86/T4170.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T4170 where
+
+import Language.Haskell.TH
+
+class LOL a
+
+lol :: Q [Dec]
+lol = [d|
+ instance LOL Int
+ |]
+
+instance LOL Int
+
diff --git a/tests/examples/ghc86/T5217.hs b/tests/examples/ghc86/T5217.hs
new file mode 100644
index 0000000..ac06be4
--- /dev/null
+++ b/tests/examples/ghc86/T5217.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T5217 where
+import Language.Haskell.TH
+
+$([d| data T a b where { T1 :: Int -> T Int Char
+ ; T2 :: a -> T a a
+ ; T3 :: a -> T [a] a
+ ; T4 :: a -> b -> T b [a] } |])
+
diff --git a/tests/examples/ghc86/T6018th.hs b/tests/examples/ghc86/T6018th.hs
new file mode 100644
index 0000000..91c61a1
--- /dev/null
+++ b/tests/examples/ghc86/T6018th.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeFamilyDependencies, DataKinds, UndecidableInstances,
+ PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T6018th where
+
+import Language.Haskell.TH
+
+-- Test that injectivity works correct with TH. This test is not as exhaustive
+-- as the original T6018 test.
+
+-- type family F a b c = (result :: k) | result -> a b c
+-- type instance F Int Char Bool = Bool
+-- type instance F Char Bool Int = Int
+-- type instance F Bool Int Char = Char
+$( return
+ [ OpenTypeFamilyD (TypeFamilyHead
+ (mkName "F")
+ [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ]
+ (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k"))))
+ (Just $ InjectivityAnn (mkName "result")
+ [(mkName "a"), (mkName "b"), (mkName "c") ]))
+ , TySynInstD
+ (mkName "F")
+ (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ , ConT (mkName "Bool")]
+ ( ConT (mkName "Bool")))
+ , TySynInstD
+ (mkName "F")
+ (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool")
+ , ConT (mkName "Int")]
+ ( ConT (mkName "Int")))
+ , TySynInstD
+ (mkName "F")
+ (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+ , ConT (mkName "Char")]
+ ( ConT (mkName "Char")))
+ ] )
+
+-- this is injective - a type variables mentioned on LHS is not mentioned on RHS
+-- but we don't claim injectivity in that argument.
+--
+-- type family J a (b :: k) = r | r -> a
+---type instance J Int b = Char
+$( return
+ [ OpenTypeFamilyD (TypeFamilyHead
+ (mkName "J")
+ [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ]
+ (TyVarSig (PlainTV (mkName "r")))
+ (Just $ InjectivityAnn (mkName "r") [mkName "a"]))
+ , TySynInstD
+ (mkName "J")
+ (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ]
+ ( ConT (mkName "Int")))
+ ] )
+
+-- Closed type families
+
+-- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where
+-- IClosed Int Char Bool = Bool
+-- IClosed Int Char Int = Bool
+-- IClosed Bool Int Int = Int
+
+$( return
+ [ ClosedTypeFamilyD (TypeFamilyHead
+ (mkName "I")
+ [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT
+ , KindedTV (mkName "c") StarT ]
+ (TyVarSig (PlainTV (mkName "r")))
+ (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]))
+ [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ , ConT (mkName "Bool")]
+ ( ConT (mkName "Bool"))
+ , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ , ConT (mkName "Int")]
+ ( ConT (mkName "Bool"))
+ , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+ , ConT (mkName "Int")]
+ ( ConT (mkName "Int"))
+ ]
+ ] )
+
+-- reification test
+$( do { decl@([ClosedTypeFamilyD (TypeFamilyHead _ _ _ (Just inj)) _]) <-
+ [d| type family Bak a = r | r -> a where
+ Bak Int = Char
+ Bak Char = Int
+ Bak a = a |]
+ ; return decl
+ }
+ )
+
+-- Check whether incorrect injectivity declarations are caught
+
+-- type family I a b c = r | r -> a b
+-- type instance I Int Char Bool = Bool
+-- type instance I Int Int Int = Bool
+-- type instance I Bool Int Int = Int
+$( return
+ [ OpenTypeFamilyD (TypeFamilyHead
+ (mkName "H")
+ [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ]
+ (TyVarSig (PlainTV (mkName "r")))
+ (Just $ InjectivityAnn (mkName "r")
+ [(mkName "a"), (mkName "b") ]))
+ , TySynInstD
+ (mkName "H")
+ (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+ , ConT (mkName "Bool")]
+ ( ConT (mkName "Bool")))
+ , TySynInstD
+ (mkName "H")
+ (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int")
+ , ConT (mkName "Int")]
+ ( ConT (mkName "Bool")))
+ , TySynInstD
+ (mkName "H")
+ (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+ , ConT (mkName "Int")]
+ ( ConT (mkName "Int")))
+ ] )
+
diff --git a/tests/examples/ghc86/T6062.hs b/tests/examples/ghc86/T6062.hs
new file mode 100644
index 0000000..ebc4d3a
--- /dev/null
+++ b/tests/examples/ghc86/T6062.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T6062 where
+x = [| False True |]
+
diff --git a/tests/examples/ghc86/T8455.hs b/tests/examples/ghc86/T8455.hs
new file mode 100644
index 0000000..7961c27
--- /dev/null
+++ b/tests/examples/ghc86/T8455.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T8455 where
+
+ty = [t| 5 |]
+
diff --git a/tests/examples/ghc86/T8759a.hs b/tests/examples/ghc86/T8759a.hs
new file mode 100644
index 0000000..e122c5f
--- /dev/null
+++ b/tests/examples/ghc86/T8759a.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T8759a where
+
+foo = [d| pattern Q = False |]
+
diff --git a/tests/examples/ghc86/T8807.hs b/tests/examples/ghc86/T8807.hs
new file mode 100644
index 0000000..b59e344
--- /dev/null
+++ b/tests/examples/ghc86/T8807.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE ConstraintKinds, RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T8807 where
+
+import Data.Proxy
+
+foo :: $( [t| forall a b. a b => Proxy a -> b -> b |] )
+foo = undefined
+
diff --git a/tests/examples/ghc86/T9367.hs b/tests/examples/ghc86/T9367.hs
new file mode 100644
index 0000000..999b7d5
--- /dev/null
+++ b/tests/examples/ghc86/T9367.hs
@@ -0,0 +1,5 @@
+x = "abc"
+main = print x
+-- This file has Windows line endings (CRLF) on purpose. Do not remove.
+-- See #9367.
+
diff --git a/tests/examples/ghc86/T9632.hs b/tests/examples/ghc86/T9632.hs
new file mode 100644
index 0000000..932f9c3
--- /dev/null
+++ b/tests/examples/ghc86/T9632.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeInType #-}
+
+module T9632 where
+
+import Data.Kind
+
+data B = T | F
+data P :: B -> Type
+
+type B' = B
+data P' :: B' -> Type
diff --git a/tests/examples/ghc86/T9662.hs b/tests/examples/ghc86/T9662.hs
new file mode 100644
index 0000000..0b9ba6c
--- /dev/null
+++ b/tests/examples/ghc86/T9662.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module T9662 where
+
+data Exp a = Exp
+data (a:.b) = a:.b
+
+type family Plain e :: Type
+type instance Plain (Exp a) = a
+type instance Plain (a:.b) = Plain a :. Plain b
+
+class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where
+ type Unlifted pattern
+ type Tuple pattern
+
+modify :: (Unlift pattern) =>
+ pattern ->
+ (Unlifted pattern -> a) ->
+ Exp (Tuple pattern) -> Exp (Plain a)
+modify p f = undefined
+
+
+data Atom a = Atom
+
+atom :: Atom a
+atom = Atom
+
+
+instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where
+ type Unlifted (pa :. int) = Unlifted pa :. Exp Int
+ type Tuple (pa :. int) = Tuple pa :. Int
+
+
+data Shape sh = Shape
+
+backpermute ::
+ (Exp sh -> Exp sh') ->
+ (Exp sh' -> Exp sh) ->
+ Shape sh -> Shape sh'
+backpermute = undefined
+
+test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k)
+test =
+ backpermute
+ (modify (atom:.atom:.atom:.atom)
+ (\(sh:.k:.m:.n) -> (sh:.m:.n:.k)))
+ id
+
+-- With this arg instead of just 'id', it worked
+-- (modify (atom:.atom:.atom:.atom)
+-- (\(ix:.m:.n:.k) -> (ix:.k:.m:.n)))
+
diff --git a/tests/examples/ghc86/T9824.hs b/tests/examples/ghc86/T9824.hs
new file mode 100644
index 0000000..de60798
--- /dev/null
+++ b/tests/examples/ghc86/T9824.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fwarn-unused-matches #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T9824 where
+
+foo = [p| (x, y) |]
+
diff --git a/tests/examples/ghc86/TH_abstractFamily.hs b/tests/examples/ghc86/TH_abstractFamily.hs
new file mode 100644
index 0000000..921dfaa
--- /dev/null
+++ b/tests/examples/ghc86/TH_abstractFamily.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_abstractFamily where
+
+import Language.Haskell.TH
+
+-- Empty closed type families are okay...
+ds1 :: Q [Dec]
+ds1 = [d| type family F a where |]
+
+-- ...but abstract ones should result in a type error
+ds2 :: Q [Dec]
+ds2 = [d| type family G a where .. |]
+
diff --git a/tests/examples/ghc86/TH_bracket1.hs b/tests/examples/ghc86/TH_bracket1.hs
new file mode 100644
index 0000000..edec759
--- /dev/null
+++ b/tests/examples/ghc86/TH_bracket1.hs
@@ -0,0 +1,9 @@
+-- Check that declarations in a bracket shadow the top-level
+{-# LANGUAGE TemplateHaskell #-}
+-- declarations, rather than clashing with them.
+
+module TH_bracket1 where
+
+foo = 1
+bar = [d| foo = 1 |]
+
diff --git a/tests/examples/ghc86/TH_bracket2.hs b/tests/examples/ghc86/TH_bracket2.hs
new file mode 100644
index 0000000..11165de
--- /dev/null
+++ b/tests/examples/ghc86/TH_bracket2.hs
@@ -0,0 +1,10 @@
+
+{-# LANGUAGE TemplateHaskell #-}
+module TH_bracket2 where
+
+d_show = [d| data A = A
+
+ instance Show A where
+ show _ = "A"
+ |]
+
diff --git a/tests/examples/ghc86/TH_bracket3.hs b/tests/examples/ghc86/TH_bracket3.hs
new file mode 100644
index 0000000..dbc7251
--- /dev/null
+++ b/tests/examples/ghc86/TH_bracket3.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_bracket3 where
+
+d_class = [d| class Classy a b where
+ f :: a -> b
+
+ instance Classy Int Bool where
+ f x = if x == 0 then True else False
+ |]
+
diff --git a/tests/examples/ghc86/TH_class1.hs b/tests/examples/ghc86/TH_class1.hs
new file mode 100644
index 0000000..27b9db8
--- /dev/null
+++ b/tests/examples/ghc86/TH_class1.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_class1 where
+
+$( [d| class Classy a b c d | a -> b c, c -> d where
+ f :: a -> b -> c -> d
+ |] )
+
diff --git a/tests/examples/ghc86/TH_dataD1.hs b/tests/examples/ghc86/TH_dataD1.hs
new file mode 100644
index 0000000..9883e3b
--- /dev/null
+++ b/tests/examples/ghc86/TH_dataD1.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_dataD1 where
+
+import Language.Haskell.TH
+
+ds :: Q [Dec]
+ds = [d|
+ $(do { d <- dataD (cxt []) (mkName "D") [] Nothing
+ [normalC (mkName "K") []] []
+ ; return [d]})
+ |]
+
diff --git a/tests/examples/ghc86/TH_localname.hs b/tests/examples/ghc86/TH_localname.hs
new file mode 100644
index 0000000..c99af3e
--- /dev/null
+++ b/tests/examples/ghc86/TH_localname.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_localname where
+
+x = \y -> [| y |]
+
diff --git a/tests/examples/ghc86/TH_lookupName.hs b/tests/examples/ghc86/TH_lookupName.hs
new file mode 100644
index 0000000..4465cf8
--- /dev/null
+++ b/tests/examples/ghc86/TH_lookupName.hs
@@ -0,0 +1,37 @@
+-- test 'lookupTypeName' and 'lookupValueName'
+{-# LANGUAGE TemplateHaskell #-}
+
+import Language.Haskell.TH
+
+import qualified TH_lookupName_Lib
+import qualified TH_lookupName_Lib as TheLib
+
+f :: String
+f = "TH_lookupName.f"
+
+data D = D
+
+$(return [])
+
+main = mapM_ print [
+ -- looking up values
+ $(do { Just n <- lookupValueName "f" ; varE n }),
+ $(do { Nothing <- lookupTypeName "f"; [| "" |] }),
+ -- looking up types
+ $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }),
+ $(do { Nothing <- lookupValueName "String"; [| "" |] }),
+ -- namespacing
+ $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }),
+ $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }),
+ -- qualified lookup
+ $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }),
+ $(do { Just n <- lookupValueName "TheLib.f"; varE n }),
+ -- shadowing
+ $(TheLib.lookup_f),
+ $( [| let f = "local f" in $(TheLib.lookup_f) |] ),
+ $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ),
+ $( [| let f = "local f" in $(varE 'f) |] ),
+ let f = "local f" in $(TheLib.lookup_f),
+ let f = "local f" in $(varE 'f)
+ ]
+
diff --git a/tests/examples/ghc86/TH_ppr1.hs b/tests/examples/ghc86/TH_ppr1.hs
new file mode 100644
index 0000000..668ae3c
--- /dev/null
+++ b/tests/examples/ghc86/TH_ppr1.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main (main) where
+
+import Language.Haskell.TH
+
+u1 :: a
+u1 = undefined
+
+u2 :: a
+u2 = undefined
+
+f :: a
+f = undefined
+
+(.+.) :: a
+(.+.) = undefined
+
+main :: IO ()
+main = do runQ [| f u1 u2 |] >>= p
+ runQ [| u1 `f` u2 |] >>= p
+ runQ [| (.+.) u1 u2 |] >>= p
+ runQ [| u1 .+. u2 |] >>= p
+ runQ [| (:) u1 u2 |] >>= p
+ runQ [| u1 : u2 |] >>= p
+ runQ [| \((:) x xs) -> x |] >>= p
+ runQ [| \(x : xs) -> x |] >>= p
+ runQ [d| class Foo a b where
+ foo :: a -> b |] >>= p
+ runQ [| \x -> (x, 1 `x` 2) |] >>= p
+ runQ [| \(+) -> ((+), 1 + 2) |] >>= p
+ runQ [| (f, 1 `f` 2) |] >>= p
+ runQ [| ((.+.), 1 .+. 2) |] >>= p
+
+p :: Ppr a => a -> IO ()
+p = putStrLn . pprint
+
diff --git a/tests/examples/ghc86/TH_raiseErr1.hs b/tests/examples/ghc86/TH_raiseErr1.hs
new file mode 100644
index 0000000..892fd11
--- /dev/null
+++ b/tests/examples/ghc86/TH_raiseErr1.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_raiseErr1 where
+import Language.Haskell.TH
+
+foo = $(do { report True "Error test succeeded"; fail "" })
+
diff --git a/tests/examples/ghc86/TH_recover.hs b/tests/examples/ghc86/TH_recover.hs
new file mode 100644
index 0000000..ac9c7cf
--- /dev/null
+++ b/tests/examples/ghc86/TH_recover.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+-- The recover successfully find that 'ola' is not in scope
+-- and use '1' instead
+
+y = $(recover (return (LitE (IntegerL 1)))
+ (reify (mkName ("ola")) >> return (LitE (IntegerL 2))))
+
+main = print y
+
diff --git a/tests/examples/ghc86/TH_reifyDecl1.hs b/tests/examples/ghc86/TH_reifyDecl1.hs
new file mode 100644
index 0000000..17294db
--- /dev/null
+++ b/tests/examples/ghc86/TH_reifyDecl1.hs
@@ -0,0 +1,88 @@
+-- test reification of data declarations
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# LANGUAGE TypeFamilies #-}
+module TH_reifyDecl1 where
+
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+infixl 3 `m1`
+
+-- simple
+data T = A | B
+
+-- parametric
+data R a = C a | D
+
+-- recursive
+data List a = Nil | Cons a (List a)
+
+-- infix operator
+data Tree a = Leaf | Tree a :+: Tree a
+
+-- type declaration
+type IntList = [Int]
+
+-- newtype declaration
+newtype Length = Length Int
+
+-- simple class
+class C1 a where
+ m1 :: a -> Int
+
+-- class with instances
+class C2 a where
+ m2 :: a -> Int
+instance C2 Int where
+ m2 x = x
+
+-- associated types
+class C3 a where
+ type AT1 a
+ data AT2 a
+
+instance C3 Int where
+ type AT1 Int = Bool
+ data AT2 Int = AT2Int
+
+-- type family
+type family TF1 a
+
+-- type family, with instances
+type family TF2 a
+type instance TF2 Bool = Bool
+
+-- data family
+data family DF1 a
+
+-- data family, with instances
+data family DF2 a
+data instance DF2 Bool = DBool
+
+$(return [])
+
+test :: ()
+test = $(let
+ display :: Name -> Q ()
+ display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
+ in do { display ''T
+ ; display ''R
+ ; display ''List
+ ; display ''Tree
+ ; display ''IntList
+ ; display ''Length
+ ; display 'Leaf
+ ; display 'm1
+ ; display ''C1
+ ; display ''C2
+ ; display ''C3
+ ; display ''AT1
+ ; display ''AT2
+ ; display ''TF1
+ ; display ''TF2
+ ; display ''DF1
+ ; display ''DF2
+ ; [| () |] })
+
diff --git a/tests/examples/ghc86/TH_reifyDecl2.hs b/tests/examples/ghc86/TH_reifyDecl2.hs
new file mode 100644
index 0000000..09de9bd
--- /dev/null
+++ b/tests/examples/ghc86/TH_reifyDecl2.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_reifyDecl2 where
+
+import Language.Haskell.TH
+import System.IO
+
+$(
+ do x <- reify ''Maybe
+ runIO $ hPutStrLn stderr $ pprint x
+ return []
+ )
+
diff --git a/tests/examples/ghc86/TH_reifyInstances.hs b/tests/examples/ghc86/TH_reifyInstances.hs
new file mode 100644
index 0000000..8d23c27
--- /dev/null
+++ b/tests/examples/ghc86/TH_reifyInstances.hs
@@ -0,0 +1,51 @@
+-- test reifyInstances
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# LANGUAGE TypeFamilies #-}
+module TH_reifyInstances where
+
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+-- classes
+class C1 a where f1 :: a
+
+class C2 a where f2 :: a
+instance C2 Int where f2 = 0
+instance C2 Bool where f2 = True
+
+-- type families
+type family T1 a
+
+type family T2 a
+type instance T2 Int = Char
+type instance T2 Bool = Int
+
+-- data families
+data family D1 a
+
+data family D2 a
+data instance D2 Int = DInt | DInt2
+data instance D2 Bool = DBool
+
+$(return [])
+
+test :: ()
+test = $(let
+ display :: Name -> Q ()
+ display n = do
+ { intTy <- [t| Int |]
+ ; is1 <- reifyInstances n [intTy]
+ ; runIO $ hPutStrLn stderr (nameBase n)
+ ; runIO $ hPutStrLn stderr (pprint is1)
+ }
+ in do { display ''C1
+ ; display ''C2
+ ; display ''T1
+ ; display ''T2
+ ; display ''D1
+ ; display ''D2
+ ; [| () |]
+ })
+
diff --git a/tests/examples/ghc86/TH_reifyMkName.hs b/tests/examples/ghc86/TH_reifyMkName.hs
new file mode 100644
index 0000000..a783535
--- /dev/null
+++ b/tests/examples/ghc86/TH_reifyMkName.hs
@@ -0,0 +1,16 @@
+-- Trac #2339
+{-# LANGUAGE TemplateHaskell #-}
+
+module Foo where
+
+import System.IO
+import Language.Haskell.TH
+
+type C = Int
+
+$(do
+ a <- reify $ mkName "C"
+ runIO $ hPutStrLn stderr (show a)
+ return []
+ )
+
diff --git a/tests/examples/ghc86/TH_repE1.hs b/tests/examples/ghc86/TH_repE1.hs
new file mode 100644
index 0000000..d764871
--- /dev/null
+++ b/tests/examples/ghc86/TH_repE1.hs
@@ -0,0 +1,32 @@
+-- test the representation of literals and also explicit type annotations
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_repE1
+where
+
+import Language.Haskell.TH
+
+integralExpr :: ExpQ
+integralExpr = [| 42 |]
+
+intExpr :: ExpQ
+intExpr = [| 42 :: Int |]
+
+integerExpr :: ExpQ
+integerExpr = [| 42 :: Integer |]
+
+charExpr :: ExpQ
+charExpr = [| 'x' |]
+
+stringExpr :: ExpQ
+stringExpr = [| "A String" |]
+
+fractionalExpr :: ExpQ
+fractionalExpr = [| 1.2 |]
+
+floatExpr :: ExpQ
+floatExpr = [| 1.2 :: Float |]
+
+doubleExpr :: ExpQ
+doubleExpr = [| 1.2 :: Double |]
+
diff --git a/tests/examples/ghc86/TH_repE2.hs b/tests/examples/ghc86/TH_repE2.hs
new file mode 100644
index 0000000..fb6997a
--- /dev/null
+++ b/tests/examples/ghc86/TH_repE2.hs
@@ -0,0 +1,37 @@
+-- test the representation of literals and also explicit type annotations
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main
+where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = mapM_ putStrLn [show an_integral, show an_int, show an_integer,
+ show an_char, show an_string, show an_fractional,
+ show an_float, show an_double]
+
+an_integral :: Integer
+an_integral = $( [| 42 |] )
+
+an_int :: Int
+an_int = $( [| 42 :: Int |] )
+
+an_integer :: Integer
+an_integer = $( [| 98765432123456789876 :: Integer |] )
+
+an_char :: Char
+an_char = $( [| 'x' |] )
+
+an_string :: String
+an_string = $( [| "A String" |] )
+
+an_fractional :: Double
+an_fractional = $( [| 1.2 |] )
+
+an_float :: Float
+an_float = $( [| 1.2 :: Float |] )
+
+an_double :: Double
+an_double = $( [| 1.2 :: Double |] )
+
diff --git a/tests/examples/ghc86/TH_repE3.hs b/tests/examples/ghc86/TH_repE3.hs
new file mode 100644
index 0000000..488fbe0
--- /dev/null
+++ b/tests/examples/ghc86/TH_repE3.hs
@@ -0,0 +1,20 @@
+-- test the representation of literals and also explicit type annotations
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_repE1
+where
+
+import Language.Haskell.TH
+
+emptyListExpr :: ExpQ
+emptyListExpr = [| [] |]
+
+singletonListExpr :: ExpQ
+singletonListExpr = [| [4] |]
+
+listExpr :: ExpQ
+listExpr = [| [4,5,6] |]
+
+consExpr :: ExpQ
+consExpr = [| 4:5:6:[] |]
+
diff --git a/tests/examples/ghc86/TH_repGuard.hs b/tests/examples/ghc86/TH_repGuard.hs
new file mode 100644
index 0000000..15d5c85
--- /dev/null
+++ b/tests/examples/ghc86/TH_repGuard.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main
+where
+
+import Language.Haskell.TH
+import System.IO
+
+$(
+ do ds <- [d|
+ foo :: Int -> Int
+ foo x
+ | x == 5 = 6
+ foo x = 7
+ |]
+ runIO $ do { putStrLn (pprint ds); hFlush stdout }
+ return ds
+ )
+
+$(
+ do ds <- [d|
+ bar :: Maybe Int -> Int
+ bar x
+ | Just y <- x = y
+ bar _ = 9
+ |]
+ runIO $ do { putStrLn (pprint ds) ; hFlush stdout }
+ return ds
+ )
+
+main :: IO ()
+main = do putStrLn $ show $ foo 5
+ putStrLn $ show $ foo 8
+ putStrLn $ show $ bar (Just 2)
+ putStrLn $ show $ bar Nothing
+
diff --git a/tests/examples/ghc86/TH_repGuardOutput.hs b/tests/examples/ghc86/TH_repGuardOutput.hs
new file mode 100644
index 0000000..0f02324
--- /dev/null
+++ b/tests/examples/ghc86/TH_repGuardOutput.hs
@@ -0,0 +1,30 @@
+-- test the representation of unboxed literals
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main
+where
+
+$(
+ [d|
+ foo :: Int -> Int
+ foo x
+ | x == 5 = 6
+ foo x = 7
+ |]
+ )
+
+$(
+ [d|
+ bar :: Maybe Int -> Int
+ bar x
+ | Just y <- x = y
+ bar _ = 9
+ |]
+ )
+
+main :: IO ()
+main = do putStrLn $ show $ foo 5
+ putStrLn $ show $ foo 8
+ putStrLn $ show $ bar (Just 2)
+ putStrLn $ show $ bar Nothing
+
diff --git a/tests/examples/ghc86/TH_repPatSig.hs b/tests/examples/ghc86/TH_repPatSig.hs
new file mode 100644
index 0000000..7a8e450
--- /dev/null
+++ b/tests/examples/ghc86/TH_repPatSig.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main
+where
+
+import TH_repPatSig_asserts
+
+assertFoo [d| foo :: Int -> Int
+ foo (x :: Int) = x
+ |]
+
+assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |]
+
+assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |]
+
+main :: IO ()
+main = return ()
+
diff --git a/tests/examples/ghc86/TH_repPatSigTVar.hs b/tests/examples/ghc86/TH_repPatSigTVar.hs
new file mode 100644
index 0000000..5c9f6bd
--- /dev/null
+++ b/tests/examples/ghc86/TH_repPatSigTVar.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main
+where
+
+import Language.Haskell.TH
+
+$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |])
+
+main :: IO ()
+main = return ()
+
diff --git a/tests/examples/ghc86/TH_repPrim.hs b/tests/examples/ghc86/TH_repPrim.hs
new file mode 100644
index 0000000..3ef37fc
--- /dev/null
+++ b/tests/examples/ghc86/TH_repPrim.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MagicHash #-}
+-- test the representation of unboxed literals
+
+module Main where
+
+import GHC.Exts
+import GHC.Float
+import Language.Haskell.TH
+import Text.PrettyPrint
+import System.IO
+
+main :: IO ()
+main = do putStrLn $ show $ $( do e <- [| I# 20# |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ return e )
+ putStrLn $ show $ $( do e <- [| W# 32## |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ return e )
+ putStrLn $ show $ $( do e <- [| F# 12.3# |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ return e )
+ putStrLn $ show $ $( do e <- [| D# 24.6## |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ return e )
+
diff --git a/tests/examples/ghc86/TH_repPrim2.hs b/tests/examples/ghc86/TH_repPrim2.hs
new file mode 100644
index 0000000..8ab2c84
--- /dev/null
+++ b/tests/examples/ghc86/TH_repPrim2.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- test the representation of unboxed literals
+
+module Main where
+
+import GHC.Exts
+import GHC.Float
+import Language.Haskell.TH
+import Text.PrettyPrint
+import System.IO
+
+main :: IO ()
+main = do putStrLn $ show $ $( do e <- [| 20# |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ [| I# $( return e) |] )
+ putStrLn $ show $ $( do e <- [| 32## |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ [| W# $(return e) |] )
+ putStrLn $ show $ $( do e <- [| 12.3# |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ [| F# $(return e) |] )
+ putStrLn $ show $ $( do e <- [| 24.6## |]
+ runIO $ putStrLn $ show e
+ runIO $ putStrLn $ pprint e
+ runIO $ hFlush stdout
+ [| D# $(return e) |] )
+
diff --git a/tests/examples/ghc86/TH_repPrimOutput.hs b/tests/examples/ghc86/TH_repPrimOutput.hs
new file mode 100644
index 0000000..047c11c
--- /dev/null
+++ b/tests/examples/ghc86/TH_repPrimOutput.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- test the representation of unboxed literals
+
+module Main
+where
+
+import GHC.Exts
+import GHC.Float
+import Language.Haskell.TH
+import Text.PrettyPrint
+import System.IO
+
+main :: IO ()
+main = do putStrLn $ show $ $( do e <- [| I# 20# |]
+ return e )
+ putStrLn $ show $ $( do e <- [| W# 32## |]
+ return e )
+ putStrLn $ show $ $( do e <- [| F# 12.3# |]
+ return e )
+ putStrLn $ show $ $( do e <- [| D# 24.6## |]
+ return e )
+
diff --git a/tests/examples/ghc86/TH_repPrimOutput2.hs b/tests/examples/ghc86/TH_repPrimOutput2.hs
new file mode 100644
index 0000000..174f096
--- /dev/null
+++ b/tests/examples/ghc86/TH_repPrimOutput2.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- test the representation of unboxed literals
+
+module Main
+where
+
+import GHC.Exts
+import GHC.Float
+import Language.Haskell.TH
+import Text.PrettyPrint
+import System.IO
+
+main :: IO ()
+main = do putStrLn $ show $ $( do e <- [| 20# |]
+ [| I# $(return e) |] )
+ putStrLn $ show $ $( do e <- [| 32## |]
+ [| W# $(return e) |] )
+ putStrLn $ show $ $( do e <- [| 12.3# |]
+ [| F# $(return e) |] )
+ putStrLn $ show $ $( do e <- [| 24.6## |]
+ [| D# $(return e) |] )
+
diff --git a/tests/examples/ghc86/TH_scope.hs b/tests/examples/ghc86/TH_scope.hs
new file mode 100644
index 0000000..d18523a
--- /dev/null
+++ b/tests/examples/ghc86/TH_scope.hs
@@ -0,0 +1,10 @@
+-- Test for Trac #2188
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_scope where
+
+f g = [d| f :: Int
+ f = g
+ g :: Int
+ g = 4 |]
+
diff --git a/tests/examples/ghc86/TH_sections.hs b/tests/examples/ghc86/TH_sections.hs
new file mode 100644
index 0000000..a5e97da
--- /dev/null
+++ b/tests/examples/ghc86/TH_sections.hs
@@ -0,0 +1,11 @@
+-- Test for trac #2956
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_sections where
+
+two :: Int
+two = $( [| (1 +) 1 |] )
+
+three :: Int
+three = $( [| (+ 2) 1 |] )
+
diff --git a/tests/examples/ghc86/TH_spliceD2.hs b/tests/examples/ghc86/TH_spliceD2.hs
new file mode 100644
index 0000000..ed8165e
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceD2.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_spliceD2 where
+
+import qualified TH_spliceD2_Lib
+
+$( [d| data T = T TH_spliceD2_Lib.T |] )
+
diff --git a/tests/examples/ghc86/TH_spliceDecl1.hs b/tests/examples/ghc86/TH_spliceDecl1.hs
new file mode 100644
index 0000000..020ba13
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceDecl1.hs
@@ -0,0 +1,12 @@
+-- test splicing of a generated data declarations
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_spliceDecl1
+where
+
+import Language.Haskell.TH
+
+
+-- splice a simple data declaration
+$(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []])
+
diff --git a/tests/examples/ghc86/TH_spliceDecl2.hs b/tests/examples/ghc86/TH_spliceDecl2.hs
new file mode 100644
index 0000000..c5c986d
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceDecl2.hs
@@ -0,0 +1,13 @@
+-- test splicing of quoted data and newtype declarations
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_spliceDecl2
+where
+
+import Language.Haskell.TH
+
+-- splice a simple quoted declaration (x 2)
+$([d| data T1 = C1 |])
+
+$([d| newtype T2 = C2 String |])
+
diff --git a/tests/examples/ghc86/TH_spliceDecl3.hs b/tests/examples/ghc86/TH_spliceDecl3.hs
new file mode 100644
index 0000000..208fef4
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceDecl3.hs
@@ -0,0 +1,13 @@
+-- test splicing of reified and renamed data declarations
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_spliceDecl3
+where
+
+import Language.Haskell.TH
+import TH_spliceDecl3_Lib
+
+data T = C
+
+$(do { TyConI d <- reify ''T; rename' d})
+
diff --git a/tests/examples/ghc86/TH_spliceE1.hs b/tests/examples/ghc86/TH_spliceE1.hs
new file mode 100644
index 0000000..c80e782
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceE1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+my_id :: a -> a
+my_id x = $( [| x |] )
+
+main = print (my_id "hello")
+
diff --git a/tests/examples/ghc86/TH_spliceE3.hs b/tests/examples/ghc86/TH_spliceE3.hs
new file mode 100644
index 0000000..3ec7ef6
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceE3.hs
@@ -0,0 +1,26 @@
+-- test the representation of literals and also explicit type annotations
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_repE1
+where
+
+import Language.Haskell.TH
+
+$( do let emptyListExpr :: ExpQ
+ emptyListExpr = [| [] |]
+
+ singletonListExpr :: ExpQ
+ singletonListExpr = [| [4] |]
+
+ listExpr :: ExpQ
+ listExpr = [| [4,5,6] |]
+
+ consExpr :: ExpQ
+ consExpr = [| 4:5:6:[] |]
+
+ [d| foo = ($emptyListExpr, $singletonListExpr, $listExpr, $consExpr) |]
+ )
+
+bar = $( [| case undefined of
+ [1] -> 1 |] )
+
diff --git a/tests/examples/ghc86/TH_spliceE4.hs b/tests/examples/ghc86/TH_spliceE4.hs
new file mode 100644
index 0000000..8844c72
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceE4.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+$( do let h x = x
+ foo = [| \x -> $(h [| x |]) |]
+
+ [d| baz = $foo |]
+ )
+
+main = print (baz "Hello")
+
diff --git a/tests/examples/ghc86/TH_spliceE5_Lib.hs b/tests/examples/ghc86/TH_spliceE5_Lib.hs
new file mode 100644
index 0000000..e88d6f5
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceE5_Lib.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_spliceE5_Lib where
+
+import Language.Haskell.TH
+
+expandVars :: [String] -> Q Exp
+expandVars s = [| concat $(return (ListE (map f s))) |]
+ where
+ f x = VarE (mkName x)
+
diff --git a/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs b/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs
new file mode 100644
index 0000000..07196f1
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_spliceE5_prof_Lib where
+
+import Language.Haskell.TH
+
+expandVars :: [String] -> Q Exp
+expandVars s = [| concat $(return (ListE (map f s))) |]
+ where
+ f x = VarE (mkName x)
+
diff --git a/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs
new file mode 100644
index 0000000..5382590
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_spliceE5_prof_ext_Lib where
+
+import Language.Haskell.TH
+
+expandVars :: [String] -> Q Exp
+expandVars s = [| concat $(return (ListE (map f s))) |]
+ where
+ f x = VarE (mkName x)
+
diff --git a/tests/examples/ghc86/TH_spliceExpr1.hs b/tests/examples/ghc86/TH_spliceExpr1.hs
new file mode 100644
index 0000000..ca78740
--- /dev/null
+++ b/tests/examples/ghc86/TH_spliceExpr1.hs
@@ -0,0 +1,11 @@
+-- test representation and splicing of left-parenthesised right infix operators
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_spliceExpr1
+where
+
+import Language.Haskell.TH
+
+foo :: Int
+foo = $( [| ((+) $ 2) $ 2 |] )
+
diff --git a/tests/examples/ghc86/TH_tf1.hs b/tests/examples/ghc86/TH_tf1.hs
new file mode 100644
index 0000000..2a57097
--- /dev/null
+++ b/tests/examples/ghc86/TH_tf1.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_tf1 where
+
+$( [d| data family T a |] )
+$( [d| data instance T Int = TInt Bool |] )
+
+foo :: Bool -> T Int
+foo b = TInt (b && b)
+
+$( [d| type family S a |] )
+$( [d| type instance S Int = Bool |] )
+
+bar :: S Int -> Int
+bar c = if c then 1 else 2
+
+$( [d| type family R (a :: * -> *) :: * -> * |] )
+$( [d| type instance R Maybe = [] |] )
+
+baz :: R Maybe Int -> Int
+baz = head
+
diff --git a/tests/examples/ghc86/TH_tf3.hs b/tests/examples/ghc86/TH_tf3.hs
new file mode 100644
index 0000000..aaa59f5
--- /dev/null
+++ b/tests/examples/ghc86/TH_tf3.hs
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}
+
+module TH_tf3 where
+
+type family T a
+
+$( [d| foo :: T [a] ~ Bool => a -> a
+ foo x = x |] )
+
+$( [d| class C a
+ instance a ~ Int => C a |] )
diff --git a/tests/examples/ghc86/TH_unresolvedInfix.hs b/tests/examples/ghc86/TH_unresolvedInfix.hs
new file mode 100644
index 0000000..c277444
--- /dev/null
+++ b/tests/examples/ghc86/TH_unresolvedInfix.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+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,
+
+-------------- Dropping constructors
+ $( n *? tupE [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,
+-------------- Dropping constructors
+ case (N :* (N :+ N)) of
+ [p16|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/ghc86/TH_unresolvedInfix2.hs b/tests/examples/ghc86/TH_unresolvedInfix2.hs
new file mode 100644
index 0000000..be58549
--- /dev/null
+++ b/tests/examples/ghc86/TH_unresolvedInfix2.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_unresolvedInfix2 where
+
+import Language.Haskell.TH
+
+infixl 6 :+
+
+data Tree = N
+ | Tree :+ Tree
+ | Tree :* Tree
+
+$(return [])
+
+-- Should fail
+expr = $( let plus = conE '(:+)
+ n = conE 'N
+ in infixE Nothing plus (Just $ uInfixE n plus n) )
+
diff --git a/tests/examples/ghc82/TensorTests.hs b/tests/examples/ghc86/TensorTests.hs
index d212198..6a6acbc 100644
--- a/tests/examples/ghc82/TensorTests.hs
+++ b/tests/examples/ghc86/TensorTests.hs
@@ -36,6 +36,6 @@ tremParams = Proxy
type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos)
-data Liftable :: TyFun (Factored, *) Bool -> *
+data Liftable :: TyFun (Factored, Type) Bool -> Type
type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq)
diff --git a/tests/examples/ghc86/Test.hs b/tests/examples/ghc86/Test.hs
new file mode 100644
index 0000000..16bcf34
--- /dev/null
+++ b/tests/examples/ghc86/Test.hs
@@ -0,0 +1,410 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE RankNTypes #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Test
+-- Copyright : (c) Simon Marlow 2002
+-- License : BSD-style
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- This module illustrates & tests most of the features of Haddock.
+-- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'.
+--
+-----------------------------------------------------------------------------
+
+-- This is plain comment, ignored by Haddock.
+
+module Test (
+
+ -- Section headings are introduced with '-- *':
+ -- * Type declarations
+
+ -- Subsection headings are introduced with '-- **' and so on.
+ -- ** Data types
+ T(..), T2, T3(..), T4(..), T5(..), T6(..),
+ N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..),
+
+ -- ** Records
+ R(..), R1(..),
+
+ -- | test that we can export record selectors on their own:
+ p, q, u,
+
+ -- * Class declarations
+ C(a,b), D(..), E, F(..),
+
+ -- | Test that we can export a class method on its own:
+ a,
+
+ -- * Function types
+ f, g,
+
+ -- * Auxiliary stuff
+
+ -- $aux1
+
+ -- $aux2
+
+ -- $aux3
+
+ -- $aux4
+
+ -- $aux5
+
+ -- $aux6
+
+ -- $aux7
+
+ -- $aux8
+
+ -- $aux9
+
+ -- $aux10
+
+ -- $aux11
+
+ -- $aux12
+
+ -- | This is some inline documentation in the export list
+ --
+ -- > a code block using bird-tracks
+ -- > each line must begin with > (which isn't significant unless it
+ -- > is at the beginning of the line).
+
+ -- * A hidden module
+ module Hidden,
+
+ -- * A visible module
+ module Visible,
+
+ {-| nested-style doc comments -}
+
+ -- * Existential \/ Universal types
+ Ex(..),
+
+ -- * Type signatures with argument docs
+ k, l, m, o,
+
+ -- * A section
+ -- and without an intervening comma:
+ -- ** A subsection
+
+{-|
+ > a literal line
+
+ $ a non /literal/ line $
+-}
+
+ f',
+ ) where
+
+import Hidden
+import Visible
+
+-- | This comment applies to the /following/ declaration
+-- and it continues until the next non-comment line
+data T a b
+ = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor
+ | -- | This comment describes the 'B' constructor
+ B (T a b, T Int Float) -- ^
+
+-- | An abstract data declaration
+data T2 a b = T2 a b
+
+-- | A data declaration with no documentation annotations on the constructors
+data T3 a b = A1 a | B1 b
+
+-- A data declaration with no documentation annotations at all
+data T4 a b = A2 a | B2 b
+
+-- A data declaration documentation on the constructors only
+data T5 a b
+ = A3 a -- ^ documents 'A3'
+ | B3 b -- ^ documents 'B3'
+
+-- | Testing alternative comment styles
+data T6
+ -- | This is the doc for 'A4'
+ = A4
+ | B4
+ | -- ^ This is the doc for 'B4'
+
+ -- | This is the doc for 'C4'
+ C4
+
+-- | A newtype
+newtype N1 a = N1 a
+
+-- | A newtype with a fieldname
+newtype N2 a b = N2 {n :: a b}
+
+-- | A newtype with a fieldname, documentation on the field
+newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field
+ }
+
+-- | An abstract newtype - we show this one as data rather than newtype because
+-- the difference isn\'t visible to the programmer for an abstract type.
+newtype N4 a b = N4 a
+
+newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor
+ }
+
+newtype N6 a b = N6 {n6 :: a b
+ }
+ -- ^ docs on the constructor only
+
+-- | docs on the newtype and the constructor
+newtype N7 a b = N7 {n7 :: a b
+ }
+ -- ^ The 'N7' constructor
+
+
+class (D a) => C a where
+ -- |this is a description of the 'a' method
+ a :: IO a
+ b :: [a]
+ -- ^ this is a description of the 'b' method
+ c :: a -- c is hidden in the export list
+
+-- ^ This comment applies to the /previous/ declaration (the 'C' class)
+
+class D a where
+ d :: T a b
+ e :: (a,a)
+-- ^ This is a class declaration with no separate docs for the methods
+
+instance D Int where
+ d = undefined
+ e = undefined
+
+-- instance with a qualified class name
+instance Test.D Float where
+ d = undefined
+ e = undefined
+
+class E a where
+ ee :: a
+-- ^ This is a class declaration with no methods (or no methods exported)
+
+-- This is a class declaration with no documentation at all
+class F a where
+ ff :: a
+
+-- | This is the documentation for the 'R' record, which has four fields,
+-- 'p', 'q', 'r', and 's'.
+data R =
+ -- | This is the 'C1' record constructor, with the following fields:
+ C1 { p :: Int -- ^ This comment applies to the 'p' field
+ , q :: forall a . a->a -- ^ This comment applies to the 'q' field
+ , -- | This comment applies to both 'r' and 's'
+ r,s :: Int
+ }
+ | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),
+ u,v :: Int
+ }
+ -- ^ This is the 'C2' record constructor, also with some fields:
+
+-- | Testing different record commenting styles
+data R1
+ -- | This is the 'C3' record constructor
+ = C3 {
+ -- | The 's1' record selector
+ s1 :: Int
+ -- | The 's2' record selector
+ , s2 :: Int
+ , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here.
+ -- Since GHC doesn't allow that, I have removed it in this file.
+ -- ^ The 's3' record selector
+ }
+
+-- These section headers are only used when there is no export list to
+-- give the structure of the documentation:
+
+-- * This is a section header (level 1)
+-- ** This is a section header (level 2)
+-- *** This is a section header (level 3)
+
+{-|
+In a comment string we can refer to identifiers in scope with
+single quotes like this: 'T', and we can refer to modules by
+using double quotes: "Foo". We can add emphasis /like this/.
+
+ * This is a bulleted list
+
+ - This is the next item (different kind of bullet)
+
+ (1) This is an ordered list
+
+ 2. This is the next item (different kind of bullet)
+
+@
+ This is a block of code, which can include other markup: 'R'
+ formatting
+ is
+ significant
+@
+
+> this is another block of code
+
+We can also include URLs in documentation: <http://www.haskell.org/>.
+-}
+
+f :: C a => a -> Int
+
+-- | we can export foreign declarations too
+foreign import ccall "header.h" g :: Int -> IO CInt
+
+-- | this doc string has a parse error in it: \'
+h :: Int
+h = 42
+
+
+-- $aux1 This is some documentation that is attached to a name ($aux1)
+-- rather than a source declaration. The documentation may be
+-- referred to in the export list using its name.
+--
+-- @ code block in named doc @
+
+-- $aux2 This is some documentation that is attached to a name ($aux2)
+
+-- $aux3
+-- @ code block on its own in named doc @
+
+-- $aux4
+--
+-- @ code block on its own in named doc (after newline) @
+
+{- $aux5 a nested, named doc comment
+
+ with a paragraph,
+
+ @ and a code block @
+-}
+
+-- some tests for various arrangements of code blocks:
+
+{- $aux6
+>test
+>test1
+
+@ test2
+ test3
+@
+-}
+
+{- $aux7
+@
+test1
+test2
+@
+-}
+
+{- $aux8
+>test3
+>test4
+-}
+
+{- $aux9
+@
+test1
+test2
+@
+
+>test3
+>test4
+-}
+
+{- $aux10
+>test3
+>test4
+
+@
+test1
+test2
+@
+-}
+
+-- This one is currently wrong (Haddock 0.4). The @...@ part is
+-- interpreted as part of the bird-tracked code block.
+{- $aux11
+aux11:
+
+>test3
+>test4
+
+@
+test1
+test2
+@
+-}
+
+-- $aux12
+-- > foo
+--
+-- > bar
+--
+
+-- | A data-type using existential\/universal types
+data Ex a
+ = forall b . C b => Ex1 b
+ | forall b . Ex2 b
+ | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file
+ | Ex4 (forall a . a -> a)
+
+-- | This is a function with documentation for each argument
+k :: T () () -- ^ This argument has type 'T'
+ -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int'
+ -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@
+ -> T5 () () -- ^ This argument has a very long description that should
+ -- hopefully cause some wrapping to happen when it is finally
+ -- rendered by Haddock in the generated HTML page.
+ -> IO () -- ^ This is the result type
+
+-- This function has arg docs but no docs for the function itself
+l :: (Int, Int, Float) -- ^ takes a triple
+ -> Int -- ^ returns an 'Int'
+
+-- | This function has some arg docs
+m :: R
+ -> N1 () -- ^ one of the arguments
+ -> IO Int -- ^ and the return value
+
+-- | This function has some arg docs but not a return value doc
+
+-- can't use the original name ('n') with GHC
+newn :: R -- ^ one of the arguments, an 'R'
+ -> N1 () -- ^ one of the arguments
+ -> IO Int
+newn = undefined
+
+
+-- | A foreign import with argument docs
+foreign import ccall unsafe "header.h"
+ o :: Float -- ^ The input float
+ -> IO Float -- ^ The output float
+
+-- | We should be able to escape this: \#\#\#
+
+-- p :: Int
+-- can't use the above original definition with GHC
+newp :: Int
+newp = undefined
+
+-- | a function with a prime can be referred to as 'f''
+-- but f' doesn't get link'd 'f\''
+f' :: Int
+
+
+-- Add some definitions here so that this file can be compiled with GHC
+
+data T1
+f = undefined
+f' = undefined
+type CInt = Int
+k = undefined
+l = undefined
+m = undefined
+
diff --git a/tests/examples/ghc86/Test12417.hs b/tests/examples/ghc86/Test12417.hs
new file mode 100644
index 0000000..93c74da
--- /dev/null
+++ b/tests/examples/ghc86/Test12417.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Test12417 where
+
+import GHC.Prim
+import GHC.Types
+
+import System.Mem (performMajorGC)
+
+type Either1 a b = (# a | b #)
+
+showEither1 :: (Show a, Show b) => Either1 a b -> String
+showEither1 (# left | #) = "Left " ++ show left
+showEither1 (# | right #) = "Right " ++ show right
+
+type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #)
+
+showEither4 :: T -> String
+showEither4 (# | b | | | | | #) = "Alt1: " ++ show b
+
diff --git a/tests/examples/ghc86/TupleN.hs b/tests/examples/ghc86/TupleN.hs
new file mode 100644
index 0000000..be8618e
--- /dev/null
+++ b/tests/examples/ghc86/TupleN.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TupleN where
+import Language.Haskell.TH
+
+tuple :: Int -> ExpQ
+tuple n = [|\list -> $(tupE (exprs [|list|])) |]
+ where
+ exprs list = id [infixE (Just (list))
+ (varE '(!!))
+ (Just (litE $ integerL (toInteger num)))
+ | num <- [0..(n - 1)]]
diff --git a/tests/examples/ghc86/UnicodeSyntax.hs b/tests/examples/ghc86/UnicodeSyntax.hs
new file mode 100644
index 0000000..103f793
--- /dev/null
+++ b/tests/examples/ghc86/UnicodeSyntax.hs
@@ -0,0 +1,243 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE Arrows #-}
+
+module Tutorial where
+
+-- import Abt.Class
+-- import Abt.Types
+-- import Abt.Concrete.LocallyNameless
+
+import Control.Applicative
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Except
+-- import Data.Vinyl
+import Prelude hiding (pi)
+
+-- | We'll start off with a monad in which to manipulate ABTs; we'll need some
+-- state for fresh variable generation.
+--
+newtype M α
+ = M
+ { _M ∷ State Int α
+ } deriving (Functor, Applicative, Monad)
+
+-- | We'll run an ABT computation by starting the variable counter at @0@.
+--
+runM ∷ M α → α
+runM (M m) = evalState m 0
+
+-- | Check out the source to see fresh variable generation.
+--
+instance MonadVar Var M where
+ fresh = M $ do
+ n ← get
+ let n' = n + 1
+ put n'
+ return $ Var Nothing n'
+
+ named a = do
+ v ← fresh
+ return $ v { _varName = Just a }
+
+-- | Next, we'll define the operators for a tiny lambda calculus as a datatype
+-- indexed by arities.
+--
+data Lang ns where
+ LAM ∷ Lang '[S Z]
+ APP ∷ Lang '[Z, Z]
+ PI ∷ Lang '[Z, S Z]
+ UNIT ∷ Lang '[]
+ AX ∷ Lang '[]
+
+instance Show1 Lang where
+ show1 = \case
+ LAM → "lam"
+ APP → "ap"
+ PI → "pi"
+ UNIT → "unit"
+ AX → "<>"
+
+instance HEq1 Lang where
+ heq1 LAM LAM = Just Refl
+ heq1 APP APP = Just Refl
+ heq1 PI PI = Just Refl
+ heq1 UNIT UNIT = Just Refl
+ heq1 AX AX = Just Refl
+ heq1 _ _ = Nothing
+
+lam ∷ Tm Lang (S Z) → Tm0 Lang
+lam e = LAM $$ e :& RNil
+
+app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang
+app m n = APP $$ m :& n :& RNil
+
+ax ∷ Tm0 Lang
+ax = AX $$ RNil
+
+unit ∷ Tm0 Lang
+unit = UNIT $$ RNil
+
+pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang
+pi α xβ = PI $$ α :& xβ :& RNil
+
+-- | A monad transformer for small step operational semantics.
+--
+newtype StepT m α
+ = StepT
+ { runStepT ∷ MaybeT m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+-- | To indicate that a term is in normal form.
+--
+stepsExhausted
+ ∷ Applicative m
+ ⇒ StepT m α
+stepsExhausted = StepT . MaybeT $ pure Nothing
+
+instance MonadVar Var m ⇒ MonadVar Var (StepT m) where
+ fresh = StepT . MaybeT $ Just <$> fresh
+ named str = StepT . MaybeT $ Just <$> named str
+
+-- | A single evaluation step.
+--
+step
+ ∷ Tm0 Lang
+ → StepT M (Tm0 Lang)
+step tm =
+ out tm >>= \case
+ APP :$ m :& n :& RNil →
+ out m >>= \case
+ LAM :$ xe :& RNil → xe // n
+ _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n
+ PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ
+ _ → stepsExhausted
+
+-- | The reflexive-transitive closure of a small-step operational semantics.
+--
+star
+ ∷ Monad m
+ ⇒ (α → StepT m α)
+ → (α → m α)
+star f a =
+ runMaybeT (runStepT $ f a) >>=
+ return a `maybe` star f
+
+-- | Evaluate a term to normal form
+--
+eval ∷ Tm0 Lang → Tm0 Lang
+eval = runM . star step
+
+newtype JudgeT m α
+ = JudgeT
+ { runJudgeT ∷ ExceptT String m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where
+ fresh = JudgeT . ExceptT $ Right <$> fresh
+ named str = JudgeT . ExceptT $ Right <$> named str
+
+type Ctx = [(Var, Tm0 Lang)]
+
+raise ∷ Monad m ⇒ String → JudgeT m α
+raise = JudgeT . ExceptT . return . Left
+
+checkTy
+ ∷ Ctx
+ → Tm0 Lang
+ → Tm0 Lang
+ → JudgeT M ()
+checkTy g tm ty = do
+ let ntm = eval tm
+ nty = eval ty
+ (,) <$> out ntm <*> out nty >>= \case
+ (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do
+ z ← fresh
+ ez ← xe // var z
+ βz ← yβ // var z
+ checkTy ((z,α):g) ez βz
+ (AX :$ RNil, UNIT :$ RNil) → return ()
+ _ → do
+ ty' ← inferTy g tm
+ if ty' === nty
+ then return ()
+ else raise "Type error"
+
+inferTy
+ ∷ Ctx
+ → Tm0 Lang
+ → JudgeT M (Tm0 Lang)
+inferTy g tm = do
+ out (eval tm) >>= \case
+ V v | Just (eval → ty) ← lookup v g → return ty
+ | otherwise → raise "Ill-scoped variable"
+ APP :$ m :& n :& RNil → do
+ inferTy g m >>= out >>= \case
+ PI :$ α :& xβ :& RNil → do
+ checkTy g n α
+ eval <$> xβ // n
+ _ → raise "Expected pi type for lambda abstraction"
+ _ → raise "Only infer neutral terms"
+
+-- | @λx.x@
+--
+identityTm ∷ M (Tm0 Lang)
+identityTm = do
+ x ← fresh
+ return $ lam (x \\ var x)
+
+-- | @(λx.x)(λx.x)@
+--
+appTm ∷ M (Tm0 Lang)
+appTm = do
+ tm ← identityTm
+ return $ app tm tm
+
+-- | A demonstration of evaluating (and pretty-printing). Output:
+--
+-- @
+-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4]
+-- @
+--
+main ∷ IO ()
+main = do
+ -- Try out the type checker
+ either fail print . runM . runExceptT . runJudgeT $ do
+ x ← fresh
+ checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit))
+
+ print . runM $ do
+ mm ← appTm
+ mmStr ← toString mm
+ mmStr' ← toString $ eval mm
+ return $ mmStr ++ " ~>* " ++ mmStr'
+
+doMap ∷ FilePath → IOSArrow XmlTree TiledMap
+doMap mapPath = proc m → do
+ mapWidth ← getAttrR "width" ⤙ m
+ returnA -< baz
+
+-- ^ An opaque ESD handle for recording data from the soundcard via ESD.
+data Recorder fr ch (r ∷ ★ → ★)
+ = Recorder {
+ reRate ∷ !Int
+ , reHandle ∷ !Handle
+ , reCloseH ∷ !(FinalizerHandle r)
+ }
+
+-- from ghc-prim
+
+-- | A backward-compatible (pre-GHC 8.0) synonym for 'Type'
+-- type * = TYPE 'PtrRepLifted
+
+-- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type'
+-- type ★ = TYPE 'PtrRepLifted
diff --git a/tests/examples/ghc86/Webhook.hs b/tests/examples/ghc86/Webhook.hs
new file mode 100644
index 0000000..e9125ac
--- /dev/null
+++ b/tests/examples/ghc86/Webhook.hs
@@ -0,0 +1,176 @@
+{-|
+Module : Servant.GitHub.Webhook
+Description : Easily write safe GitHub webhook handlers with Servant
+Copyright : (c) Jacob Thomas Errington, 2016
+License : MIT
+Maintainer : servant-github-webhook@mail.jerrington.me
+Stability : experimental
+
+The GitHub webhook machinery will attach three headers to the HTTP requests
+that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@.
+The former two headers correspond with the 'GitHubEvent' and
+'GitHubSignedReqBody''' routing combinators. This library ignores the
+@X-Github-Delivery@ header; if you would like to access its value, then use the
+builtin 'Header' combinator from Servant.
+
+Usage of the library is straightforward: protect routes with the 'GitHubEvent'
+combinator to ensure that the route is only reached for specific
+'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write
+under that route with 'GitHubSignedReqBody'. It is advised to always include a
+'GitHubSignedReqBody''', as this is the only way you can be sure that it is
+GitHub who is sending the request, and not a malicious user. If you don't care
+about the request body, then simply use Aeson\'s 'Object' type as the
+deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and
+ignore the @Object@ in the handler.
+
+The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in
+order to extract the signing key. This is the same key that must be entered in
+the configuration of the webhook on GitHub. See 'GitHubKey'' for more details.
+
+In order to support multiple keys on a per-route basis, the basic combinator
+@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this,
+create a datatype, e.g. @KeyIndex@ whose constructors identify the different
+keys you will be using. Generally, this means one constructor per repository.
+Use the @DataKinds@ extension to promote this datatype to a kind, and write an
+instance of 'Reflect' for each promoted constructor of your datatype. Finally,
+create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is
+the datatype you've built up. Thus, your function can determine which key to
+retrieve.
+-}
+
+{-# LANGUAGE CPP #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- GHC 8 seems to have improved its decidability check for type family
+-- instances and class instances. In particular, without UndecidableInstances
+-- enabled, the Demote' instance for lists, which we need, will not compile.
+-- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol,
+-- won't compile on GHC < 8 because the instance head is no smaller than the
+-- instance head.
+#if __GLASGOW_HASKELL__ < 800
+{-# LANGUAGE UndecidableInstances #-}
+#endif
+
+module Servant.GitHub.Webhook
+( -- * Servant combinators
+ GitHubSignedReqBody''
+, GitHubSignedReqBody'
+, GitHubSignedReqBody
+, GitHubEvent
+
+ -- ** Security
+, GitHubKey'(..)
+, GitHubKey
+, gitHubKey
+
+ -- * Reexports
+ --
+ -- | We reexport a few datatypes that are typically needed to use the
+ -- library.
+, RepoWebhookEvent(..)
+, KProxy(..)
+
+ -- * Implementation details
+
+ -- ** Type-level programming machinery
+, Demote
+, Demote'
+, Reflect(..)
+
+ -- ** Stringy stuff
+, parseHeaderMaybe
+, matchEvent
+
+ -- * Examples
+ --
+ -- $example1
+ --
+ -- $example2
+) where
+
+import Control.Monad.IO.Class ( liftIO )
+import Data.Aeson ( decode', encode )
+import qualified Data.ByteString as BS
+import Data.ByteString.Lazy ( fromStrict, toStrict )
+import qualified Data.ByteString.Base16 as B16
+import Data.HMAC ( hmac_sha1 )
+import Data.List ( intercalate )
+import Data.Maybe ( catMaybes, fromMaybe )
+import Data.Monoid ( (<>) )
+import Data.Proxy
+import Data.String.Conversions ( cs )
+import qualified Data.Text.Encoding as E
+import GHC.TypeLits
+import GitHub.Data.Webhooks
+import Network.HTTP.Types hiding (Header, ResponseHeaders)
+import Network.Wai ( requestHeaders, strictRequestBody )
+import Servant
+import Servant.API.ContentTypes ( AllCTUnrender(..) )
+import Servant.Server.Internal
+
+
+-- | A clone of Servant's 'ReqBody' combinator, except that it will also
+-- verify the signature provided by GitHub in the @X-Hub-Signature@ header by
+-- computing the SHA1 HMAC of the request body and comparing.
+--
+-- The use of this combinator will require that the router context contain an
+-- appropriate 'GitHubKey'' entry. Specifically, the type parameter of
+-- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the
+-- index @key@ used here. Consequently, it will be necessary to use
+-- 'serveWithContext' instead of 'serve'.
+--
+-- Other routes are not tried upon the failure of this combinator, and a 401
+-- response is generated.
+--
+-- Use of this datatype directly is discouraged, since the choice of the index
+-- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use
+-- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just
+-- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for
+-- the implementation of the 'HasServer' instance for the datatype.
+data GitHubSignedReqBody''
+ (proxy :: KProxy k)
+ (key :: k)
+ (list :: [Type])
+ (result :: Type) where
+
+-- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first
+-- type argument given just the second one.
+--
+-- Use this type synonym if you are creating a webhook server to handle
+-- webhooks from multiple repositories, with different secret keys.
+type GitHubSignedReqBody' (key :: k)
+ = GitHubSignedReqBody'' ('KProxy :: KProxy k) key
+
+-- | A convenient alias for a trivial key index.
+--
+-- USe this type synonym if you are creating a webhook server to handle only
+-- webhooks from a single repository, or for mutliple repositories using the
+-- same secret key.
+type GitHubSignedReqBody = GitHubSignedReqBody' '()
+
+-- | A routing combinator that succeeds only for a webhook request that matches
+-- one of the given 'RepoWebhookEvent' given in the type-level list @events@.
+--
+-- If the list contains 'WebhookWildcardEvent', then all events will be
+-- matched.
+--
+-- The combinator will require that its associated handler take a
+-- 'RepoWebhookEvent' parameter, and the matched event will be passed to the
+-- handler. This allows the handler to determine which event triggered it from
+-- the list.
+--
+-- Other routes are tried if there is a mismatch.
+data GitHubEvent (events :: [RepoWebhookEvent]) where
+
diff --git a/tests/examples/ghc86/deriving-via-compile.hs b/tests/examples/ghc86/deriving-via-compile.hs
new file mode 100644
index 0000000..b94da99
--- /dev/null
+++ b/tests/examples/ghc86/deriving-via-compile.hs
@@ -0,0 +1,460 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module DerivingViaCompile where
+
+import Data.Void
+import Data.Complex
+import Data.Functor.Const
+import Data.Functor.Identity
+import Data.Ratio
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Applicative hiding (WrappedMonad(..))
+
+import Data.Bifunctor
+import Data.Monoid
+import Data.Kind
+
+type f ~> g = forall xx. f xx -> g xx
+
+-----
+-- Simple example
+-----
+
+data Foo a = MkFoo a a
+ deriving Show
+ via (Identity (Foo a))
+
+-----
+-- Eta reduction at work
+-----
+
+newtype Flip p a b = Flip { runFlip :: p b a }
+
+instance Bifunctor p => Bifunctor (Flip p) where
+ bimap f g = Flip . bimap g f . runFlip
+
+instance Bifunctor p => Functor (Flip p a) where
+ fmap f = Flip . first f . runFlip
+
+newtype Bar a = MkBar (Either a Int)
+ deriving Functor
+ via (Flip Either Int)
+
+-----
+-- Monad transformers
+-----
+
+type MTrans = (Type -> Type) -> (Type -> Type)
+
+-- From `constraints'
+data Dict c where
+ Dict :: c => Dict c
+
+newtype a :- b = Sub (a => Dict b)
+
+infixl 1 \\
+(\\) :: a => (b => r) -> (a :- b) -> r
+r \\ Sub Dict = r
+
+-- With `-XQuantifiedConstraints' this just becomes
+--
+-- type Lifting cls trans = forall mm. cls mm => cls (trans mm)
+--
+-- type LiftingMonad trans = Lifting Monad trans
+--
+class LiftingMonad (trans :: MTrans) where
+ proof :: Monad m :- Monad (trans m)
+
+instance LiftingMonad (StateT s :: MTrans) where
+ proof :: Monad m :- Monad (StateT s m)
+ proof = Sub Dict
+
+instance Monoid w => LiftingMonad (WriterT w :: MTrans) where
+ proof :: Monad m :- Monad (WriterT w m)
+ proof = Sub Dict
+
+instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where
+ proof :: forall m. Monad m :- Monad (ComposeT trans trans' m)
+ proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m)
+
+newtype Stack :: MTrans where
+ Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a
+ deriving newtype
+ ( Functor
+ , Applicative
+ , Monad
+ , MonadReader Int
+ , MonadState Bool
+ , MonadWriter String
+ )
+ deriving (MonadTrans, MFunctor)
+ via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String)
+
+class MFunctor (trans :: MTrans) where
+ hoist :: Monad m => (m ~> m') -> (trans m ~> trans m')
+
+instance MFunctor (ReaderT r :: MTrans) where
+ hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m')
+ hoist nat = ReaderT . fmap nat . runReaderT
+
+instance MFunctor (StateT s :: MTrans) where
+ hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m')
+ hoist nat = StateT . fmap nat . runStateT
+
+instance MFunctor (WriterT w :: MTrans) where
+ hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m')
+ hoist nat = WriterT . nat . runWriterT
+
+infixr 9 `ComposeT`
+newtype ComposeT :: MTrans -> MTrans -> MTrans where
+ ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a
+ deriving newtype (Functor, Applicative, Monad)
+
+instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where
+ lift :: forall m. Monad m => m ~> ComposeT f g m
+ lift = ComposeT . lift . lift
+ \\ proof @g @m
+
+instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where
+ hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m')
+ hoist f = ComposeT . hoist (hoist f) . getComposeT
+ \\ proof @g @m
+
+-----
+-- Using tuples in a `via` type
+-----
+
+newtype X a = X (a, a)
+ deriving (Semigroup, Monoid)
+ via (Product a, Sum a)
+
+ deriving (Show, Eq)
+ via (a, a)
+
+-----
+-- Abstract data types
+-----
+
+class C f where
+ c :: f a -> Int
+
+newtype X2 f a = X2 (f a)
+
+instance C (X2 f) where
+ c = const 0
+
+deriving via (X2 IO) instance C IO
+
+----
+-- Testing parser
+----
+
+newtype P0 a = P0 a deriving Show via a
+newtype P1 a = P1 [a] deriving Show via [a]
+newtype P2 a = P2 (a, a) deriving Show via (a, a)
+newtype P3 a = P3 (Maybe a) deriving Show via (First a)
+newtype P4 a = P4 (Maybe a) deriving Show via (First $ a)
+newtype P5 a = P5 a deriving Show via (Identity $ a)
+newtype P6 a = P6 [a] deriving Show via ([] $ a)
+newtype P7 a = P7 (a, a) deriving Show via (Identity $ (a, a))
+newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ()))
+
+newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor
+
+----
+-- From Baldur's notes
+----
+
+----
+-- 1
+----
+newtype WrapApplicative f a = WrappedApplicative (f a)
+ deriving (Functor, Applicative)
+
+instance (Applicative f, Num a) => Num (WrapApplicative f a) where
+ (+) = liftA2 (+)
+ (*) = liftA2 (*)
+ negate = fmap negate
+ fromInteger = pure . fromInteger
+ abs = fmap abs
+ signum = fmap signum
+
+instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where
+ recip = fmap recip
+ fromRational = pure . fromRational
+
+instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where
+ pi = pure pi
+ sqrt = fmap sqrt
+ exp = fmap exp
+ log = fmap log
+ sin = fmap sin
+ cos = fmap cos
+ asin = fmap asin
+ atan = fmap atan
+ acos = fmap acos
+ sinh = fmap sinh
+ cosh = fmap cosh
+ asinh = fmap asinh
+ atanh = fmap atanh
+ acosh = fmap acosh
+
+instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where
+ (<>) = liftA2 (<>)
+
+instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where
+ mempty = pure mempty
+
+----
+-- 2
+----
+class Pointed p where
+ pointed :: a -> p a
+
+newtype WrapMonad f a = WrappedMonad (f a)
+ deriving newtype (Pointed, Monad)
+
+instance (Monad m, Pointed m) => Functor (WrapMonad m) where
+ fmap = liftM
+
+instance (Monad m, Pointed m) => Applicative (WrapMonad m) where
+ pure = pointed
+ (<*>) = ap
+
+-- data
+data Sorted a = Sorted a a a
+ deriving (Functor, Applicative)
+ via (WrapMonad Sorted)
+ deriving (Num, Fractional, Floating, Semigroup, Monoid)
+ via (WrapApplicative Sorted a)
+
+
+instance Monad Sorted where
+ (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b
+ Sorted a b c >>= f = Sorted a' b' c' where
+ Sorted a' _ _ = f a
+ Sorted _ b' _ = f b
+ Sorted _ _ c' = f c
+
+instance Pointed Sorted where
+ pointed :: a -> Sorted a
+ pointed a = Sorted a a a
+
+----
+-- 3
+----
+class IsZero a where
+ isZero :: a -> Bool
+
+newtype WrappedNumEq a = WrappedNumEq a
+newtype WrappedShow a = WrappedShow a
+newtype WrappedNumEq2 a = WrappedNumEq2 a
+
+instance (Num a, Eq a) => IsZero (WrappedNumEq a) where
+ isZero :: WrappedNumEq a -> Bool
+ isZero (WrappedNumEq a) = 0 == a
+
+instance Show a => IsZero (WrappedShow a) where
+ isZero :: WrappedShow a -> Bool
+ isZero (WrappedShow a) = "0" == show a
+
+instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
+ isZero :: WrappedNumEq2 a -> Bool
+ isZero (WrappedNumEq2 a) = a + a == a
+
+newtype INT = INT Int
+ deriving newtype Show
+ deriving IsZero via (WrappedNumEq Int)
+
+newtype VOID = VOID Void deriving IsZero via (WrappedShow Void)
+
+----
+-- 4
+----
+class Bifunctor p => Biapplicative p where
+ bipure :: a -> b -> p a b
+
+ biliftA2
+ :: (a -> b -> c)
+ -> (a' -> b' -> c')
+ -> p a a'
+ -> p b b'
+ -> p c c'
+
+instance Biapplicative (,) where
+ bipure = (,)
+
+ biliftA2 f f' (a, a') (b, b') =
+ (f a b, f' a' b')
+
+newtype WrapBiapp p a b = WrapBiap (p a b)
+ deriving newtype (Bifunctor, Biapplicative, Eq)
+
+instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where
+ (+) = biliftA2 (+) (+)
+ (-) = biliftA2 (*) (*)
+ (*) = biliftA2 (*) (*)
+ negate = bimap negate negate
+ abs = bimap abs abs
+ signum = bimap signum signum
+ fromInteger n = fromInteger n `bipure` fromInteger n
+
+newtype INT2 = INT2 (Int, Int)
+ deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int))
+
+----
+-- 5
+----
+class Monoid a => MonoidNull a where
+ null :: a -> Bool
+
+newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid)
+
+instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where
+ null :: WrpMonNull a -> Bool
+ null = (== mempty)
+
+deriving via (WrpMonNull Any) instance MonoidNull Any
+deriving via () instance MonoidNull ()
+deriving via Ordering instance MonoidNull Ordering
+
+----
+-- 6
+----
+-- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635
+
+class Lattice a where
+ sup :: a -> a -> a
+ (.>=) :: a -> a -> Bool
+ (.>) :: a -> a -> Bool
+
+newtype WrapOrd a = WrappedOrd a
+ deriving newtype (Eq, Ord)
+
+instance Ord a => Lattice (WrapOrd a) where
+ sup = max
+ (.>=) = (>=)
+ (.>) = (>)
+
+deriving via [a] instance Ord a => Lattice [a]
+deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b)
+--mkLattice_(Bool)
+deriving via Bool instance Lattice Bool
+--mkLattice_(Char)
+deriving via Char instance Lattice Char
+--mkLattice_(Int)
+deriving via Int instance Lattice Int
+--mkLattice_(Integer)
+deriving via Integer instance Lattice Integer
+--mkLattice_(Float)
+deriving via Float instance Lattice Float
+--mkLattice_(Double)
+deriving via Double instance Lattice Double
+--mkLattice_(Rational)
+deriving via Rational instance Lattice Rational
+
+----
+-- 7
+----
+-- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html
+
+class Functor f => Additive f where
+ zero :: Num a => f a
+ (^+^) :: Num a => f a -> f a -> f a
+ (^+^) = liftU2 (+)
+ (^-^) :: Num a => f a -> f a -> f a
+ x ^-^ y = x ^+^ fmap negate y
+ liftU2 :: (a -> a -> a) -> f a -> f a -> f a
+
+instance Additive [] where
+ zero = []
+ liftU2 f = go where
+ go (x:xs) (y:ys) = f x y : go xs ys
+ go [] ys = ys
+ go xs [] = xs
+
+instance Additive Maybe where
+ zero = Nothing
+ liftU2 f (Just a) (Just b) = Just (f a b)
+ liftU2 _ Nothing ys = ys
+ liftU2 _ xs Nothing = xs
+
+instance Applicative f => Additive (WrapApplicative f) where
+ zero = pure 0
+ liftU2 = liftA2
+
+deriving via (WrapApplicative ((->) a)) instance Additive ((->) a)
+deriving via (WrapApplicative Complex) instance Additive Complex
+deriving via (WrapApplicative Identity) instance Additive Identity
+
+instance Additive ZipList where
+ zero = ZipList []
+ liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys)
+
+class Additive (Diff p) => Affine p where
+ type Diff p :: Type -> Type
+
+ (.-.) :: Num a => p a -> p a -> Diff p a
+ (.+^) :: Num a => p a -> Diff p a -> p a
+ (.-^) :: Num a => p a -> Diff p a -> p a
+ p .-^ v = p .+^ fmap negate v
+
+-- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
+-- (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
+-- (.-^) = (^-^) ; {-# INLINE (.-^) #-}
+-- #define ADDITIVE(T) ADDITIVEC((), T)
+newtype WrapAdditive f a = WrappedAdditive (f a)
+
+instance Additive f => Affine (WrapAdditive f) where
+ type Diff (WrapAdditive f) = f
+
+ WrappedAdditive a .-. WrappedAdditive b = a ^-^ b
+ WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b)
+ WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b)
+
+-- ADDITIVE(((->) a))
+deriving via (WrapAdditive ((->) a)) instance Affine ((->) a)
+-- ADDITIVE([])
+deriving via (WrapAdditive []) instance Affine []
+-- ADDITIVE(Complex)
+deriving via (WrapAdditive Complex) instance Affine Complex
+-- ADDITIVE(Maybe)
+deriving via (WrapAdditive Maybe) instance Affine Maybe
+-- ADDITIVE(ZipList)
+deriving via (WrapAdditive ZipList) instance Affine ZipList
+-- ADDITIVE(Identity)
+deriving via (WrapAdditive Identity) instance Affine Identity
+
+----
+-- 8
+----
+
+class C2 a b c where
+ c2 :: a -> b -> c
+
+instance C2 a b (Const a b) where
+ c2 x _ = Const x
+
+newtype Fweemp a = Fweemp a
+ deriving (C2 a b)
+ via (Const a (b :: Type))
+
diff --git a/tests/examples/ghc86/determ004.hs b/tests/examples/ghc86/determ004.hs
new file mode 100644
index 0000000..3b42148
--- /dev/null
+++ b/tests/examples/ghc86/determ004.hs
@@ -0,0 +1,311 @@
+{-# LANGUAGE TypeOperators
+ , DataKinds
+ , PolyKinds
+ , TypeFamilies
+ , GADTs
+ , UndecidableInstances
+ , RankNTypes
+ , ScopedTypeVariables
+ #-}
+
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Werror #-}
+{-# OPTIONS_GHC -O1 -fspec-constr #-}
+
+{-
+
+With reversed order of allocated uniques the type variables would be in
+wrong order:
+
+*** Core Lint errors : in result of SpecConstr ***
+determ004.hs:88:12: warning:
+ [in body of lambda with binder m_azbFg :: a_afdP_azbON]
+ @ (a_afdP_azbON :: BOX) is out of scope
+*** Offending Program ***
+
+...
+
+Rec {
+$s$wsFoldr1_szbtK
+ :: forall (m_azbFg :: a_afdP_azbON)
+ (x_azbOM :: TyFun
+ a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type)
+ -> Type)
+ (a_afdP_azbON :: BOX)
+ (ipv_szbwN :: a_afdP_azbON)
+ (ipv_szbwO :: [a_afdP_azbON]).
+ R:Sing[]z (ipv_szbwN : ipv_szbwO)
+ ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)
+ -> Sing ipv_szbwO
+ -> Sing ipv_szbwN
+ -> (forall (t_azbNM :: a_afdP_azbON).
+ Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM))
+ -> Sing
+ (Apply
+ (Apply Foldr1Sym0 x_azbOM)
+ (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))
+[LclId,
+ Arity=4,
+ Str=DmdType <L,U><L,U><L,U><C(S(C(S))),C(U(1*C1(U)))>]
+$s$wsFoldr1_szbtK =
+ \ (@ (m_azbFg :: a_afdP_azbON))
+ (@ (x_azbOM :: TyFun
+ a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type)
+ -> Type))
+ (@ (a_afdP_azbON :: BOX))
+ (@ (ipv_szbwN :: a_afdP_azbON))
+ (@ (ipv_szbwO :: [a_afdP_azbON]))
+ (sg_szbtL
+ :: R:Sing[]z (ipv_szbwN : ipv_szbwO)
+ ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO))
+ (sc_szbtM :: Sing ipv_szbwO)
+ (sc_szbtN :: Sing ipv_szbwN)
+ (sc_szbtP
+ :: forall (t_azbNM :: a_afdP_azbON).
+ Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) ->
+ case (SCons
+ @ a_afdP_azbON
+ @ (ipv_szbwN : ipv_szbwO)
+ @ ipv_szbwO
+ @ ipv_szbwN
+ @~ (<ipv_szbwN : ipv_szbwO>_N
+ :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO))
+ sc_szbtN
+ sc_szbtM)
+ `cast` (sg_szbtL
+ ; TFCo:R:Sing[]z[0] <a_afdP_azbON>_N <Let1627448493XsSym4
+ x_azbOM m_azbFg ipv_szbwN ipv_szbwO>_N
+ :: R:Sing[]z (ipv_szbwN : ipv_szbwO)
+ ~R# R:Sing[]z
+ (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))
+ of wild_XD {
+ SNil dt_dzbxX ->
+ (lvl_szbwi @ a_afdP_azbON)
+ `cast` ((Sing
+ (Sym (TFCo:R:Foldr1[2] <a_afdP_azbON>_N <x_azbOM>_N)
+ ; Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ <a_afdP_azbON>_N <'[]>_N <x_azbOM>_N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))
+ (Sym dt_dzbxX))_N))_R
+ :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list")
+ ~R# Sing
+ (Apply
+ (Apply Foldr1Sym0 x_azbOM)
+ (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)));
+ SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH
+ ds_dzbyu [Dmd=<S,1*U>] ->
+ case ds_dzbyu
+ `cast` (TFCo:R:Sing[]z[0] <a_afdP_azbON>_N <n_azbFh>_N
+ :: Sing n_azbFh ~R# R:Sing[]z n_azbFh)
+ of wild_Xo {
+ SNil dt_dzbxk ->
+ (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe)
+ `cast` ((Sing
+ (Sym (TFCo:R:Foldr1[0] <a_afdP_azbON>_N <m_XzbGe>_N <x_azbOM>_N)
+ ; Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ <a_afdP_azbON>_N <'[m_XzbGe]>_N <x_azbOM>_N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))
+ ((<m_XzbGe>_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R
+ :: Sing m_XzbGe
+ ~R# Sing
+ (Apply
+ (Apply Foldr1Sym0 x_azbOM)
+ (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)));
+ SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK ->
+ case (sc_szbtP @ m_XzbGe _sX_azbOH)
+ `cast` (TFCo:R:Sing(->)f[0]
+ <a_afdP_azbON>_N <a_afdP_azbON>_N <Apply x_azbOM m_XzbGe>_N
+ :: Sing (Apply x_azbOM m_XzbGe)
+ ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe))
+ of wild_X3X { SLambda ds_XzbBr [Dmd=<C(S),1*C1(U)>] ->
+ (ds_XzbBr
+ @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR))
+ (($wsFoldr1_szbuc
+ @ a_afdP_azbON
+ @ x_azbOM
+ @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)
+ sc_szbtP
+ ((SCons
+ @ a_afdP_azbON
+ @ (ipv_XzbyV : ipv_XzbxR)
+ @ ipv_XzbxR
+ @ ipv_XzbyV
+ @~ (<ipv_XzbyV : ipv_XzbxR>_N
+ :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR))
+ ipv_szbwL
+ ipv_szbwK)
+ `cast` (Sym (TFCo:R:Sing[]z[0] <a_afdP_azbON>_N) (Sym
+ (TFCo:R:Apply[][]:$$i[0]
+ <a_afdP_azbON>_N
+ <ipv_XzbxR>_N
+ <ipv_XzbyV>_N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Applyk(->):$l[0]
+ <a_afdP_azbON>_N
+ <ipv_XzbyV>_N))
+ <ipv_XzbxR>_N)_N)
+ :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR)
+ ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR))))
+ `cast` ((Sing
+ ((Apply
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N)
+ <Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR>_N)_N
+ ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ <a_afdP_azbON>_N
+ ((Apply
+ (TFCo:R:Applyk(->):$l[0] <a_afdP_azbON>_N <ipv_XzbyV>_N)
+ <ipv_XzbxR>_N)_N
+ ; TFCo:R:Apply[][]:$$i[0]
+ <a_afdP_azbON>_N <ipv_XzbxR>_N <ipv_XzbyV>_N)
+ <x_azbOM>_N))_R
+ :: Sing
+ (Apply
+ (Apply Foldr1Sym0 x_azbOM)
+ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR))
+ ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR)))))
+ `cast` ((Sing
+ ((Apply
+ <Apply x_azbOM m_XzbGe>_N
+ (Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ <a_afdP_azbON>_N <ipv_XzbyV : ipv_XzbxR>_N <x_azbOM>_N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0]
+ <a_afdP_azbON>_N <x_azbOM>_N))
+ (Sym
+ (TFCo:R:Apply[][]:$$i[0]
+ <a_afdP_azbON>_N <ipv_XzbxR>_N <ipv_XzbyV>_N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Applyk(->):$l[0] <a_afdP_azbON>_N <ipv_XzbyV>_N))
+ <ipv_XzbxR>_N)_N))_N))_N
+ ; Sym
+ (TFCo:R:Foldr1[1]
+ <a_afdP_azbON>_N
+ <ipv_XzbxR>_N
+ <ipv_XzbyV>_N
+ <m_XzbGe>_N
+ <x_azbOM>_N)
+ ; Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ <a_afdP_azbON>_N <m_XzbGe : ipv_XzbyV : ipv_XzbxR>_N <x_azbOM>_N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))
+ ((<m_XzbGe>_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R
+ :: Sing
+ (Apply
+ (Apply x_azbOM m_XzbGe)
+ (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR)))
+ ~R# Sing
+ (Apply
+ (Apply Foldr1Sym0 x_azbOM)
+ (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)))
+ }
+ }
+ }
+...
+-}
+
+module List (sFoldr1) where
+
+data Proxy t
+
+data family Sing (a :: k)
+
+data TyFun (a :: Type) (b :: Type)
+
+type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2
+
+data instance Sing (f :: TyFun k1 k2 -> Type) =
+ SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) }
+
+type SingFunction1 f = forall t. Sing t -> Sing (Apply f t)
+
+type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t)
+singFun2 :: Proxy f -> SingFunction2 f -> Sing f
+singFun2 _ f = SLambda (\x -> SLambda (f x))
+
+data (:$$) (j :: a) (i :: TyFun [a] [a])
+type instance Apply ((:$$) j) i = (:) j i
+
+data (:$) (l :: TyFun a (TyFun [a] [a] -> Type))
+type instance Apply (:$) l = (:$$) l
+data instance Sing (z :: [a])
+ = z ~ '[] =>
+ SNil
+ | forall (m :: a)
+ (n :: [a]). z ~ (:) m n =>
+ SCons (Sing m) (Sing n)
+
+data ErrorSym0 (t1 :: TyFun k1 k2)
+
+type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh
+
+type Let1627448493Xs f_afe9
+ x_afea
+ wild_1627448474_afeb
+ wild_1627448476_afec =
+ Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec
+type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)
+ -> Type)
+ (t_afdZ :: [a_afdP]) =
+ Foldr1 t_afdY t_afdZ
+data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)
+ -> Type)
+ (l_afe2 :: TyFun [a_afdP] a_afdP)
+type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2
+
+data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP
+ -> Type)
+ -> Type) (TyFun [a_afdP] a_afdP -> Type))
+type instance Apply Foldr1Sym0 l = Foldr1Sym1 l
+
+type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP
+ -> Type)
+ -> Type)
+ (a_afe6 :: [a_afdP]) :: a_afdP where
+ Foldr1 z_afe7 '[x_afe8] = x_afe8
+ Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec))
+ Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list"
+
+sFoldr1 ::
+ forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type)
+ (y :: [a_afdP]).
+ Sing x
+ -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y)
+sFoldr1 _ (SCons _sX SNil) = undefined
+sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476))
+ = let
+ lambda_afeC ::
+ forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec.
+ Sing f_afe9
+ -> Sing x_afea
+ -> Sing wild_1627448474_afeb
+ -> Sing wild_1627448476_afec
+ -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec)))
+ lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG
+ = let
+ sXs ::
+ Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)
+ sXs
+ = applySing
+ (applySing
+ (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF)
+ wild_1627448476_afeG
+ in
+ applySing
+ (applySing f_afeD x_afeE)
+ (applySing
+ (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD)
+ sXs)
+ in lambda_afeC sF sX sWild_1627448474 sWild_1627448476
+sFoldr1 _ SNil = undefined
diff --git a/tests/examples/ghc86/dynamic-paper.hs b/tests/examples/ghc86/dynamic-paper.hs
new file mode 100644
index 0000000..5134d8b
--- /dev/null
+++ b/tests/examples/ghc86/dynamic-paper.hs
@@ -0,0 +1,341 @@
+{- This is the code extracted from "A reflection on types", by Simon PJ,
+Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -}
+
+{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators,
+ ScopedTypeVariables, GADTs, FlexibleInstances,
+ UndecidableInstances, RebindableSyntax,
+ DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-}
+
+module Dynamic where
+
+import Data.Map ( Map )
+import qualified Data.Map as Map
+import Unsafe.Coerce ( unsafeCoerce )
+import Control.Monad ( (<=<) )
+import Prelude hiding ( lookup, fromInteger, replicate )
+import qualified Prelude
+import qualified Data.Typeable
+import qualified Data.Data
+import Data.Kind
+
+lookupMap = Map.lookup
+insertMap = Map.insert
+
+-- let's ignore overloaded numbers
+fromInteger :: Integer -> Int
+fromInteger = Prelude.fromInteger
+
+insertStore = undefined
+schema = undefined
+withTypeable = undefined
+throw# = undefined
+
+toDynamicST = undefined
+fromDynamicST = undefined
+
+extendStore :: Typeable a => STRef s a -> a -> Store -> Store
+lookupStore :: Typeable a => STRef s a -> Store -> Maybe a
+
+type Key = Int
+data STRef s a = STR Key
+type Store = Map Key Dynamic
+
+extendStore (STR k) v s = insertMap k (toDynamicST v) s
+lookupStore (STR k) s = case lookupMap k s of
+ Just d -> fromDynamicST d
+ Nothing -> Nothing
+
+toDynamicST :: Typeable a => a -> Dynamic
+fromDynamicST :: Typeable a => Dynamic -> Maybe a
+
+eval = undefined
+data Term
+
+data DynamicSilly = DIntSilly Int
+ | DBoolSilly Bool
+ | DCharSilly Char
+ | DPairSilly DynamicSilly DynamicSilly
+
+
+toDynInt :: Int -> DynamicSilly
+toDynInt = DIntSilly
+
+fromDynInt :: DynamicSilly -> Maybe Int
+fromDynInt (DIntSilly n) = Just n
+fromDynInt _ = Nothing
+
+toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly
+toDynPair = DPairSilly
+
+dynFstSilly :: DynamicSilly -> Maybe DynamicSilly
+dynFstSilly (DPairSilly x1 x2) = Just x1
+dynFstSilly _ = Nothing
+
+eval :: Term -> DynamicSilly
+
+eqT = undefined
+
+instance Typeable (->)
+instance Typeable Maybe
+instance Typeable Bool
+instance Typeable Int
+instance (Typeable a, Typeable b) => Typeable (a b)
+instance Typeable (,)
+
+instance Eq TypeRepX
+
+data Dynamic where
+ Dyn :: TypeRep a -> a -> Dynamic
+
+toDynamic :: Typeable a => a -> Dynamic
+toDynamic x = Dyn typeRep x
+
+eqTNoKind = undefined
+
+eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b)
+ -- Primitive; implemented by compiler
+
+data a :***: b where
+ ReflNoKind :: a :***: a
+
+fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d
+fromDynamic (Dyn (ra :: TypeRep a) (x :: a))
+ = case eqT ra (typeRep :: TypeRep d) of
+ Nothing -> Nothing
+ Just Refl -> Just x
+
+fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d
+
+fromDynamicMonad (Dyn ra x)
+ = do Refl <- eqT ra (typeRep :: TypeRep d)
+ return x
+
+cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b
+cast x = do Refl <- eqT (typeRep :: TypeRep a)
+ (typeRep :: TypeRep b)
+ return x
+
+gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b)
+gcast x = do Refl <- eqT (typeRep :: TypeRep a)
+ (typeRep :: TypeRep b)
+ return x
+
+data SameKind :: k -> k -> Type
+type CheckAppResult = SameKind AppResult AppResultNoKind
+ -- not the most thorough check
+foo :: AppResult x -> AppResultNoKind x
+foo (App y z) = AppNoKind y z
+
+splitApp :: TypeRep a -> Maybe (AppResult a)
+splitApp = undefined
+splitAppNoKind = undefined
+splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a)
+ -- Primitive; implemented by compiler
+
+data AppResultNoKind t where
+ AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b)
+
+dynFstNoKind :: Dynamic -> Maybe Dynamic
+dynFstNoKind (Dyn rpab x)
+ = do AppNoKind rpa rb <- splitAppNoKind rpab
+ AppNoKind rp ra <- splitAppNoKind rpa
+ Refl <- eqT rp (typeRep :: TypeRep (,))
+ return (Dyn ra (fst x))
+
+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
+dynApply (Dyn rf f) (Dyn rx x) = do
+ App ra rt2 <- splitApp rf
+ App rtc rt1 <- splitApp ra
+ Refl <- eqT rtc (typeRep :: TypeRep (->))
+ Refl <- eqT rt1 rx
+ return (Dyn rt2 (f x))
+
+data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind
+
+class Typeable (a :: k) where
+ typeRep :: TypeRep a
+
+data AppResult (t :: k) where
+ App :: forall k1 k (a :: k1 -> k) (b :: k1).
+ TypeRep a -> TypeRep b -> AppResult (a b)
+
+dynFst :: Dynamic -> Maybe Dynamic
+dynFst (Dyn (rpab :: TypeRep pab) (x :: pab))
+
+ = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab
+ -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2|
+
+ App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa
+ -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1|
+
+ Refl <- eqT rp (typeRep :: TypeRep (,))
+ -- introduces |p ~ (,)| and |(k1 -> k2 -> Type) ~ (Type -> Type -> Type)|
+
+ return (Dyn ra (fst x))
+
+eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b)
+
+data (a :: k1) :~: (b :: k2) where
+ Refl :: forall k (a :: k). a :~: a
+
+castDance :: (Typeable a, Typeable b) => a -> Maybe b
+castDance = castR typeRep typeRep
+
+withTypeable :: TypeRep a -> (Typeable a => r) -> r
+
+castR :: TypeRep a -> TypeRep b -> a -> Maybe b
+castR ta tb = withTypeable ta (withTypeable tb castDance)
+
+cmpT = undefined
+compareTypeRep = undefined
+
+data TypeRepX where
+ TypeRepX :: TypeRep a -> TypeRepX
+
+type TyMapLessTyped = Map TypeRepX Dynamic
+
+insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped
+insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x)
+
+lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a
+lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a))
+
+instance Ord TypeRepX where
+ compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2
+
+compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive
+
+data TyMap = Empty | Node Dynamic TyMap TyMap
+
+lookup :: TypeRep a -> TyMap -> Maybe a
+lookup tr1 (Node (Dyn tr2 v) left right) =
+ case compareTypeRep tr1 tr2 of
+ LT -> lookup tr1 left
+ EQ -> castR tr2 tr1 v -- know this cast will succeed
+ GT -> lookup tr1 right
+lookup tr1 Empty = Nothing
+
+cmpT :: TypeRep a -> TypeRep b -> OrderingT a b
+ -- definition is primitive
+
+data OrderingT a b where
+ LTT :: OrderingT a b
+ EQT :: OrderingT t t
+ GTT :: OrderingT a b
+
+data TypeRep (a :: k) where
+ TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b)
+ TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k)
+
+data TyCon = TyCon { tc_module :: Module, tc_name :: String }
+data Module = Module { mod_pkg :: String, mod_name :: String }
+
+tcMaybe :: TyCon
+tcMaybe = TyCon { tc_module = Module { mod_pkg = "base"
+ , mod_name = "Data.Maybe" }
+ , tc_name = "Maybe" }
+
+rt = undefined
+
+delta1 :: Dynamic -> Dynamic
+delta1 dn = case fromDynamic dn of
+ Just f -> f dn
+ Nothing -> dn
+loop1 = delta1 (toDynamic delta1)
+
+data Rid = MkT (forall a. TypeRep a -> a -> a)
+rt :: TypeRep Rid
+delta :: forall a. TypeRep a -> a -> a
+delta ra x = case (eqT ra rt) of
+ Just Refl -> case x of MkT y -> y rt x
+ Nothing -> x
+loop = delta rt (MkT delta)
+
+throw# :: SomeException -> a
+
+data SomeException where
+ SomeException :: Exception e => e -> SomeException
+
+class (Typeable e, Show e) => Exception e where { }
+
+data Company
+data Salary
+incS :: Float -> Salary -> Salary
+incS = undefined
+
+-- some impedance matching with SYB
+instance Data.Data.Data Company
+instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a
+
+mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
+mkT f x = case (cast f) of
+ Just g -> g x
+ Nothing -> x
+
+data Expr a
+frontEnd = undefined
+
+data DynExp where
+ DE :: TypeRep a -> Expr a -> DynExp
+
+frontEnd :: String -> DynExp
+
+data TyConOld
+
+typeOf = undefined
+eqTOld = undefined
+funTcOld = undefined :: TyConOld
+splitTyConApp = undefined
+mkTyCon3 = undefined
+boolTcOld = undefined
+tupleTc = undefined
+mkTyConApp = undefined
+instance Eq TypeRepOld
+instance Eq TyConOld
+
+data TypeRepOld -- Abstract
+
+class TypeableOld a where
+ typeRepOld :: proxy a -> TypeRepOld
+
+data DynamicOld where
+ DynOld :: TypeRepOld -> a -> DynamicOld
+
+data Proxy a = Proxy
+
+fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d
+fromDynamicOld (DynOld trx x)
+ | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x)
+ | otherwise = Nothing
+
+dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld
+dynApplyOld (DynOld trf f) (DynOld trx x) =
+ case splitTyConApp trf of
+ (tc, [t1,t2]) | tc == funTcOld && t1 == trx ->
+ Just (DynOld t2 ((unsafeCoerce f) x))
+ _ -> Nothing
+
+data DynamicClosed where
+ DynClosed :: TypeRepClosed a -> a -> DynamicClosed
+
+data TypeRepClosed (a :: Type) where
+ TBool :: TypeRepClosed Bool
+ TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b)
+ TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b)
+
+
+lookupPil = undefined
+
+lookupPil :: Typeable a => [Dynamic] -> Maybe a
+
+data Dyn1 = Dyn1 Int
+ | DynFun (Dyn1 -> Dyn1)
+ | DynPair (Dyn1, Dyn1)
+
+data TypeEnum = IntType | FloatType | BoolType | DateType | StringType
+data Schema = Object [Schema] |
+ Field TypeEnum |
+ Array Schema
+
+schema :: Typeable a => a -> Schema
diff --git a/tests/examples/ghc86/dynbrk005.hs b/tests/examples/ghc86/dynbrk005.hs
new file mode 100644
index 0000000..30ea3d6
--- /dev/null
+++ b/tests/examples/ghc86/dynbrk005.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+import TupleN
+
+tuple3 x = $(tuple 3) x
+
+normal_fn x = tuple3 x
diff --git a/tests/examples/ghc86/ffi1.hs b/tests/examples/ghc86/ffi1.hs
new file mode 100644
index 0000000..a1a2d79
--- /dev/null
+++ b/tests/examples/ghc86/ffi1.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Lib where
+
+import GHC.Prim
+
+-- Can't unboxed tuples and sums to FFI, we should fail appropriately.
+
+foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int
+foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int
+foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int
+
diff --git a/tests/examples/ghc86/ghci006.hs b/tests/examples/ghc86/ghci006.hs
new file mode 100644
index 0000000..aea1307
--- /dev/null
+++ b/tests/examples/ghc86/ghci006.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE RankNTypes #-}
+module Ghci006 where
+
+data Q = forall x . Show x => Q x
+showQ (Q x) = show x
+
+-- associated bug is that at the interpreter command line,
+-- showQ (Q "foo") crashed the interpreter.
+
diff --git a/tests/examples/ghc86/haddockA026.hs b/tests/examples/ghc86/haddockA026.hs
new file mode 100644
index 0000000..b3f9f0c
--- /dev/null
+++ b/tests/examples/ghc86/haddockA026.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE RankNTypes #-}
+
+module ShouldCompile where
+
+test :: (Eq a) => [a] -- ^ doc1
+ -> forall b . [b] {-^ doc2 -}
+ -> [a] -- ^ doc3
+test xs ys = xs
+
diff --git a/tests/examples/ghc86/haddockA027.hs b/tests/examples/ghc86/haddockA027.hs
new file mode 100644
index 0000000..aa8690d
--- /dev/null
+++ b/tests/examples/ghc86/haddockA027.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE RankNTypes #-}
+
+module ShouldCompile where
+
+test :: [a] -- ^ doc1
+ -> forall b. (Ord b) => [b] {-^ doc2 -}
+ -> forall c. (Num c) => [c] -- ^ doc3
+ -> [a]
+test xs ys zs = xs
+
diff --git a/tests/examples/ghc86/haddockA031.hs b/tests/examples/ghc86/haddockA031.hs
new file mode 100644
index 0000000..a267862
--- /dev/null
+++ b/tests/examples/ghc86/haddockA031.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE RankNTypes #-}
+module ShouldCompile where
+
+data A
+ = A
+ | {-| comment for B -} forall a. B a a
+ | forall a. Num a => C a {-^ comment for C -}
+
diff --git a/tests/examples/ghc86/haddockC026.hs b/tests/examples/ghc86/haddockC026.hs
new file mode 100644
index 0000000..b3f9f0c
--- /dev/null
+++ b/tests/examples/ghc86/haddockC026.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE RankNTypes #-}
+
+module ShouldCompile where
+
+test :: (Eq a) => [a] -- ^ doc1
+ -> forall b . [b] {-^ doc2 -}
+ -> [a] -- ^ doc3
+test xs ys = xs
+
diff --git a/tests/examples/ghc86/haddockC027.hs b/tests/examples/ghc86/haddockC027.hs
new file mode 100644
index 0000000..564a825
--- /dev/null
+++ b/tests/examples/ghc86/haddockC027.hs
@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE RankNTypes #-}
+
+module ShouldCompile where
+
+-- I bet this test is a mistake! From the layout it
+-- looks as if 'test' takes three args, the latter two
+-- of higher rank. But the parens around these args are
+-- missing, so it parses as
+-- test :: [a]
+-- -> forall a. Ord a
+-- => [b]
+-- -> forall c. Num c
+-- => [c]
+-- -> [a]
+--
+-- But maybe that what was intended; I'm not sure
+-- Anyway it should typecheck!
+
+test :: [a] -- ^ doc1
+ -> forall b. (Ord b) => [b] {-^ doc2 -}
+ -> forall c. (Num c) => [c] -- ^ doc3
+ -> [a]
+test xs ys zs = xs
+
diff --git a/tests/examples/ghc86/haddockC031.hs b/tests/examples/ghc86/haddockC031.hs
new file mode 100644
index 0000000..a267862
--- /dev/null
+++ b/tests/examples/ghc86/haddockC031.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE RankNTypes #-}
+module ShouldCompile where
+
+data A
+ = A
+ | {-| comment for B -} forall a. B a a
+ | forall a. Num a => C a {-^ comment for C -}
+
diff --git a/tests/examples/ghc86/mdo.hs b/tests/examples/ghc86/mdo.hs
new file mode 100644
index 0000000..c077a12
--- /dev/null
+++ b/tests/examples/ghc86/mdo.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE RecursiveDo #-}
+import Control.Monad.Fix
+import Data.IORef
+import Prelude hiding (traverse)
+
+data N a = N (IORef Bool, N a, a, N a)
+
+newNode :: N a -> a -> N a -> IO (N a)
+newNode b c f = do v <- newIORef False
+ return (N (v, b, c, f))
+
+ll = mdo n0 <- newNode n3 0 n1
+ n1 <- newNode n0 1 n2
+ n2 <- newNode n1 2 n3
+ n3 <- newNode n2 3 n0
+ return n0
+
+data Dir = F | B deriving Eq
+
+traverse :: Dir -> N a -> IO [a]
+traverse d (N (v, b, i, f)) =
+ do visited <- readIORef v
+ if visited
+ then return []
+ else do writeIORef v True
+ let next = if d == F then f else b
+ is <- traverse d next
+ return (i:is)
+
+l2dll :: [a] -> IO (N a)
+l2dll (x:xs) = mdo c <- newNode l x f
+ (f, l) <- l2dll' c xs
+ return c
+
+l2dll' :: N a -> [a] -> IO (N a, N a)
+l2dll' p [] = return (p, p)
+l2dll' p (x:xs) = mdo c <- newNode p x f
+ (f, l) <- l2dll' c xs
+ return (c, l)
+
diff --git a/tests/examples/ghc86/mkGADTVars.hs b/tests/examples/ghc86/mkGADTVars.hs
new file mode 100644
index 0000000..843fecc
--- /dev/null
+++ b/tests/examples/ghc86/mkGADTVars.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE GADTs, TypeInType #-}
+
+module GADTVars where
+
+import Data.Kind
+import Data.Proxy
+
+data T (k1 :: Type) (k2 :: Type) (a :: k2) (b :: k2) where
+ MkT :: T x1 * (Proxy (y :: x1), z) z
diff --git a/tests/examples/ghc86/overloadedrecflds_generics.hs b/tests/examples/ghc86/overloadedrecflds_generics.hs
new file mode 100644
index 0000000..4c0e112
--- /dev/null
+++ b/tests/examples/ghc86/overloadedrecflds_generics.hs
@@ -0,0 +1,50 @@
+-- Test that DuplicateRecordFields doesn't affect the metadata
+-- generated by GHC.Generics or Data.Data
+
+-- Based on a Stack Overflow post by bennofs
+-- (http://stackoverflow.com/questions/24474581)
+-- licensed under cc by-sa 3.0
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+
+import GHC.Generics
+import Data.Data
+import Data.Proxy
+
+type family FirstSelector (f :: Type -> Type) :: Meta
+type instance FirstSelector (M1 D x f) = FirstSelector f
+type instance FirstSelector (M1 C x f) = FirstSelector f
+type instance FirstSelector (a :*: b) = FirstSelector a
+type instance FirstSelector (M1 S s f) = s
+
+data SelectorProxy (s :: Meta) (f :: Type -> Type) a = SelectorProxy
+type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy ()
+
+-- Extract the first selector name using GHC.Generics
+firstSelectorName :: forall a. Selector (FirstSelector (Rep a))
+ => Proxy a -> String
+firstSelectorName _ =
+ selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a)))
+
+-- Extract the list of selector names for a constructor using Data.Data
+selectorNames :: Data a => a -> [String]
+selectorNames = constrFields . toConstr
+
+data T = MkT { foo :: Int } deriving (Data, Generic)
+data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic)
+
+main = do -- This should yield "foo", not "$sel:foo:MkT"
+ print (firstSelectorName (Proxy :: Proxy T))
+ -- Similarly this should yield "foo"
+ print (firstSelectorName (Proxy :: Proxy U))
+ -- This should yield ["foo"]
+ print (selectorNames (MkT 3))
+ -- And this should yield ["foo","bar"]
+ print (selectorNames (MkU 3 True))
diff --git a/tests/examples/ghc80/BadTelescope.hs b/tests/examples/pre-ghc86/BadTelescope.hs
index acabffe..acabffe 100644
--- a/tests/examples/ghc80/BadTelescope.hs
+++ b/tests/examples/pre-ghc86/BadTelescope.hs
diff --git a/tests/examples/ghc80/BadTelescope2.hs b/tests/examples/pre-ghc86/BadTelescope2.hs
index 6237df4..6237df4 100644
--- a/tests/examples/ghc80/BadTelescope2.hs
+++ b/tests/examples/pre-ghc86/BadTelescope2.hs
diff --git a/tests/examples/ghc80/BadTelescope3.hs b/tests/examples/pre-ghc86/BadTelescope3.hs
index 807479f..807479f 100644
--- a/tests/examples/ghc80/BadTelescope3.hs
+++ b/tests/examples/pre-ghc86/BadTelescope3.hs
diff --git a/tests/examples/ghc80/BadTelescope4.hs b/tests/examples/pre-ghc86/BadTelescope4.hs
index 566922a..566922a 100644
--- a/tests/examples/ghc80/BadTelescope4.hs
+++ b/tests/examples/pre-ghc86/BadTelescope4.hs
diff --git a/tests/examples/ghc80/Dep3.hs b/tests/examples/pre-ghc86/Dep3.hs
index cba5043..cba5043 100644
--- a/tests/examples/ghc80/Dep3.hs
+++ b/tests/examples/pre-ghc86/Dep3.hs
diff --git a/tests/examples/ghc80/KindEqualities2.hs b/tests/examples/pre-ghc86/KindEqualities2.hs
index 5a6f60d..5a6f60d 100644
--- a/tests/examples/ghc80/KindEqualities2.hs
+++ b/tests/examples/pre-ghc86/KindEqualities2.hs
diff --git a/tests/examples/ghc710/LiftedConstructors.hs b/tests/examples/pre-ghc86/LiftedConstructors.hs
index af14b4a..af14b4a 100644
--- a/tests/examples/ghc710/LiftedConstructors.hs
+++ b/tests/examples/pre-ghc86/LiftedConstructors.hs
diff --git a/tests/examples/ghc80/RAE_T32a.hs b/tests/examples/pre-ghc86/RAE_T32a.hs
index 08a4ad7..08a4ad7 100644
--- a/tests/examples/ghc80/RAE_T32a.hs
+++ b/tests/examples/pre-ghc86/RAE_T32a.hs
diff --git a/tests/examples/ghc80/RAE_T32b.hs b/tests/examples/pre-ghc86/RAE_T32b.hs
index 7e06709..7e06709 100644
--- a/tests/examples/ghc80/RAE_T32b.hs
+++ b/tests/examples/pre-ghc86/RAE_T32b.hs
diff --git a/tests/examples/ghc80/Rae31.hs b/tests/examples/pre-ghc86/Rae31.hs
index cedc019..cedc019 100644
--- a/tests/examples/ghc80/Rae31.hs
+++ b/tests/examples/pre-ghc86/Rae31.hs
diff --git a/tests/examples/ghc80/RaeBlogPost.hs b/tests/examples/pre-ghc86/RaeBlogPost.hs
index e99c7b5..e99c7b5 100644
--- a/tests/examples/ghc80/RaeBlogPost.hs
+++ b/tests/examples/pre-ghc86/RaeBlogPost.hs
diff --git a/tests/examples/ghc80/RenamingStar.hs b/tests/examples/pre-ghc86/RenamingStar.hs
index 255021c..255021c 100644
--- a/tests/examples/ghc80/RenamingStar.hs
+++ b/tests/examples/pre-ghc86/RenamingStar.hs
diff --git a/tests/examples/ghc710/SlidingTypeSyn.hs b/tests/examples/pre-ghc86/SlidingTypeSyn.hs
index 1a60d1f..1a60d1f 100644
--- a/tests/examples/ghc710/SlidingTypeSyn.hs
+++ b/tests/examples/pre-ghc86/SlidingTypeSyn.hs
diff --git a/tests/examples/ghc80/T10134a.hs b/tests/examples/pre-ghc86/T10134a.hs
index 0d84d56..0d84d56 100644
--- a/tests/examples/ghc80/T10134a.hs
+++ b/tests/examples/pre-ghc86/T10134a.hs
diff --git a/tests/examples/ghc80/T10321.hs b/tests/examples/pre-ghc86/T10321.hs
index 44d264a..44d264a 100644
--- a/tests/examples/ghc80/T10321.hs
+++ b/tests/examples/pre-ghc86/T10321.hs
diff --git a/tests/examples/ghc80/T10689a.hs b/tests/examples/pre-ghc86/T10689a.hs
index 5b21b42..5b21b42 100644
--- a/tests/examples/ghc80/T10689a.hs
+++ b/tests/examples/pre-ghc86/T10689a.hs
diff --git a/tests/examples/ghc80/T10934.hs b/tests/examples/pre-ghc86/T10934.hs
index fb7a538..fb7a538 100644
--- a/tests/examples/ghc80/T10934.hs
+++ b/tests/examples/pre-ghc86/T10934.hs
diff --git a/tests/examples/ghc80/T11142.hs b/tests/examples/pre-ghc86/T11142.hs
index 58eb3b6..58eb3b6 100644
--- a/tests/examples/ghc80/T11142.hs
+++ b/tests/examples/pre-ghc86/T11142.hs
diff --git a/tests/examples/ghc80/T3927b.hs b/tests/examples/pre-ghc86/T3927b.hs
index 98e4cb9..98e4cb9 100644
--- a/tests/examples/ghc80/T3927b.hs
+++ b/tests/examples/pre-ghc86/T3927b.hs
diff --git a/tests/examples/ghc80/T9632.hs b/tests/examples/pre-ghc86/T9632.hs
index bea468f..bea468f 100644
--- a/tests/examples/ghc80/T9632.hs
+++ b/tests/examples/pre-ghc86/T9632.hs
diff --git a/tests/examples/pre-ghc86/TensorTests.hs b/tests/examples/pre-ghc86/TensorTests.hs
new file mode 100644
index 0000000..497b839
--- /dev/null
+++ b/tests/examples/pre-ghc86/TensorTests.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude,
+ RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators,
+ UndecidableInstances #-}
+
+module TensorTests (tensorTests) where
+
+import Apply.Cyc
+import Tests
+import Utils
+
+import TestTypes
+
+import Crypto.Lol
+import Crypto.Lol.CRTrans
+import Crypto.Lol.Cyclotomic.Tensor
+import Crypto.Lol.Types
+
+import Control.Applicative
+
+import Data.Maybe
+
+import Data.Singletons
+import Data.Promotion.Prelude.Eq
+import Data.Singletons.TypeRepStar ()
+
+import qualified Test.Framework as TF
+
+type TMRParams = ( '( , ,) <$> Tensors <*> Tensors) <*> MRCombos
+
+type TMRParams = ( '(,) <$> Tensors) <*> MRCombos
+tmrParams :: Proxy TMRParams
+tmrParams = Proxy
+
+--type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos
+type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos
+tremParams :: Proxy TrEmParams
+tremParams = Proxy
+
+type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos)
+
+data Liftable :: TyFun (Factored, *) Bool -> *
+type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq)
+
diff --git a/tests/examples/ghc80/UnicodeSyntax.hs b/tests/examples/pre-ghc86/UnicodeSyntax.hs
index 9e4cc50..9e4cc50 100644
--- a/tests/examples/ghc80/UnicodeSyntax.hs
+++ b/tests/examples/pre-ghc86/UnicodeSyntax.hs
diff --git a/tests/examples/ghc710/Vect.hs b/tests/examples/pre-ghc86/Vect.hs
index 59c8404..59c8404 100644
--- a/tests/examples/ghc710/Vect.hs
+++ b/tests/examples/pre-ghc86/Vect.hs
diff --git a/tests/examples/ghc80/Webhook.hs b/tests/examples/pre-ghc86/Webhook.hs
index decc719..decc719 100644
--- a/tests/examples/ghc80/Webhook.hs
+++ b/tests/examples/pre-ghc86/Webhook.hs
diff --git a/tests/examples/ghc80/determ004.hs b/tests/examples/pre-ghc86/determ004.hs
index c74f8d0..c74f8d0 100644
--- a/tests/examples/ghc80/determ004.hs
+++ b/tests/examples/pre-ghc86/determ004.hs
diff --git a/tests/examples/ghc80/dynamic-paper.hs b/tests/examples/pre-ghc86/dynamic-paper.hs
index 4e89209..4e89209 100644
--- a/tests/examples/ghc80/dynamic-paper.hs
+++ b/tests/examples/pre-ghc86/dynamic-paper.hs
diff --git a/tests/examples/ghc80/mkGADTVars.hs b/tests/examples/pre-ghc86/mkGADTVars.hs
index 1e74c69..1e74c69 100644
--- a/tests/examples/ghc80/mkGADTVars.hs
+++ b/tests/examples/pre-ghc86/mkGADTVars.hs
diff --git a/tests/examples/ghc80/overloadedrecflds_generics.hs b/tests/examples/pre-ghc86/overloadedrecflds_generics.hs
index c2b4bd6..c2b4bd6 100644
--- a/tests/examples/ghc80/overloadedrecflds_generics.hs
+++ b/tests/examples/pre-ghc86/overloadedrecflds_generics.hs
diff --git a/tests/examples/ghc710/DiophantineVect.hs b/tests/examples/vect/DiophantineVect.hs
index 5e29679..5e29679 100644
--- a/tests/examples/ghc710/DiophantineVect.hs
+++ b/tests/examples/vect/DiophantineVect.hs