EPA: Bringing over tests and updates from ghc-exactprint

26 files changed, 981 insertions, 0 deletions

diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index e8bbe7c079..e2081aee9c 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -608,3 +608,123 @@ Test19840:
 Test19850:
 	$(CHECK_PPR)   $(LIBDIR) Test19850.hs
 	$(CHECK_EXACT) $(LIBDIR) Test19850.hs
+
+.PHONY: PprCommentsOnly
+PprCommentsOnly:
+	$(CHECK_PPR)   $(LIBDIR) PprCommentsOnly.hs
+	$(CHECK_EXACT) $(LIBDIR) PprCommentsOnly.hs
+
+.PHONY: PprSemis
+PprSemis:
+	$(CHECK_PPR)   $(LIBDIR) PprSemis.hs
+	$(CHECK_EXACT) $(LIBDIR) PprSemis.hs
+
+.PHONY: PprForeignDecl
+PprForeignDecl:
+	# $(CHECK_PPR)   $(LIBDIR) PprForeignDecl.hs
+	$(CHECK_EXACT) $(LIBDIR) PprForeignDecl.hs
+
+.PHONY: PprRoles
+PprRoles:
+	$(CHECK_PPR)   $(LIBDIR) PprRoles.hs
+	$(CHECK_EXACT) $(LIBDIR) PprRoles.hs
+
+.PHONY: PprTypeSynParens
+PprTypeSynParens:
+	$(CHECK_PPR)   $(LIBDIR) PprTypeSynParens.hs
+	$(CHECK_EXACT) $(LIBDIR) PprTypeSynParens.hs
+
+.PHONY: PprEmptyMostlyInst
+PprEmptyMostlyInst:
+	$(CHECK_PPR)   $(LIBDIR) PprEmptyMostlyInst.hs
+	$(CHECK_EXACT) $(LIBDIR) PprEmptyMostlyInst.hs
+
+.PHONY: PprParenFunBind
+PprParenFunBind:
+	$(CHECK_PPR)   $(LIBDIR) PprParenFunBind.hs
+	$(CHECK_EXACT) $(LIBDIR) PprParenFunBind.hs
+
+.PHONY: PprRecordSemi
+PprRecordSemi:
+	$(CHECK_PPR)   $(LIBDIR) PprRecordSemi.hs
+	$(CHECK_EXACT) $(LIBDIR) PprRecordSemi.hs
+
+.PHONY: PprCompleteSig
+PprCompleteSig:
+	$(CHECK_PPR)   $(LIBDIR) PprCompleteSig.hs
+	$(CHECK_EXACT) $(LIBDIR) PprCompleteSig.hs
+
+.PHONY: PprOverloadedLabels
+PprOverloadedLabels:
+	$(CHECK_PPR)   $(LIBDIR) PprOverloadedLabels.hs
+	$(CHECK_EXACT) $(LIBDIR) PprOverloadedLabels.hs
+
+.PHONY: PprArrows
+PprArrows:
+	$(CHECK_PPR)   $(LIBDIR) PprArrows.hs
+	$(CHECK_EXACT) $(LIBDIR) PprArrows.hs
+
+.PHONY: PprOverloadedRecords
+PprOverloadedRecords:
+	$(CHECK_PPR)   $(LIBDIR) PprOverloadedRecords.hs
+	$(CHECK_EXACT) $(LIBDIR) PprOverloadedRecords.hs
+
+.PHONY: PprArrowLambdaCase
+PprArrowLambdaCase:
+	$(CHECK_PPR)   $(LIBDIR) PprArrowLambdaCase.hs
+	$(CHECK_EXACT) $(LIBDIR) PprArrowLambdaCase.hs
+
+.PHONY: PprRecursiveDo
+PprRecursiveDo:
+	$(CHECK_PPR)   $(LIBDIR) PprRecursiveDo.hs
+	$(CHECK_EXACT) $(LIBDIR) PprRecursiveDo.hs
+
+.PHONY: PprTypeBrackets
+PprTypeBrackets:
+	$(CHECK_PPR)   $(LIBDIR) PprTypeBrackets.hs
+	$(CHECK_EXACT) $(LIBDIR) PprTypeBrackets.hs
+
+.PHONY: PprDynamic
+PprDynamic:
+	$(CHECK_PPR)   $(LIBDIR) PprDynamic.hs
+	$(CHECK_EXACT) $(LIBDIR) PprDynamic.hs
+
+.PHONY: PprEmptyMostly
+PprEmptyMostly:
+	$(CHECK_PPR)   $(LIBDIR) PprEmptyMostly.hs
+	$(CHECK_EXACT) $(LIBDIR) PprEmptyMostly.hs
+
+.PHONY: PprClassParens
+PprClassParens:
+	$(CHECK_PPR)   $(LIBDIR) PprClassParens.hs
+	$(CHECK_EXACT) $(LIBDIR) PprClassParens.hs
+
+.PHONY: PprThAbstractFamily
+PprThAbstractFamily:
+	$(CHECK_PPR)   $(LIBDIR) PprThAbstractFamily.hs
+	$(CHECK_EXACT) $(LIBDIR) PprThAbstractFamily.hs
+
+.PHONY: PprClassTypeFamily
+PprClassTypeFamily:
+	$(CHECK_PPR)   $(LIBDIR) PprClassTypeFamily.hs
+	$(CHECK_EXACT) $(LIBDIR) PprClassTypeFamily.hs
+
+.PHONY: PprT13747
+PprT13747:
+	$(CHECK_PPR)   $(LIBDIR) PprT13747.hs
+	$(CHECK_EXACT) $(LIBDIR) PprT13747.hs
+
+.PHONY: PprBracesSemiDataDecl
+PprBracesSemiDataDecl:
+	$(CHECK_PPR)   $(LIBDIR) PprBracesSemiDataDecl.hs
+	$(CHECK_EXACT) $(LIBDIR) PprBracesSemiDataDecl.hs
+
+.PHONY: PprUnicodeSyntax
+PprUnicodeSyntax:
+	$(CHECK_PPR)   $(LIBDIR) PprUnicodeSyntax.hs
+	$(CHECK_EXACT) $(LIBDIR) PprUnicodeSyntax.hs
+
+.PHONY: PprCommentPlacement2
+PprCommentPlacement2:
+	$(CHECK_PPR)   $(LIBDIR) PprCommentPlacement2.hs
+	$(CHECK_EXACT) $(LIBDIR) PprCommentPlacement2.hs
diff --git a/testsuite/tests/printer/PprArrowLambdaCase.hs b/testsuite/tests/printer/PprArrowLambdaCase.hs
new file mode 100644
index 0000000000..c678339890
--- /dev/null
+++ b/testsuite/tests/printer/PprArrowLambdaCase.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE Arrows, LambdaCase #-}
+module Main (main) where
+
+import Control.Arrow
+
+main :: IO ()
+main = do
+  putStrLn $ foo (Just 42)
+  putStrLn $ foo (Just 500)
+  putStrLn $ foo Nothing
+
+foo :: ArrowChoice p => p (Maybe Int) String
+foo = proc x ->
+  (| id (\case
+     Just x | x > 100   -> returnA -< "big " ++ show x
+            | otherwise -> returnA -< "small " ++ show x
+     Nothing            -> returnA -< "none")
+  |) x
diff --git a/testsuite/tests/printer/PprArrows.hs b/testsuite/tests/printer/PprArrows.hs
new file mode 100644
index 0000000000..a98e0689ee
--- /dev/null
+++ b/testsuite/tests/printer/PprArrows.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE Arrows #-}
+module Arrow where
+
+import Control.Arrow
+import qualified Control.Category as Cat
+
+addA :: Arrow a => a b Int -> a b Int -> a b Int
+addA f g = proc x -> do
+                y <- f -< x
+                z <- g -< x
+                returnA -< y + z
+
+newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) }
+
+instance Cat.Category Circuit where
+    id = Circuit $ \a -> (Cat.id, a)
+    (.) = dot
+      where
+        (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a ->
+            let (cir1', b) = cir1 a
+                (cir2', c) = cir2 b
+            in  (cir2' `dot` cir1', c)
+
+instance Arrow Circuit where
+    arr f = Circuit $ \a -> (arr f, f a)
+    first (Circuit cir) = Circuit $ \(b, d) ->
+        let (cir', c) = cir b
+        in  (first cir', (c, d))
+
+-- | Accumulator that outputs a value determined by the supplied function.
+accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b
+accum acc f = Circuit $ \input ->
+    let (output, acc') = input `f` acc
+    in  (accum acc' f, output)
+
+-- | Accumulator that outputs the accumulator value.
+accum' :: b -> (a -> b -> b) -> Circuit a b
+accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b'))
+
+total :: Num a => Circuit a a
+total = accum' 0 (+)
+
+mean3 :: Fractional a => Circuit a a
+mean3 = proc value -> do
+    (t, n) <- (| (&&&) (total -< value) (total -< 1) |)
+    returnA -< t / n
diff --git a/testsuite/tests/printer/PprBracesSemiDataDecl.hs b/testsuite/tests/printer/PprBracesSemiDataDecl.hs
new file mode 100644
index 0000000000..825ba4257d
--- /dev/null
+++ b/testsuite/tests/printer/PprBracesSemiDataDecl.hs
@@ -0,0 +1,6 @@
+
+data Nat (t :: NatKind) where
+{
+    ZeroNat :: Nat Zero;
+    SuccNat :: Nat t -> Nat (Succ t);
+};
diff --git a/testsuite/tests/printer/PprClassParens.hs b/testsuite/tests/printer/PprClassParens.hs
new file mode 100644
index 0000000000..344ce63174
--- /dev/null
+++ b/testsuite/tests/printer/PprClassParens.hs
@@ -0,0 +1,3 @@
+module PprClassParens where
+
+class (f `Compose` g) x
diff --git a/testsuite/tests/printer/PprClassTypeFamily.hs b/testsuite/tests/printer/PprClassTypeFamily.hs
new file mode 100644
index 0000000000..27473a8082
--- /dev/null
+++ b/testsuite/tests/printer/PprClassTypeFamily.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Servant.Auth.Server.Internal.Class where
+
+-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all
+-- elements of @ctx@ to be the in the Context and whose authentication check
+-- returns an @AuthCheck v@.
+class IsAuth a v  where
+  type family AuthArgs a :: [*]
+  runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)
diff --git a/testsuite/tests/printer/PprCommentPlacement2.hs b/testsuite/tests/printer/PprCommentPlacement2.hs
new file mode 100644
index 0000000000..245f12c9e8
--- /dev/null
+++ b/testsuite/tests/printer/PprCommentPlacement2.hs
@@ -0,0 +1,8 @@
+module PprCommentPlacement2 where
+
+c04 = do
+    let result = do
+            acceptStr <- y
+            where
+                --COMMENT
+                aa = bb
diff --git a/testsuite/tests/printer/PprCommentsOnly.hs b/testsuite/tests/printer/PprCommentsOnly.hs
new file mode 100644
index 0000000000..a03c1cb598
--- /dev/null
+++ b/testsuite/tests/printer/PprCommentsOnly.hs
@@ -0,0 +1,5 @@
+{-
+Nothing but comments. Make sure they actually get exact printed
+-}
+
+-- Another one
diff --git a/testsuite/tests/printer/PprCompleteSig.hs b/testsuite/tests/printer/PprCompleteSig.hs
new file mode 100644
index 0000000000..1a5fbaed66
--- /dev/null
+++ b/testsuite/tests/printer/PprCompleteSig.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+module Simple where
+
+pattern Foo :: ()
+pattern Foo = ()
+
+a :: () -> ()
+a Foo = ()
+
+data A = B | C | D
+
+{-# COMPLETE Foo #-}
+{-# COMPLETE B,C #-}
+{-# COMPLETE B #-}
+
+b :: A -> A
+b B = B
+b C = C
diff --git a/testsuite/tests/printer/PprDynamic.hs b/testsuite/tests/printer/PprDynamic.hs
new file mode 100644
index 0000000000..5134d8b067
--- /dev/null
+++ b/testsuite/tests/printer/PprDynamic.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/testsuite/tests/printer/PprEmptyMostly.hs b/testsuite/tests/printer/PprEmptyMostly.hs
new file mode 100644
index 0000000000..ccbade7bd4
--- /dev/null
+++ b/testsuite/tests/printer/PprEmptyMostly.hs
@@ -0,0 +1,14 @@
+module EmptyMostly where
+   { ;;;
+     ;;x=let{;;;;;y=2;;z=3;;;;}in y;
+   -- ;;;;
+    class Foo a where {;;;;;;
+  (--<>--) :: a -> a -> Int  ;
+  infixl 5 --<>-- ;
+  (--<>--) _ _ = 2 ; -- empty decl at the end.
+};
+-- ;;;;;;;;;;;;
+-- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;}
+-- ;;
+   }
+-- really trailing
diff --git a/testsuite/tests/printer/PprEmptyMostlyInst.hs b/testsuite/tests/printer/PprEmptyMostlyInst.hs
new file mode 100644
index 0000000000..1dbe3c1273
--- /dev/null
+++ b/testsuite/tests/printer/PprEmptyMostlyInst.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE FlexibleInstances #-}
+module EmptyMostlyInst where
+   {
+;;;;;;;;;;;;
+;
+instance Eq (Int,Integer) where {;;;;;;;;;
+;;;;;;; a == b = False;;;;;;;;;;;
+}
+   }
diff --git a/testsuite/tests/printer/PprForeignDecl.hs b/testsuite/tests/printer/PprForeignDecl.hs
new file mode 100644
index 0000000000..21c35029ab
--- /dev/null
+++ b/testsuite/tests/printer/PprForeignDecl.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- Based on ghc/testsuite/tests/ffi/should_compile contents
+module PprForeignDecl where
+
+import Foreign
+import GHC.Exts
+import Data.Int
+import Data.Word
+
+-- simple functions
+
+foreign import ccall unsafe "a" a :: IO Int
+
+foreign import ccall unsafe "b" b :: Int -> IO Int
+
+foreign import ccall unsafe "c"
+  c :: Int -> Char -> Float -> Double -> IO Float
+
+-- simple monadic code
+
+d =     a               >>= \ x ->
+        b x             >>= \ y ->
+        c y 'f' 1.0 2.0
+
+-- We can't import the same function using both stdcall and ccall
+-- calling conventions in the same file when compiling via C (this is a
+-- restriction in the C backend caused by the need to emit a prototype
+-- for stdcall functions).
+foreign import stdcall        "p" m_stdcall :: StablePtr a -> IO (StablePtr b)
+foreign import ccall   unsafe "q" m_ccall   :: ByteArray# -> IO Int
+
+-- We can't redefine the calling conventions of certain functions (those from
+-- math.h).
+foreign import stdcall "my_sin" my_sin :: Double -> IO Double
+foreign import stdcall "my_cos" my_cos :: Double -> IO Double
+
+foreign import stdcall "m1" m8  :: IO Int8
+foreign import stdcall "m2" m16 :: IO Int16
+foreign import stdcall "m3" m32 :: IO Int32
+foreign import stdcall "m4" m64 :: IO Int64
+
+foreign import stdcall "dynamic" d8  :: FunPtr (IO Int8) -> IO Int8
+foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16
+foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32
+foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64
+
+foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ();
+
+foreign import ccall unsafe "kitchen"
+   sink :: Ptr a
+        -> ByteArray#
+        -> MutableByteArray# RealWorld
+        -> Int
+        -> Int8
+        -> Int16
+        -> Int32
+        -> Int64
+        -> Word8
+        -> Word16
+        -> Word32
+        -> Word64
+        -> Float
+        -> Double
+        -> IO ()
+
+
+type Sink2 b = Ptr b
+            -> ByteArray#
+            -> MutableByteArray# RealWorld
+            -> Int
+            -> Int8
+            -> Int16
+            -> Int32
+            -> Word8
+            -> Word16
+            -> Word32
+            -> Float
+            -> Double
+            -> IO ()
+
+foreign import ccall unsafe "dynamic"
+  sink2 :: Ptr (Sink2 b) -> Sink2 b
+
+-- exports
+foreign export ccall "plusInt" (+) :: Int -> Int -> Int
+
+listToJSArray :: ToJSRef a => [a] -> IO (JSArray a)
+listToJSArray = toJSArray deconstr
+        where deconstr (x : xs) = Just (x, xs)
+              deconstr [] = Nothing
+
+foreign import javascript unsafe "$r = new Float32Array($1);"
+        float32Array :: JSArray Float -> IO Float32Array
+
+foreign import javascript unsafe "$r = new Int32Array($1);"
+        int32Array :: JSArray Int32 -> IO Int32Array
+
+foreign import javascript unsafe "$r = new Uint16Array($1);"
+        uint16Array :: JSArray Word16 -> IO Uint16Array
+
+foreign import javascript unsafe "$r = new Uint8Array($1);"
+        uint8Array :: JSArray Word8 -> IO Uint8Array
+
+foreign import javascript unsafe "$r = $1.getContext(\"webgl\");"
+        getCtx :: JSRef a -> IO Ctx
diff --git a/testsuite/tests/printer/PprOverloadedLabels.hs b/testsuite/tests/printer/PprOverloadedLabels.hs
new file mode 100644
index 0000000000..361da45086
--- /dev/null
+++ b/testsuite/tests/printer/PprOverloadedLabels.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-}
+
+import GHC.OverloadedLabels
+
+-- No instance for (OverloadedLabel "x" t0)
+a = #x
+
+-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0)
+b = #x #y
+
+-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t)
+c :: IsLabel "x" t => t
+c = #y
+
+main = return ()
diff --git a/testsuite/tests/printer/PprOverloadedRecords.hs b/testsuite/tests/printer/PprOverloadedRecords.hs
new file mode 100644
index 0000000000..49d8c2041d
--- /dev/null
+++ b/testsuite/tests/printer/PprOverloadedRecords.hs
@@ -0,0 +1,27 @@
+-- Test that DuplicateRecordFields works with NamedFieldPuns and
+-- RecordWildCards
+
+{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-}
+
+data S = MkS { foo :: Int }
+  deriving Show
+data T = MkT { foo :: Int }
+  deriving Show
+
+f MkS{foo} = MkT{foo}
+
+g MkT{..} = MkS{..}
+
+h e = let foo = 6 in e { foo } :: S
+
+main = do print a
+          print b
+          print c
+          print d
+  where
+    foo = 42
+
+    a = MkS{foo}
+    b = f a
+    c = g b
+    d = h c
diff --git a/testsuite/tests/printer/PprParenFunBind.hs b/testsuite/tests/printer/PprParenFunBind.hs
new file mode 100644
index 0000000000..6312cdcaee
--- /dev/null
+++ b/testsuite/tests/printer/PprParenFunBind.hs
@@ -0,0 +1,5 @@
+module ParenFunBind where
+
+(foo x)   y  = x + y
+((bar x)) y  = x + y
+((baz x)) (y) = x + y
diff --git a/testsuite/tests/printer/PprRecordSemi.hs b/testsuite/tests/printer/PprRecordSemi.hs
new file mode 100644
index 0000000000..e06c049722
--- /dev/null
+++ b/testsuite/tests/printer/PprRecordSemi.hs
@@ -0,0 +1,15 @@
+-- | Generate a generate statement for the builtin function "fst"
+genFst :: BuiltinBuilder
+genFst = genNoInsts genFst'
+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
+genFst' res f args@[(arg,argType)] = do {
+  ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType
+  ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
+  ; let {
+        ; labels      = getFieldLabels arg_htype 0
+        ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)
+        ; assign      = mkUncondAssign res argexprA
+        } ;
+    -- Return the generate functions
+  ; return [assign]
+  }
diff --git a/testsuite/tests/printer/PprRecursiveDo.hs b/testsuite/tests/printer/PprRecursiveDo.hs
new file mode 100644
index 0000000000..174cc9ecf5
--- /dev/null
+++ b/testsuite/tests/printer/PprRecursiveDo.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE RecursiveDo #-}
+-- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html
+
+import Control.Monad.Fix
+
+data RoseTree a = RoseTree a [RoseTree a]
+  deriving (Show)
+
+exampleTree :: RoseTree Int
+exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []]
+
+pureMax :: Ord a => RoseTree a -> RoseTree (a, a)
+pureMax tree =
+  let (t, largest) = go largest tree
+  in t
+ where
+  go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a)
+  go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x)
+  go biggest (RoseTree x xs) =
+      let sub = map (go biggest) xs
+          (xs', largests) = unzip sub
+      in (RoseTree (x, biggest) xs', max x (maximum largests))
+
+t = pureMax exampleTree
+
+-- ---------------------------------------------------------------------
+
+impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b))
+impureMin f tree = do
+  rec (t, largest) <- go largest tree
+  return t
+ where
+  go smallest (RoseTree x []) = do
+    b <- f x
+    return (RoseTree (x, smallest) [], b)
+
+  go smallest (RoseTree x xs) = do
+    sub <- mapM (go smallest) xs
+    b <- f x
+    let (xs', bs) = unzip sub
+    return (RoseTree (x, smallest) xs', min b (minimum bs))
+
+budget :: String -> IO Int
+budget "Ada"      = return 10 -- A struggling startup programmer
+budget "Curry"    = return 50 -- A big-earner in finance
+budget "Dijkstra" = return 20 -- Teaching is the real reward
+budget "Howard"   = return 5  -- An frugile undergraduate!
+
+inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" []
+                            , RoseTree "Curry" [ RoseTree "Howard" []]
+                            ]
+
+ti = impureMin budget inviteTree
+
+simplemdo = mdo
+  return 5
diff --git a/testsuite/tests/printer/PprRoles.hs b/testsuite/tests/printer/PprRoles.hs
new file mode 100644
index 0000000000..abdc222868
--- /dev/null
+++ b/testsuite/tests/printer/PprRoles.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE RoleAnnotations, PolyKinds #-}
+
+module Roles where
+
+data T1 a = K1 a
+data T2 a = K2 a
+data T3 (a :: k) = K3
+data T4 (a :: * -> *) b = K4 (a b)
+
+data T5 a = K5 a
+data T6 a = K6
+data T7 a b = K7 b
+
+type role T1 nominal
+type role T2 representational
+type role T3 phantom
+type role T4 nominal _
+type role T5 _
diff --git a/testsuite/tests/printer/PprSemis.hs b/testsuite/tests/printer/PprSemis.hs
new file mode 100644
index 0000000000..9faf3c51c2
--- /dev/null
+++ b/testsuite/tests/printer/PprSemis.hs
@@ -0,0 +1,18 @@
+module Semis where
+
+-- Make sure we get all the semicolons in statements
+
+foo :: IO ()
+foo = do
+  do { ;;;; a }
+  a
+
+bar :: IO ()
+bar = do
+  { ;
+    a ;;
+    b
+  }
+
+baz :: IO ()
+baz = do { ;; s ; s ; ; s ;; }
diff --git a/testsuite/tests/printer/PprT13747.hs b/testsuite/tests/printer/PprT13747.hs
new file mode 100644
index 0000000000..749d8d2fc4
--- /dev/null
+++ b/testsuite/tests/printer/PprT13747.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+
+module T13747 where
+
+class C a where
+  type family TC a :: *
+
+class D a where
+  data family TD a :: *
+
+instance C Int where
+  type instance TC Int = Int
+
+instance D Double where
+  data instance TD Double = TDDouble
+
+instance D Int where
+  newtype instance TD Int = TDInt Int
+
+instance D Char where
+    data instance TD Char where
+        C1 :: TD Char
+        C2 :: TD Char
diff --git a/testsuite/tests/printer/PprThAbstractFamily.hs b/testsuite/tests/printer/PprThAbstractFamily.hs
new file mode 100644
index 0000000000..a76b00b602
--- /dev/null
+++ b/testsuite/tests/printer/PprThAbstractFamily.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+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/testsuite/tests/printer/PprTypeBrackets.hs b/testsuite/tests/printer/PprTypeBrackets.hs
new file mode 100644
index 0000000000..eeb343d176
--- /dev/null
+++ b/testsuite/tests/printer/PprTypeBrackets.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}
+
+foo (f :: (Maybe t -> Int)) =
+     undefined
+
+type (((f `ObjectsFUnder` a))) = ConstF f a :/\: f
+type   (f `ObjectsFOver`  a)   = f :/\: ConstF f a
+
+type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a
+type (c `ObjectsOver`  a) = Id c `ObjectsFOver`  a
+
+type family ((a :: Bool) || (b :: Bool)) :: Bool
+type instance 'True  || a = 'True
+type instance a || 'True  = 'True
+type instance 'False || a = a
+type instance a || 'False = a
+
+-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the
+-- previously applied style. Or be a specific value.
+data MaybeDefault v where
+    Default :: MaybeDefault v
+    KeepCurrent :: MaybeDefault v
+    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
+    SetTo2 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v
+
+bar :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a])
+baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v
+
+instance Dsp (S n) where
+  data   (ASig (S n))   = S_A CVar
+  data  ((KSig (S n)))  = S_K CVar
+  data (((INum (S n)))) = S_I CVar
+  getSr    = fst <$> ask
+  getKsmps = snd <$> ask
diff --git a/testsuite/tests/printer/PprTypeSynParens.hs b/testsuite/tests/printer/PprTypeSynParens.hs
new file mode 100644
index 0000000000..b77c01de2f
--- /dev/null
+++ b/testsuite/tests/printer/PprTypeSynParens.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeFamilies #-}
+
+class Compilable a where
+   type CompileResult a :: *
+
+instance Compilable a => Compilable [a] where
+   type CompileResult [a] = [CompileResult a]
+
+instance Compilable a => Compilable (Maybe a) where
+   type CompileResult (Maybe a) = Maybe (CompileResult a)
+
+instance Compilable InterpreterStmt where
+   type CompileResult InterpreterStmt = [Hask.Stmt]
+
+instance Compilable ModuleSpan where
+   type ((CompileResult ModuleSpan)) = Hask.Module
+
+instance Compilable StatementSpan where
+   type (CompileResult StatementSpan) = [Stmt]
diff --git a/testsuite/tests/printer/PprUnicodeSyntax.hs b/testsuite/tests/printer/PprUnicodeSyntax.hs
new file mode 100644
index 0000000000..c40d06a5cc
--- /dev/null
+++ b/testsuite/tests/printer/PprUnicodeSyntax.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE UnicodeSyntax #-}
+
+foo x = addToEnv (∀)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index e936cdc64e..1de996cb9c 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -142,3 +142,31 @@ test('Test19834', ignore_stderr, makefile_test, ['Test19834'])
 test('Test19839', ignore_stderr, makefile_test, ['Test19839'])
 test('Test19840', ignore_stderr, makefile_test, ['Test19840'])
 test('Test19850', ignore_stderr, makefile_test, ['Test19850'])
+test('PprCommentsOnly', ignore_stderr, makefile_test, ['PprCommentsOnly'])
+test('PprSemis', ignore_stderr, makefile_test, ['PprSemis'])
+
+# Normal ppr does not reproduce all foreign decls, commented out
+# in the Makefile for this test.
+test('PprForeignDecl', ignore_stderr, makefile_test, ['PprForeignDecl'])
+
+test('PprRoles', ignore_stderr, makefile_test, ['PprRoles'])
+test('PprTypeSynParens', ignore_stderr, makefile_test, ['PprTypeSynParens'])
+test('PprEmptyMostlyInst', ignore_stderr, makefile_test, ['PprEmptyMostlyInst'])
+test('PprParenFunBind', ignore_stderr, makefile_test, ['PprParenFunBind'])
+test('PprRecordSemi', ignore_stderr, makefile_test, ['PprRecordSemi'])
+test('PprCompleteSig', ignore_stderr, makefile_test, ['PprCompleteSig'])
+test('PprOverloadedLabels', ignore_stderr, makefile_test, ['PprOverloadedLabels'])
+test('PprArrows', ignore_stderr, makefile_test, ['PprArrows'])
+test('PprOverloadedRecords', ignore_stderr, makefile_test, ['PprOverloadedRecords'])
+test('PprArrowLambdaCase', ignore_stderr, makefile_test, ['PprArrowLambdaCase'])
+test('PprRecursiveDo', ignore_stderr, makefile_test, ['PprRecursiveDo'])
+test('PprTypeBrackets', ignore_stderr, makefile_test, ['PprTypeBrackets'])
+test('PprDynamic', ignore_stderr, makefile_test, ['PprDynamic'])
+test('PprEmptyMostly', ignore_stderr, makefile_test, ['PprEmptyMostly'])
+test('PprClassParens', ignore_stderr, makefile_test, ['PprClassParens'])
+test('PprThAbstractFamily', ignore_stderr, makefile_test, ['PprThAbstractFamily'])
+test('PprClassTypeFamily', ignore_stderr, makefile_test, ['PprClassTypeFamily'])
+test('PprT13747', ignore_stderr, makefile_test, ['PprT13747'])
+test('PprBracesSemiDataDecl', ignore_stderr, makefile_test, ['PprBracesSemiDataDecl'])
+test('PprUnicodeSyntax', ignore_stderr, makefile_test, ['PprUnicodeSyntax'])
+test('PprCommentPlacement2', ignore_stderr, makefile_test, ['PprCommentPlacement2'])