diff --git a/ChangeLog b/ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2016-06-02 v0.5.1.0
+ * Support for GHC 8.0.1
+ * Add graftT to the Transform module, courtesy of @xich
+ * Add semi-pure parsing function, courtesy of @lspitzner
2015-12-13 v0.5.0.1
* Fix a bug (#34) where quasiquote values would not roundtrip.
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -1,5 +1,5 @@
name: ghc-exactprint
-version: 0.5.0.1
+version: 0.5.1.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
@@ -26,6 +26,7 @@
maintainer: alan.zimm@gmail.com
category: Development
build-type: Simple
+tested-with: GHC == 7.10.3, GHC == 8.0.1
extra-source-files: ChangeLog
tests/examples/failing/*.hs
tests/examples/ghc710/*.hs
@@ -63,7 +64,8 @@
-- other-modules:
-- other-extensions:
GHC-Options: -Wall
- build-depends: base >=4.7 && <4.9
+ build-depends: base >=4.7 && <5.0
+ , bytestring >= 0.10.6
, containers >= 0.5
, directory >= 1.2
, filepath >= 1.4
@@ -72,6 +74,8 @@
, mtl >= 2.2.1
, syb >= 0.5
, free >= 4.12
+ if impl (ghc >= 7.11)
+ build-depends: ghc-boot
hs-source-dirs: src
default-language: Haskell2010
if impl (ghc < 7.10.2)
@@ -98,6 +102,8 @@
, syb >= 0.5
, silently >= 1.2
, filemanip >= 0.3
+ if impl (ghc >= 7.11)
+ build-depends: ghc-boot
executable roundtrip
main-is: Roundtrip.hs
@@ -117,6 +123,9 @@
, ghc-paths
, syb
, temporary
+ , time
+ if impl (ghc >= 7.11)
+ build-depends: ghc-boot
buildable: True
else
buildable: False
@@ -130,10 +139,36 @@
if flag (roundtrip)
build-depends: base
, directory
+ , filemanip
, filepath
+ , ghc
, Diff
buildable: True
+ if impl (ghc >= 7.11)
+ build-depends: ghc-boot
else
buildable: False
-
+ ghc-options:
+ -threaded
+executable prepare-hackage
+ main-is: PrepareHackage.hs
+ hs-source-dirs: tests
+ default-language: Haskell2010
+ if flag (roundtrip)
+ build-depends: base
+ , containers
+ , directory
+ , filemanip
+ , filepath
+ , ghc >= 7.10.2
+ , ghc-paths >= 0.1
+ , HUnit
+ , text >= 1.2.2
+ , turtle >= 1.2.5
+ buildable: True
+ if impl (ghc >= 7.11)
+ build-depends: ghc-boot
+ else
+ buildable: False
+ GHC-Options: -threaded
diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
@@ -21,6 +21,7 @@
-- 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.Annotate
(
annotate
@@ -57,6 +58,7 @@
import Debug.Trace
+{-# ANN module "HLint: ignore Eta reduce" #-}
-- ---------------------------------------------------------------------
-- |
@@ -116,7 +118,9 @@
-- Required to work around deficiencies in the GHC AST
StoreOriginalSrcSpan :: AnnKey -> (AnnKey -> next) -> AnnotationF next
GetSrcSpanForKw :: GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next
+#if __GLASGOW_HASKELL__ <= 710
StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next
+#endif
AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next
deriving instance Functor (AnnotationF)
@@ -136,7 +140,9 @@
makeFreeCon 'CountAnns
makeFreeCon 'StoreOriginalSrcSpan
makeFreeCon 'GetSrcSpanForKw
+#if __GLASGOW_HASKELL__ <= 710
makeFreeCon 'StoreString
+#endif
makeFreeCon 'AnnotationsToComments
makeFreeCon 'WithSortKey
@@ -155,11 +161,12 @@
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
workOutString :: GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated ()
workOutString kw f = do
ss <- getSrcSpanForKw kw
storeString (f ss) ss
-
+#endif
-- ---------------------------------------------------------------------
@@ -301,8 +308,17 @@
markWithString GHC.AnnClose "#-}"
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
+#else
+instance Annotate GHC.StringLiteral where
+ markAST l (GHC.StringLiteral src _) = markExternal l GHC.AnnVal src
+#endif
+
+-- ---------------------------------------------------------------------
+
instance Annotate (GHC.SourceText,GHC.FastString) where
- markAST l (_,fs) = markAST l fs
+ -- markAST l (_,fs) = markAST l fs
+ markAST l (src,_fs) = markExternal l GHC.AnnVal src
-- ---------------------------------------------------------------------
@@ -343,10 +359,37 @@
markLocatedFromKw GHC.AnnVal n
else markLocated ln
+#if __GLASGOW_HASKELL__ <= 710
(GHC.IEThingWith ln ns) -> do
+#else
+ (GHC.IEThingWith ln wc ns _lfs) -> do
+{-
+ | IEThingWith (Located name)
+ IEWildcard
+ [Located name]
+ [Located (FieldLbl name)]
+ -- ^ Class/Type plus some methods/constructors
+ -- and record fields; see Note [IEThingWith]
+
+-}
+#endif
+ -- TODO: Deal with GHC 8.0 additions
markLocated ln
mark GHC.AnnOpenP
+#if __GLASGOW_HASKELL__ <= 710
mapM_ markLocated ns
+#else
+ case wc of
+ GHC.NoIEWildcard -> mapM_ markLocated ns
+ GHC.IEWildcard n -> do
+ mapM_ markLocated (take n ns)
+ mark GHC.AnnDotdot
+ case drop n ns of
+ [] -> return ()
+ ns' -> do
+ markOffset GHC.AnnComma 0
+ mapM_ markLocated ns'
+#endif
mark GHC.AnnCloseP
(GHC.IEThingAll ln) -> do
@@ -417,7 +460,7 @@
markMany GHC.AnnCommaTuple -- For '(,,,)'
case cnt of
0 -> if cntT > 0
- then return () -- traceM $ "Printing RdrName, no AnnVal, multiple AnnCommTuple:" ++ showGhc (l,n)
+ then return ()
else markExternal l GHC.AnnVal str'
1 -> markWithString GHC.AnnVal str'
_ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)
@@ -451,10 +494,12 @@
mark GHC.AnnOpenP -- '('
mark GHC.AnnTildehsh
mark GHC.AnnCloseP
+#if __GLASGOW_HASKELL__ <= 710
"~" -> do
mark GHC.AnnOpenP
mark GHC.AnnTilde
mark GHC.AnnCloseP
+#endif
_ -> doNormalRdrName
-- ---------------------------------------------------------------------
@@ -483,7 +528,7 @@
#if __GLASGOW_HASKELL__ <= 710
Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg))
#else
- Just (srcPkg,_pkg) -> markWithString GHC.AnnPackageName srcPkg
+ Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg
#endif
markLocated modname
@@ -623,14 +668,7 @@
=> Annotate (GHC.RuleDecl name) where
markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do
markLocated ln
- -- activation
- mark GHC.AnnOpenS -- "["
- mark GHC.AnnTilde
- case act of
- GHC.ActiveBefore n -> markWithString GHC.AnnVal (show n)
- GHC.ActiveAfter n -> markWithString GHC.AnnVal (show n)
- _ -> return ()
- mark GHC.AnnCloseS -- "]"
+ markActivation act
mark GHC.AnnForall
mapM_ markLocated bndrs
@@ -643,17 +681,64 @@
-- ---------------------------------------------------------------------
+markActivation :: GHC.Activation -> Annotated ()
+markActivation act = do
+ mark GHC.AnnOpenS -- '['
+ mark GHC.AnnTilde -- ~
+#if __GLASGOW_HASKELL__ <= 710
+ case act of
+ GHC.ActiveBefore n -> do
+ markWithString GHC.AnnVal (show n)
+ GHC.ActiveAfter n -> do
+ markWithString GHC.AnnVal (show n)
+ _ -> return ()
+#else
+ case act of
+ GHC.ActiveBefore src _ -> do
+ mark GHC.AnnTilde -- ~
+ markWithString GHC.AnnVal src
+ GHC.ActiveAfter src _ -> do
+ markWithString GHC.AnnVal src
+ _ -> return ()
+#endif
+ mark GHC.AnnCloseS -- ']'
+
+-- ---------------------------------------------------------------------
+
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.RuleBndr name) where
markAST _ (GHC.RuleBndr ln) = markLocated ln
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do
mark GHC.AnnOpenP -- "("
markLocated ln
mark GHC.AnnDcolon
markLocated thing
mark GHC.AnnCloseP -- ")"
-
+#else
+ markAST _ (GHC.RuleBndrSig ln st) = do
+ mark GHC.AnnOpenP -- "("
+ markLocated ln
+ mark GHC.AnnDcolon
+ markLHsSigWcType st
+ mark GHC.AnnCloseP -- ")"
+#endif
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
+#else
+markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => GHC.LHsSigWcType name -> Annotated ()
+markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do
+ case mwc of
+ Nothing -> markLocated ty
+ Just lwc -> do
+ -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty])
+ -- markLocated (GHC.L lc sorted)
+ applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")]
+ ++ prepareListAnnotation [ty]
+ )
+#endif
+-- ---------------------------------------------------------------------
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.AnnDecl name) where
@@ -699,9 +784,21 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.ForeignDecl name) where
-
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.ForeignImport ln typ _
(GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do
+#else
+ markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _
+ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do
+{-
+ = ForeignImport
+ { fd_name :: Located name -- defines this name
+ , fd_sig_ty :: LHsSigType name -- sig_ty
+ , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty
+ , fd_fi :: ForeignImport }
+
+-}
+#endif
mark GHC.AnnForeign
mark GHC.AnnImport
markLocated cconv
@@ -709,14 +806,24 @@
then return ()
else markLocated safety
-- markMaybe mh
+#if __GLASGOW_HASKELL__ <= 710
markExternal ls GHC.AnnVal (show src)
+#else
+ if GHC.unLoc cconv == GHC.PrimCallConv
+ then markExternal ls GHC.AnnVal src
+ else markExternal ls GHC.AnnVal (show src)
+#endif
markLocated ln
mark GHC.AnnDcolon
markLocated typ
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do
+#else
+ markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ) _ (GHC.CExport spec (GHC.L ls src))) = do
+#endif
mark GHC.AnnForeign
mark GHC.AnnExport
markLocated spec
@@ -756,7 +863,11 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DerivDecl name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.DerivDecl typ mov) = do
+#else
+ markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do
+#endif
mark GHC.AnnDeriving
mark GHC.AnnInstance
markMaybe mov
@@ -811,7 +922,11 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.ClsInstDecl name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do
+#else
+ markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do
+#endif
mark GHC.AnnInstance
markMaybe mov
markLocated poly
@@ -844,7 +959,11 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DataFamInstDecl name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) defn _) = do
+#else
+ markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats) defn _) = do
+#endif
mark GHC.AnnData
mark GHC.AnnNewtype
mark GHC.AnnInstance
@@ -855,6 +974,10 @@
)
mark GHC.AnnCloseP
+#if __GLASGOW_HASKELL__ > 710
+ mark GHC.AnnDcolon
+ markMaybe (GHC.dd_kindSig defn)
+#endif
mark GHC.AnnWhere
mark GHC.AnnEqual
markDataDefn l defn
@@ -863,12 +986,18 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsBind name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.FunBind (GHC.L _ln _n) _ (GHC.MG matches _ _ _) _ _ _) = do
+#else
+ markAST _ (GHC.FunBind (GHC.L _ln _n) (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do
+#endif
mapM_ markLocated matches
- --markTrailingSemi
- -- markMatchGroup l mg
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do
+#else
+ markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do
+#endif
markLocated lhs
mark GHC.AnnEqual
mapM_ markLocated grhs
@@ -891,13 +1020,25 @@
GHC.PrefixPatSyn ns -> do
markLocated ln
mapM_ markLocated ns
+#if __GLASGOW_HASKELL__ <= 710
+#else
+ GHC.RecordPatSyn fs -> do
+ markLocated ln
+ mark GHC.AnnOpenC -- '{'
+ mapM_ (markLocated . GHC.recordPatSynSelectorId) fs
+ mark GHC.AnnCloseC -- '}'
+#endif
mark GHC.AnnEqual
mark GHC.AnnLarrow
markLocated def
case dir of
GHC.Unidirectional -> return ()
GHC.ImplicitBidirectional -> return ()
- GHC.ExplicitBidirectional mg -> markMatchGroup l mg
+ GHC.ExplicitBidirectional mg -> do
+ mark GHC.AnnWhere
+ mark GHC.AnnOpenC -- '{'
+ markMatchGroup l mg
+ mark GHC.AnnCloseC -- '}'
mark GHC.AnnWhere
mark GHC.AnnOpenC -- '{'
@@ -906,8 +1047,13 @@
-- Introduced after renaming.
markAST _ (GHC.AbsBinds _ _ _ _ _) =
- traceM "warning: AbsBind introduced after renaming"
+ traceM "warning: AbsBinds introduced after renaming"
+#if __GLASGOW_HASKELL__ > 710
+ -- Introduced after renaming.
+ markAST _ GHC.AbsBindsSig{} =
+ traceM "warning: AbsBindsSig introduced after renaming"
+#endif
-- ---------------------------------------------------------------------
@@ -932,25 +1078,47 @@
Annotate body)
=> Annotate (GHC.Match name (GHC.Located body)) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do
+#else
+ markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do
+#endif
let
+#if __GLASGOW_HASKELL__ <= 710
get_infix Nothing = False
get_infix (Just (_,f)) = f
+#else
+ get_infix GHC.NonFunBindMatch = False
+ get_infix (GHC.FunBindMatch _ f) = f
+#endif
case (get_infix mln,pats) of
- (True, (a:b:xs)) -> do
+ (True, a:b:xs) -> do
mark GHC.AnnOpenP
markLocated a
case mln of
+#if __GLASGOW_HASKELL__ <= 710
Nothing -> return ()
Just (n,_) -> markLocated n
+#else
+ GHC.NonFunBindMatch -> return ()
+ GHC.FunBindMatch n _ -> markLocated n
+#endif
markLocated b
mark GHC.AnnCloseP
mapM_ markLocated xs
_ -> do
+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
+#if __GLASGOW_HASKELL__ <= 710
case mln of
Nothing -> mark GHC.AnnFunId
Just (n,_) -> markLocated n
mapM_ markLocated pats
+#else
+ case mln of
+ GHC.NonFunBindMatch -> mark GHC.AnnFunId
+ GHC.FunBindMatch n _ -> markLocated n
+ mapM_ markLocated pats
+#endif
-- TODO: The AnnEqual annotation actually belongs in the first GRHS value
mark GHC.AnnEqual
@@ -976,7 +1144,8 @@
(_:_) -> mark GHC.AnnVbar >> mapM_ markLocated guards
mark GHC.AnnEqual
cntL <- countAnns GHC.AnnLam
- when (cntL == 0) $ mark GHC.AnnRarrow -- For HsLam
+ cntP <- countAnns GHC.AnnProc
+ when (cntL == 0 && cntP == 0) $ mark GHC.AnnRarrow -- For HsLam
markLocated expr
-- ---------------------------------------------------------------------
@@ -984,12 +1153,21 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.Sig name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.TypeSig lns typ _) = do
+#else
+ markAST _ (GHC.TypeSig lns st) = do
+#endif
mapM_ markLocated lns
mark GHC.AnnDcolon
+#if __GLASGOW_HASKELL__ <= 710
markLocated typ
+#else
+ markLHsSigWcType st
+#endif
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do
mark GHC.AnnPattern
markLocated ln
@@ -1005,55 +1183,80 @@
markLocated ctx2
markOffset GHC.AnnDarrow 1
markLocated typ
-
+ markTrailingSemi
+#else
+ markAST _ (GHC.PatSynSig ln (GHC.HsIB _ typ)) = do
+ mark GHC.AnnPattern
+ markLocated ln
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+#endif
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.GenericSig ns typ) = do
+#else
+ markAST _ (GHC.ClassOpSig _ ns (GHC.HsIB _ typ)) = do
+#endif
mark GHC.AnnDefault
mapM_ markLocated ns
mark GHC.AnnDcolon
markLocated typ
+ markTrailingSemi
markAST _ (GHC.IdSig _) =
traceM "warning: Introduced after renaming"
-- FixSig (FixitySig name)
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do
+#else
+ markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src _v fdir))) = do
+#endif
let fixstr = case fdir of
GHC.InfixL -> "infixl"
GHC.InfixR -> "infixr"
GHC.InfixN -> "infix"
markWithString GHC.AnnInfix fixstr
+#if __GLASGOW_HASKELL__ <= 710
markWithString GHC.AnnVal (show v)
+#else
+ markWithString GHC.AnnVal src
+#endif
mapM_ markLocated lns
markTrailingSemi
-- InlineSig (Located name) InlinePragma
-- '{-# INLINE' activation qvar '#-}'
markAST _ (GHC.InlineSig ln inl) = do
- let actStr = case GHC.inl_act inl of
- GHC.NeverActive -> ""
- GHC.AlwaysActive -> ""
- GHC.ActiveBefore np -> show np
- GHC.ActiveAfter np -> show np
markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE'
- mark GHC.AnnOpenS -- '['
- mark GHC.AnnTilde -- ~
- markWithString GHC.AnnVal actStr -- e.g. 34
- mark GHC.AnnCloseS -- ']'
+ markActivation (GHC.inl_act inl)
markLocated ln
markWithString GHC.AnnClose "#-}" -- '#-}'
markTrailingSemi
-
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.SpecSig ln typs inl) = do
- markWithString GHC.AnnOpen (GHC.inl_src inl)
- mark GHC.AnnOpenS -- '['
- mark GHC.AnnTilde -- ~
+#else
+ markAST _ (GHC.SpecSig ln typs inl) = do
+{-
+ | SpecSig (Located name) -- Specialise a function or datatype ...
+ [LHsSigType name] -- ... to these types
+ InlinePragma -- The pragma on SPECIALISE_INLINE form.
+ -- If it's just defaultInlinePragma, then we said
+ -- SPECIALISE, not SPECIALISE_INLINE
- mark GHC.AnnCloseS -- ']'
+-}
+#endif
+ markWithString GHC.AnnOpen (GHC.inl_src inl)
+ markActivation (GHC.inl_act inl)
markLocated ln
mark GHC.AnnDcolon -- '::'
+#if __GLASGOW_HASKELL__ <= 710
mapM_ markLocated typs
+#else
+ mapM_ markLHsSigType typs
+#endif
markWithString GHC.AnnClose "#-}" -- '#-}'
markTrailingSemi
@@ -1062,23 +1265,48 @@
markAST _ (GHC.SpecInstSig src typ) = do
markWithString GHC.AnnOpen src
mark GHC.AnnInstance
+#if __GLASGOW_HASKELL__ <= 710
markLocated typ
+#else
+ markLHsSigType typ
+#endif
markWithString GHC.AnnClose "#-}" -- '#-}'
markTrailingSemi
-- MinimalSig (BooleanFormula (Located name))
- markAST l (GHC.MinimalSig src formula) = do
+ markAST l (GHC.MinimalSig src formula) = do
markWithString GHC.AnnOpen src
annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar]
+#if __GLASGOW_HASKELL__ <= 710
markAST l formula
+#else
+ markLocated formula
+#endif
markWithString GHC.AnnClose "#-}"
markTrailingSemi
+-- --------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
+#else
+markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => GHC.LHsSigType name -> Annotated ()
+markLHsSigType (GHC.HsIB _ typ) = markLocated typ
+
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => Annotate [GHC.LHsSigType name] where
+ markAST l ls = do
+ mark GHC.AnnDeriving
+ markMany GHC.AnnOpenP
+ mapM_ markLHsSigType ls
+ markMany GHC.AnnCloseP
+#endif
+
-- --------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
-- In practice, due to the way the BooleanFormula is constructed in the parser,
-- we will get the following variants
-- a | b : Or [a,b]
@@ -1093,13 +1321,32 @@
markAST _ (GHC.Var x) = markLocated x
markAST l (GHC.Or ls) = mapM_ (markAST l) ls
markAST l (GHC.And ls) = mapM_ (markAST l) ls
+#else
+instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
+ markAST _ (GHC.Var x) = do
+ markLocated x
+ mark GHC.AnnVbar -- '|'
+ markAST l (GHC.Or ls) = mapM_ markLocated ls
+ markAST l (GHC.And ls) = do
+ mapM_ markLocated ls
+ mark GHC.AnnVbar -- '|'
+ markAST _ (GHC.Parens x) = do
+ mark GHC.AnnOpenP -- '('
+ markLocated x
+ mark GHC.AnnCloseP -- ')'
+ mark GHC.AnnVbar -- '|'
+#endif
-- ---------------------------------------------------------------------
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsTyVarBndr name) where
markAST l (GHC.UserTyVar n) = do
+#if __GLASGOW_HASKELL__ <= 710
markAST l n
+#else
+ markLocated n
+#endif
markAST _ (GHC.KindedTyVar n ty) = do
mark GHC.AnnOpenP -- '('
@@ -1113,6 +1360,7 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsType name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do
mark GHC.AnnOpenP -- "("
mark GHC.AnnForall
@@ -1122,27 +1370,64 @@
case mwc of
Nothing -> if lc /= GHC.noSrcSpan then markLocated ctx else return ()
Just lwc -> do
-#if __GLASGOW_HASKELL__ <= 710
let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs)
markLocated (GHC.L lc sorted)
-#else
- applyListAnnotations (prepareListAnnotation [GHC.L lwc WildCardAnon]
- ++ prepareListAnnotation ctxs)
-#endif
mark GHC.AnnDarrow
markLocated typ
mark GHC.AnnCloseP -- ")"
+#else
+ markAST _ (GHC.HsForAllTy tvs typ) = do
+ mark GHC.AnnOpenP -- "("
+ mark GHC.AnnForall
+ mapM_ markLocated tvs
+ mark GHC.AnnDot
+ markLocated typ
+ mark GHC.AnnCloseP -- ")"
+{-
+ = HsForAllTy -- See Note [HsType binders]
+ { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c'
+ , hst_body :: LHsType name -- body type
+ }
+
+-}
+#endif
+
+#if __GLASGOW_HASKELL__ <= 710
+#else
+ markAST l (GHC.HsQualTy cxt ty) = do
+ mark GHC.AnnDcolon -- for HsKind, alias for HsType
+ markLocated cxt
+ mark GHC.AnnDarrow
+ markLocated ty
+{-
+ | HsQualTy -- See Note [HsType binders]
+ { hst_ctxt :: LHsContext name -- Context C => blah
+ , hst_body :: LHsType name }
+-}
+#endif
+
markAST l (GHC.HsTyVar name) = do
mark GHC.AnnDcolon -- for HsKind, alias for HsType
n <- countAnns GHC.AnnSimpleQuote
case n of
1 -> do
mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenC
+#if __GLASGOW_HASKELL__ <= 710
markLocatedFromKw GHC.AnnName name
_ -> markAST l name
+#else
+ markLocatedFromKw GHC.AnnName (GHC.unLoc name)
+ _ -> markLocated name
+#endif
+#if __GLASGOW_HASKELL__ > 710
+ markAST _ (GHC.HsAppsTy ts) = do
+ mapM_ markLocated ts
+#endif
+
markAST _ (GHC.HsAppTy t1 t2) = do
mark GHC.AnnDcolon -- for HsKind, alias for HsType
markLocated t1
@@ -1173,7 +1458,13 @@
mark GHC.AnnCloseP -- ')'
markWithString GHC.AnnClose "#)" -- '#)'
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsOpTy t1 (_,lo) t2) = do
+#else
+ markAST _ (GHC.HsOpTy t1 lo t2) = do
+ -- | HsOpTy (LHsType name) (Located name) (LHsType name)
+
+#endif
markLocated t1
mark GHC.AnnSimpleQuote
markLocated lo
@@ -1212,6 +1503,7 @@
markLocated t
markLocated ds
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsBangTy b t) = do
case b of
(GHC.HsSrcBang ms (Just True) _) -> do
@@ -1223,7 +1515,33 @@
_ -> return ()
mark GHC.AnnBang
markLocated t
+#else
+ markAST _ (GHC.HsBangTy (GHC.HsSrcBang mt _up _str) t) = do
+ case mt of
+ Nothing -> return ()
+ Just src -> do
+ markWithString GHC.AnnOpen src
+ markWithString GHC.AnnClose "#-}"
+ mark GHC.AnnBang
+ mark GHC.AnnTilde
+ markLocated t
+{-
+ | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations
+data HsSrcBang =
+ HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
+ SrcUnpackedness
+ SrcStrictness
+data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
+ | SrcStrict -- ^ Strict, ie '!'
+ | NoSrcStrict -- ^ no strictness annotation
+data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
+ | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified
+ | NoSrcUnpack -- ^ no unpack pragma
+
+-}
+#endif
+
-- HsRecTy [LConDeclField name]
markAST _ (GHC.HsRecTy cons) = do
mark GHC.AnnOpenC -- '{'
@@ -1255,8 +1573,10 @@
markExternal l GHC.AnnVal s
-- HsWrapTy HsTyAnnotated (HsType name)
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsWrapTy _ _) =
traceM "warning: HsWrapTyy Introduced after renaming"
+#endif
#if __GLASGOW_HASKELL__ <= 710
markAST l (GHC.HsWildcardTy) = do
@@ -1266,8 +1586,8 @@
#else
markAST l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do
markExternal l GHC.AnnVal "_"
- markAST l (GHC.HsWildCardTy (GHC.NamedWildCard n)) = do
- markExternal l GHC.AnnVal (showGhc n)
+ -- markAST l (GHC.HsWildCardTy (GHC.NamedWildCard n)) = do
+ -- markExternal l GHC.AnnVal (showGhc n)
#endif
#if __GLASGOW_HASKELL__ <= 710
@@ -1275,7 +1595,21 @@
markAST l n
#endif
+-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
+#else
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => Annotate (GHC.HsAppType name) where
+ markAST _ (GHC.HsAppInfix t) = do
+ mark GHC.AnnSimpleQuote
+ markLocated t
+ markAST _ (GHC.HsAppPrefix t) = do
+ mark GHC.AnnTilde
+ markLocated t
+#endif
+-- ---------------------------------------------------------------------
+
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsSplice name) where
#if __GLASGOW_HASKELL__ > 710
markAST l c =
@@ -1284,7 +1618,11 @@
markExternal l GHC.AnnVal
("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")
+#if __GLASGOW_HASKELL__ <= 710
GHC.HsTypedSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do
+#else
+ GHC.HsTypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do
+#endif
markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))
markLocated b
GHC.HsTypedSplice _n b -> do
@@ -1292,7 +1630,11 @@
markLocated b
mark GHC.AnnCloseP
+#if __GLASGOW_HASKELL__ <= 710
GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do
+#else
+ GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do
+#endif
markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))
markLocated b
GHC.HsUntypedSplice _n b -> do
@@ -1315,8 +1657,7 @@
mark GHC.AnnCloseP
#endif
-#if __GLASGOW_HASKELL__ > 710
-#else
+#if __GLASGOW_HASKELL__ <= 710
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsQuasiQuote name) where
markAST l (GHC.HsQuasiQuote n _pos fs) = do
@@ -1329,6 +1670,14 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) =>
Annotate (GHC.ConDeclField name) where
markAST _ (GHC.ConDeclField ns ty mdoc) = do
+{-
+data ConDeclField name -- Record fields have Haddoc docs on them
+ = ConDeclField { cd_fld_names :: [LFieldOcc name],
+ -- ^ See Note [ConDeclField names]
+ cd_fld_type :: LBangType name,
+ cd_fld_doc :: Maybe LHsDocString }
+
+-}
mapM_ markLocated ns
mark GHC.AnnDcolon
markLocated ty
@@ -1336,6 +1685,14 @@
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ > 710
+instance (GHC.DataId name)
+ => Annotate (GHC.FieldOcc name) where
+ markAST l (GHC.FieldOcc rn _) = markLocated rn
+#endif
+
+-- ---------------------------------------------------------------------
+
instance Annotate GHC.HsDocString where
markAST l (GHC.HsDocString s) = do
markExternal l GHC.AnnVal (GHC.unpackFS s)
@@ -1345,7 +1702,11 @@
=> Annotate (GHC.Pat name) where
markAST l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"
markAST l (GHC.VarPat n) = do
+#if __GLASGOW_HASKELL__ <= 710
markAST l n
+#else
+ markLocated n
+#endif
markAST _ (GHC.LazyPat p) = do
mark GHC.AnnTilde
markLocated p
@@ -1403,21 +1764,36 @@
markAST l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp)
-- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id)
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.NPat ol _ _) = do
+#else
+ markAST _ (GHC.NPat ol _ _ _) = do
+#endif
mark GHC.AnnMinus
markLocated ol
-- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id)
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.NPlusKPat ln ol _ _) = do
+#else
+ markAST _ (GHC.NPlusKPat ln ol _ _ _ _) = do
+#endif
markLocated ln
markWithString GHC.AnnVal "+" -- "+"
markLocated ol
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do
markLocated pat
mark GHC.AnnDcolon
markLocated ty
+#else
+ markAST _ (GHC.SigPatIn pat ty) = do
+ markLocated pat
+ mark GHC.AnnDcolon
+ markLHsSigWcType ty
+#endif
markAST _ (GHC.SigPatOut {}) =
traceM "warning: SigPatOut introduced after renaming"
@@ -1448,7 +1824,7 @@
GHC.HsInteger src _ _ -> src
GHC.HsRat (GHC.FL src _) _ -> src
GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#"
- GHC.HsDoublePrim (GHC.FL src _) -> src
+ GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##"
markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.Located name -> GHC.HsConPatDetails name -> Annotated ()
@@ -1506,10 +1882,17 @@
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
instance (GHC.DataId name,Annotate arg)
=> Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where
markAST _ (GHC.HsWB thing _ _ _) = do
markLocated thing
+#else
+instance (GHC.DataId name,Annotate arg)
+ => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where
+ markAST _ (GHC.HsIB _ thing) = do
+ markLocated thing
+#endif
-- ---------------------------------------------------------------------
@@ -1517,25 +1900,41 @@
,GHC.HasOccName name,Annotate body)
=> Annotate (GHC.Stmt name (GHC.Located body)) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.LastStmt body _) = markLocated body
+#else
+ markAST _ (GHC.LastStmt body _ _) = markLocated body
+#endif
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.BindStmt pat body _ _) = do
+#else
+ markAST _ (GHC.BindStmt pat body _ _ _) = do
+#endif
markLocated pat
mark GHC.AnnLarrow
markLocated body
mark GHC.AnnVbar -- possible in list comprehension
markTrailingSemi
+#if __GLASGOW_HASKELL__ > 710
+ markAST _ GHC.ApplicativeStmt{}
+ = error "ApplicativeStmt should not appear in ParsedSource"
+#endif
+
markAST _ (GHC.BodyStmt body _ _ _) = do
markLocated body
mark GHC.AnnVbar -- possible in list comprehension
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.LetStmt lb) = do
+#else
+ markAST _ (GHC.LetStmt (GHC.L l lb)) = do
+#endif
-- return () `debug` ("markP.LetStmt entered")
mark GHC.AnnLet
mark GHC.AnnOpenC -- '{'
- --markOffset GHC.AnnSemi 0
markInside GHC.AnnSemi
markLocalBindsWithLayout lb
mark GHC.AnnCloseC -- '}'
@@ -1543,12 +1942,20 @@
mark GHC.AnnVbar -- possible in list comprehension
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST l (GHC.ParStmt pbs _ _) = do
+#else
+ markAST l (GHC.ParStmt pbs _ _ _) = do
+#endif
mapM_ (markAST l) pbs
mark GHC.AnnVbar -- possible in list comprehension
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do
+#else
+ markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do
+#endif
mapM_ markLocated stmts
case form of
GHC.ThenForm -> do
@@ -1568,7 +1975,11 @@
mark GHC.AnnVbar -- possible in list comprehension
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do
+#else
+ markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do
+#endif
mark GHC.AnnRec
mark GHC.AnnOpenC
markInside GHC.AnnSemi
@@ -1610,7 +2021,11 @@
Annotate body)
=> GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body)
-> Annotated ()
+#if __GLASGOW_HASKELL__ <= 710
markMatchGroup _ (GHC.MG matches _ _ _)
+#else
+markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _)
+#endif
= markListWithLayout matches
-- ---------------------------------------------------------------------
@@ -1624,7 +2039,20 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsExpr name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST l (GHC.HsVar n) = markAST l n
+#else
+ markAST l (GHC.HsVar n) = markLocated n
+#endif
+
+#if __GLASGOW_HASKELL__ <= 710
+#else
+ markAST l (GHC.HsRecFld f) = markAST l f
+
+ markAST l (GHC.HsOverLabel fs)
+ = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)
+#endif
+
markAST l (GHC.HsIPVar (GHC.HsIPName v)) =
markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v)
markAST l (GHC.HsOverLit ov) = markAST l ov
@@ -1633,7 +2061,11 @@
markAST _ (GHC.HsLam match) = do
mark GHC.AnnLam
-- TODO: Change this, HsLam binds do not need obey layout rules.
+#if __GLASGOW_HASKELL__ <= 710
mapM_ markLocated (GHC.mg_alts match)
+#else
+ mapM_ markLocated (GHC.unLoc $ GHC.mg_alts match)
+#endif
markAST l (GHC.HsLamCase _ match) = do
mark GHC.AnnLam
@@ -1703,9 +2135,15 @@
markAST _ (GHC.HsMultiIf _ rhs) = do
mark GHC.AnnIf
+ mark GHC.AnnOpenC
mapM_ markLocated rhs
+ mark GHC.AnnCloseC
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsLet binds e) = do
+#else
+ markAST _ (GHC.HsLet (GHC.L _ binds) e) = do
+#endif
setLayoutFlag (do -- Make sure the 'in' gets indented too
mark GHC.AnnLet
mark GHC.AnnOpenC
@@ -1715,7 +2153,11 @@
mark GHC.AnnIn
markLocated e)
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsDo cts es _) = do
+#else
+ markAST _ (GHC.HsDo cts (GHC.L _ es) _) = do
+#endif
mark GHC.AnnDo
mark GHC.AnnMdo
let (ostr,cstr,_isComp) =
@@ -1750,29 +2192,49 @@
mapM_ markLocated es
markWithString GHC.AnnClose ":]"
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do
+#else
+ markAST _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs _)) = do
+#endif
markLocated n
mark GHC.AnnOpenC
mapM_ markLocated fs
mark GHC.AnnDotdot
mark GHC.AnnCloseC
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do
+#else
+ markAST _ (GHC.RecordUpd e fs _cons _ _ _) = do
+#endif
markLocated e
mark GHC.AnnOpenC
mapM_ markLocated fs
mark GHC.AnnDotdot
mark GHC.AnnCloseC
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.ExprWithTySig e typ _) = do
+#else
+ markAST _ (GHC.ExprWithTySig e typ) = do
+#endif
markLocated e
mark GHC.AnnDcolon
+#if __GLASGOW_HASKELL__ <= 710
markLocated typ
+#else
+ markLHsSigWcType typ
+#endif
markAST _ (GHC.ExprWithTySigOut e typ) = do
markLocated e
mark GHC.AnnDcolon
+#if __GLASGOW_HASKELL__ <= 710
markLocated typ
+#else
+ markLHsSigWcType typ
+#endif
markAST _ (GHC.ArithSeq _ _ seqInfo) = do
mark GHC.AnnOpenS -- '['
@@ -1826,8 +2288,8 @@
markWithString GHC.AnnVal (GHC.unpackFS csFStr)
markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"")
#else
- markWithString GHC.AnnVal (fst csFStr)
- markWithString GHC.AnnValStr (fst csFStr)
+ markWithString GHC.AnnVal (GHC.sl_st csFStr)
+ markWithString GHC.AnnValStr (GHC.sl_st csFStr)
#endif
markWithString GHC.AnnClose "#-}"
markLocated e
@@ -1837,7 +2299,7 @@
#if __GLASGOW_HASKELL__ <= 710
markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"")
#else
- markWithString GHC.AnnVal (fst csFStr)
+ markWithString GHC.AnnVal (GHC.sl_st csFStr)
#endif
markWithString GHC.AnnClose "#-}"
markLocated e
@@ -1856,23 +2318,31 @@
markAST _ (GHC.HsBracket (GHC.DecBrG _)) =
traceM "warning: DecBrG introduced after renamer"
markAST _ (GHC.HsBracket (GHC.ExpBr e)) = do
--- markWithString GHC.AnnOpen "[|"
+#if __GLASGOW_HASKELL__ <= 710
-- This exists like this as the lexer collapses [e| and [| into the
-- same construtor
workOutString GHC.AnnOpen
(\ss -> if spanLength ss == 2
then "[|"
else "[e|")
+#else
+ markWithString GHC.AnnOpen "[|"
+ mark GHC.AnnOpenE -- "[e|"
+#endif
markLocated e
markWithString GHC.AnnClose "|]"
markAST _ (GHC.HsBracket (GHC.TExpBr e)) = do
- -- markWithString GHC.AnnOpen "[||"
+#if __GLASGOW_HASKELL__ <= 710
-- This exists like this as the lexer collapses [e|| and [|| into the
-- same construtor
workOutString GHC.AnnOpen
(\ss -> if spanLength ss == 3
then "[||"
else "[e||")
+#else
+ markWithString GHC.AnnOpen "[||"
+ markWithString GHC.AnnOpenE "[e||"
+#endif
markLocated e
markWithString GHC.AnnClose "||]"
markAST _ (GHC.HsBracket (GHC.TypBr e)) = do
@@ -1939,14 +2409,11 @@
markAST _ (GHC.HsTick _ _) = return ()
markAST _ (GHC.HsBinTick _ _ _) = return ()
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do
-- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
markWithString GHC.AnnOpen src
-#if __GLASGOW_HASKELL__ <= 710
markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING
-#else
- markOffsetWithString GHC.AnnVal 0 (fst str) -- STRING
-#endif
markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER
markOffset GHC.AnnColon 0 -- ':'
markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER
@@ -1956,6 +2423,21 @@
markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER
markWithString GHC.AnnClose "#-}"
markLocated e
+#else
+ markAST _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do
+ -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+ markWithString GHC.AnnOpen src
+ markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING
+ markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER
+ markOffset GHC.AnnColon 0 -- ':'
+ markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER
+ mark GHC.AnnMinus -- '-'
+ markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER
+ markOffset GHC.AnnColon 1 -- ':'
+ markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER
+ markWithString GHC.AnnClose "#-}"
+ markLocated e
+#endif
markAST l (GHC.EWildPat) = do
markExternal l GHC.AnnVal "_"
@@ -1974,17 +2456,71 @@
mark GHC.AnnTilde
markLocated e
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsType ty) = markLocated ty
+#else
+ markAST _ (GHC.HsAppType e ty) = do
+ markLocated e
+ mark GHC.AnnAt
+ markLHsWcType ty
+ markAST _ (GHC.HsAppTypeOut _ _) =
+ traceM "warning: HsAppTypeOut introduced after renaming"
+#endif
markAST _ (GHC.HsWrap _ _) =
traceM "warning: HsWrap introduced after renaming"
markAST _ (GHC.HsUnboundVar _) =
traceM "warning: HsUnboundVar introduced after renaming"
+
+-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ > 710
+markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => GHC.LHsWcType name -> Annotated ()
+markLHsWcType (GHC.HsWC _ mwc ty) = do
+ case mwc of
+ Nothing -> markLocated ty
+ Just lwc -> do
+ -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty])
+ -- markLocated (GHC.L lc sorted)
+ applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")]
+ ++ prepareListAnnotation [ty]
+ )
+#endif
+-- ---------------------------------------------------------------------
+
instance Annotate GHC.HsLit where
markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)
+
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ > 710
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => Annotate (GHC.HsRecUpdField name) where
+ markAST _ (GHC.HsRecField lbl expr _isPun) = do
+ markLocated lbl
+ mark GHC.AnnEqual
+ markLocated expr
+{-
+type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+--
+-- For details on above see note [Api annotations] in ApiAnnotation
+data HsRecField' id arg = HsRecField {
+ hsRecFieldLbl :: Located id,
+ hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning
+ hsRecPun :: Bool -- ^ Note [Punning]
+ } deriving (Data, Typeable)
+
+-}
+
+instance (GHC.DataId name)
+ => Annotate (GHC.AmbiguousFieldOcc name) where
+ markAST l (GHC.Unambiguous n _) = markLocated n
+ markAST l (GHC.Ambiguous n _) = markLocated n
+#endif
+-- ---------------------------------------------------------------------
+
-- |Used for declarations that need to be aligned together, e.g. in a
-- do or let .. in statement/expr
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
@@ -2065,7 +2601,11 @@
mark GHC.AnnElse
markLocated e3
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsCmdLet binds e) = do
+#else
+ markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do
+#endif
mark GHC.AnnLet
mark GHC.AnnOpenC
markLocalBindsWithLayout binds
@@ -2073,15 +2613,31 @@
mark GHC.AnnIn
markLocated e
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsCmdDo es _) = do
+#else
+ markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do
+#endif
mark GHC.AnnDo
mark GHC.AnnOpenC
markListWithLayout es
mark GHC.AnnCloseC
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.HsCmdCast {}) =
traceM "warning: HsCmdCast introduced after renaming"
+#endif
+#if __GLASGOW_HASKELL__ > 710
+ markAST _ (GHC.HsCmdWrap {}) =
+ traceM "warning: HsCmdWrap introduced after renaming"
+{-
+ | HsCmdWrap HsWrapper
+ (HsCmd id) -- If cmd :: arg1 --> res
+ -- wrap :: arg1 "->" arg2
+ -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
+-}
+#endif
-- ---------------------------------------------------------------------
@@ -2096,7 +2652,11 @@
markAST l (GHC.FamDecl famdecl) = markAST l famdecl
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do
+#else
+ markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) typ _) = do
+#endif
-- 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
@@ -2111,8 +2671,13 @@
markLocated typ
markTrailingSemi
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars)
(GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do
+#else
+ markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _)
+ (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _ _) = do
+#endif
mark GHC.AnnData
mark GHC.AnnNewtype
markMaybe mctyp
@@ -2125,14 +2690,19 @@
mark GHC.AnnWhere
mark GHC.AnnOpenC
mapM_ markLocated cons
- markMaybe mderivs
mark GHC.AnnCloseC
+ markMaybe mderivs
markTrailingSemi
-- -----------------------------------
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds
sigs meths ats atdefs docs _) = do
+#else
+ markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds
+ sigs meths ats atdefs docs _) = do
+#endif
mark GHC.AnnClass
markLocated ctx
@@ -2167,7 +2737,20 @@
instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.FamilyDecl name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do
+#else
+ markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do
+{-
+data FamilyDecl name = FamilyDecl
+ { fdInfo :: FamilyInfo name -- type/data, closed/open
+ , fdLName :: Located name -- type constructor
+ , fdTyVars :: LHsQTyVars name -- type variables
+ , fdResultSig :: LFamilyResultSig name -- result signature
+ , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann
+ }
+-}
+#endif
mark GHC.AnnType
mark GHC.AnnData
mark GHC.AnnFamily
@@ -2176,9 +2759,17 @@
++ prepareListAnnotation tyvars)
mark GHC.AnnCloseP
mark GHC.AnnDcolon
+#if __GLASGOW_HASKELL__ <= 710
markMaybe mkind
+#else
+ mark GHC.AnnEqual
+ markLocated rsig
+ mark GHC.AnnVbar
+ markMaybe minj
+#endif
mark GHC.AnnWhere
mark GHC.AnnOpenC -- {
+ mark GHC.AnnDotdot
case info of
#if __GLASGOW_HASKELL__ > 710
GHC.ClosedTypeFamily (Just eqns) -> mapM_ markLocated eqns
@@ -2191,9 +2782,37 @@
-- ---------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 710
+#else
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
+ => Annotate (GHC.FamilyResultSig name) where
+ markAST _ (GHC.NoSig) = return ()
+ markAST _ (GHC.KindSig k) = markLocated k
+ markAST _ (GHC.TyVarSig ltv) = markLocated ltv
+#endif
+
+-- ---------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ <= 710
+#else
+instance (GHC.DataId name,Annotate name)
+ => Annotate (GHC.InjectivityAnn name) where
+ markAST l (GHC.InjectivityAnn ln lns) = do
+ mark GHC.AnnVbar
+ markLocated ln
+ mark GHC.AnnRarrow
+ mapM_ markLocated lns
+#endif
+
+-- ---------------------------------------------------------------------
+
+instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.TyFamInstEqn name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do
+#else
+ markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do
+#endif
mark GHC.AnnOpenP
applyListAnnotations (prepareListAnnotation [ln]
++ prepareListAnnotation pats)
@@ -2205,11 +2824,16 @@
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.TyFamDefltEqn name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do
+#else
+ markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do
+#endif
mark GHC.AnnType
mark GHC.AnnInstance
- markLocated ln
- mapM_ markLocated bndrs
+ applyListAnnotations (prepareListAnnotation [ln]
+ ++ prepareListAnnotation bndrs
+ )
mark GHC.AnnEqual
markLocated typ
@@ -2234,7 +2858,9 @@
markDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do
markLocated ctx
markMaybe typ
+#if __GLASGOW_HASKELL__ <= 710
markMaybe mk
+#endif
mapM_ markLocated cons
case mderivs of
Nothing -> return ()
@@ -2246,17 +2872,19 @@
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.LHsType name] where
markAST _ ts = do
+#if __GLASGOW_HASKELL__ <= 710
mark GHC.AnnDeriving
+#endif
markMany GHC.AnnOpenP -- may be nested parens around context
mapM_ markLocated ts
markMany GHC.AnnCloseP -- may be nested parens around context
- -- mark GHC.AnnDarrow
markOutside GHC.AnnDarrow (G GHC.AnnDarrow)
-- ---------------------------------------------------------------------
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.ConDecl name) where
+#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx
dets res _ depc_syntax) = do
case res of
@@ -2302,7 +2930,57 @@
mark GHC.AnnVbar
markTrailingSemi
+#else
+ markAST _ (GHC.ConDeclH98 ln mqtvs ctx
+ dets _ ) = do
+{-
+ | ConDeclH98
+ { con_name :: Located name
+ , con_qvars :: Maybe (LHsQTyVars name)
+ -- User-written forall (if any), and its implicit
+ -- kind variables
+ -- Non-Nothing needs -XExistentialQuantification
+ -- e.g. data T a = forall b. MkT b (b->a)
+ -- con_qvars = {b}
+
+ , con_cxt :: Maybe (LHsContext name)
+ -- ^ User-written context (if any)
+
+ , con_details :: HsConDeclDetails name
+ -- ^ Arguments
+
+ , con_doc :: Maybe LHsDocString
+ -- ^ A possible Haddock comment.
+
+-}
+ case mqtvs of
+ Nothing -> return ()
+#if __GLASGOW_HASKELL__ <= 710
+ Just (GHC.HsQTvs _ns bndrs) -> do
+#else
+ Just (GHC.HsQTvs _ns bndrs _) -> do
+#endif
+ mark GHC.AnnForall
+ mapM_ markLocated bndrs
+ mark GHC.AnnDot
+
+ markMaybe ctx
+ mark GHC.AnnDarrow
+ case dets of
+ GHC.InfixCon _ _ -> return ()
+ _ -> markLocated ln
+
+ markHsConDeclDetails [ln] dets
+
+ mark GHC.AnnVbar
+ markTrailingSemi
+ markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do
+ mapM_ markLocated lns
+ mark GHC.AnnDcolon
+ markLocated typ
+ markTrailingSemi
+#endif
-- ResTyGADT has a SrcSpan for the original sigtype, we need to create
-- a type for exactPC and annotatePC
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE BangPatterns #-}
-- | This module converts 'GHC.ApiAnns' into 'Anns' by traversing a
@@ -68,15 +69,20 @@
import Data.Ord
import Language.Haskell.GHC.ExactPrint.Utils
+#if __GLASGOW_HASKELL__ <= 710
import Language.Haskell.GHC.ExactPrint.Lookup
+#endif
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated
, annotate, Annotate(..))
import qualified GHC
-import qualified SrcLoc as GHC
+import qualified SrcLoc as GHC
import qualified Data.Map as Map
+#if __GLASGOW_HASKELL__ <= 710
+import qualified Data.Set as Set
+#endif
-- import Debug.Trace
@@ -238,17 +244,19 @@
go (MarkMany akwid next) = addDeltaAnnotations akwid >> next
go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next
go (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next
- go (CountAnns kwid next) = countAnnsDelta kwid >>= next
- go (SetLayoutFlag r action next) = do
+ go (CountAnns kwid next) = countAnnsDelta kwid >>= next
+ go (SetLayoutFlag r action next) = do
rigidity <- asks drRigidity
(if (r <= rigidity) then setLayoutFlag else id) (deltaInterpret action)
next
go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next
go (StoreOriginalSrcSpan key next) = storeOriginalSrcSpanDelta key >>= next
go (GetSrcSpanForKw kw next) = getSrcSpanForKw kw >>= next
+#if __GLASGOW_HASKELL__ <= 710
go (StoreString s ss next) = storeString s ss >> next
+#endif
go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next
- go (WithSortKey kws next) = withSortKey kws >> next
+ go (WithSortKey kws next) = withSortKey kws >> next
withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta ()
withSortKey kws =
@@ -275,8 +283,10 @@
tellCapturedSpan key
return key
+#if __GLASGOW_HASKELL__ <= 710
storeString :: String -> GHC.SrcSpan -> Delta ()
storeString s ss = addAnnotationWorker (AnnString s) ss
+#endif
-- ---------------------------------------------------------------------
@@ -366,33 +376,64 @@
peekAnnotationDelta an = do
ga <- gets apAnns
ss <- getSrcSpan
+#if __GLASGOW_HASKELL__ <= 710
return $ GHC.getAnnotation ga ss an
+#else
+ let unicodeAnns = case unicodeEquivalent an of
+ [] -> []
+ [kw] -> GHC.getAnnotation ga ss kw
+ return $ unicodeAnns ++ GHC.getAnnotation ga ss an
+#endif
-getAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]
+getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAnnotationDelta an = do
ss <- getSrcSpan
getAndRemoveAnnotationDelta ss an
-getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta [GHC.SrcSpan]
+getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAndRemoveAnnotationDelta sp an = do
ga <- gets apAnns
+#if __GLASGOW_HASKELL__ <= 710
let (r,ga') = GHC.getAndRemoveAnnotation ga sp an
- r <$ modify (\s -> s { apAnns = ga' })
+ kw = an
+#else
+ let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga sp an of
+ ([],_) -> (ss,g,k)
+ where
+ k = GHC.unicodeAnn an
+ (ss,g) = GHC.getAndRemoveAnnotation ga sp k
+ (ss,g) -> (ss,g,an)
+#endif
+ modify (\s -> s { apAnns = ga' })
+ return (r,kw)
-getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]
+getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getOneAnnotationDelta an = do
ss <- getSrcSpan
getAndRemoveOneAnnotationDelta ss an
-getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta [GHC.SrcSpan]
+getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAndRemoveOneAnnotationDelta sp an = do
(anns,cs) <- gets apAnns
- let (r,ga') = case Map.lookup (sp,an) anns of
- Nothing -> ([],(anns,cs))
- Just [] -> ([], (Map.delete (sp,an) anns,cs))
- Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs))
+#if __GLASGOW_HASKELL__ <= 710
+ let (r,ga',kw) = case Map.lookup (sp,an) anns of
+ Nothing -> ([],(anns,cs),an)
+ Just [] -> ([], (Map.delete (sp,an) anns,cs),an)
+ Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an)
+#else
+ let getKw kw =
+ case Map.lookup (sp,kw) anns of
+ Nothing -> ([],(anns,cs),kw)
+ Just [] -> ([], (Map.delete (sp,kw) anns,cs),kw)
+ Just (s:ss) -> ([s],(Map.insert (sp,kw) ss anns,cs),kw)
+
+ let (r,ga',kw) =
+ case getKw an of
+ ([],_,_) -> getKw (GHC.unicodeAnn an)
+ v -> v
+#endif
modify (\s -> s { apAnns = ga' })
- return r
+ return (r,kw)
-- ---------------------------------------------------------------------
@@ -498,13 +539,18 @@
_ -> do
p' <- adjustDeltaForOffsetM p
commentAllocation (priorComment (ss2pos pa)) (mapM_ (uncurry addDeltaComment))
+#if __GLASGOW_HASKELL__ <= 710
addAnnDeltaPos (checkUnicode ann pa) p'
+#else
+ addAnnDeltaPos ann p'
+#endif
setPriorEndAST pa
`debug` ("addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" ++ show (showGhc ss,showGhc ss,pe,showGhc pa,p,p',ann))
+#if __GLASGOW_HASKELL__ <= 710
checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId
checkUnicode gkw@(G kw) ss =
- if kw `elem` unicodeSyntax
+ if kw `Set.member` unicodeSyntax
then
let s = keywordToString gkw in
if (length s /= spanLength ss)
@@ -513,7 +559,7 @@
else
gkw
where
- unicodeSyntax =
+ unicodeSyntax = Set.fromList
[ GHC.AnnDcolon
, GHC.AnnDarrow
, GHC.AnnForall
@@ -524,7 +570,27 @@
, GHC.AnnLarrowtail
, GHC.AnnRarrowtail]
checkUnicode kwid _ = kwid
+#else
+unicodeEquivalent :: GHC.AnnKeywordId -> [GHC.AnnKeywordId]
+unicodeEquivalent kw =
+ case Map.lookup kw unicodeSyntax of
+ Nothing -> []
+ Just kwu -> [kwu]
+ where
+ unicodeSyntax = Map.fromList
+ [ (GHC.AnnDcolon, GHC.AnnDcolonU)
+ , (GHC.AnnDarrow, GHC.AnnDarrowU)
+ , (GHC.AnnForall, GHC.AnnForallU)
+ , (GHC.AnnRarrow, GHC.AnnRarrowU)
+ , (GHC.AnnLarrow, GHC.AnnLarrowU)
+ , (GHC.Annlarrowtail, GHC.AnnlarrowtailU)
+ , (GHC.Annrarrowtail, GHC.AnnrarrowtailU)
+ , (GHC.AnnLarrowtail, GHC.AnnLarrowtailU)
+ , (GHC.AnnRarrowtail, GHC.AnnRarrowtailU)]
+#endif
+
+
-- ---------------------------------------------------------------------
commentAllocation :: (Comment -> Bool)
@@ -555,10 +621,9 @@
-- | Look up and add a Delta annotation at the current position, and
-- advance the position to the end of the annotation
addDeltaAnnotation :: GHC.AnnKeywordId -> Delta ()
-addDeltaAnnotation ann = do
+addDeltaAnnotation ann' = do
ss <- getSrcSpan
- -- ma <- getAnnotationDelta ann
- ma <- getOneAnnotationDelta ann
+ (ma,ann) <- getOneAnnotationDelta ann'
case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier
[] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann))
[pa] -> addAnnotationWorker (G ann) pa
@@ -580,8 +645,8 @@
-- position, and advance the position to the end of the annotations
addDeltaAnnotations :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotations ann = do
- ma <- getAnnotationDelta ann
- let do_one ap' = addAnnotationWorker (G ann) ap'
+ (ma,kw) <- getAnnotationDelta ann
+ let do_one ap' = addAnnotationWorker (G kw) ap'
`debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))
mapM_ do_one (sort ma)
@@ -600,11 +665,17 @@
-- | Look up and add possibly multiple Delta annotations not enclosed by
-- the current SrcSpan at the current position, and advance the
-- position to the end of the annotations
+-- The first argument (gann) is the one to look up in the GHC annotations, the
+-- second is the one to apply in the ghc-exactprint ones. These are different
+-- for GHC.AnnSemi mapping to AnnSemiSep, to ensure that it reflects the ';'
+-- outside the current span.
addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta ()
addDeltaAnnotationsOutside gann ann = do
ss <- getSrcSpan
- ma <- getAndRemoveAnnotationDelta ss gann
- let do_one ap' = addAnnotationWorker ann ap'
+ (ma,kw) <- getAndRemoveAnnotationDelta ss gann
+ let do_one ap' = if ann == AnnSemiSep
+ then addAnnotationWorker ann ap'
+ else addAnnotationWorker (G kw) ap'
mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma)
-- | Add a Delta annotation at the current position, and advance the
@@ -615,7 +686,7 @@
addEofAnnotation :: Delta ()
addEofAnnotation = do
pe <- getPriorEnd
- ma <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)
+ (ma,_kw) <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)
case ma of
[] -> return ()
(pa:pss) -> do
diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
@@ -1,12 +1,17 @@
+{-# LANGUAGE CPP #-}
module Language.Haskell.GHC.ExactPrint.Lookup
(
keywordToString
+#if __GLASGOW_HASKELL__ <= 710
, unicodeString
+#endif
) where
import Language.Haskell.GHC.ExactPrint.Types
import qualified GHC (AnnKeywordId(..))
+#if __GLASGOW_HASKELL__ <= 710
import Data.Maybe
+#endif
-- | Maps `AnnKeywordId` to the corresponding String representation.
-- There is no specific mapping for the following constructors.
@@ -21,7 +26,9 @@
-- warnings if new constructors are added.
AnnComment _ -> mkErr kw
AnnString _ -> mkErr kw
+#if __GLASGOW_HASKELL__ <= 710
AnnUnicode kw' -> keywordToString (G kw')
+#endif
AnnSemiSep -> ";"
(G GHC.AnnOpen ) -> mkErr kw
(G GHC.AnnClose ) -> mkErr kw
@@ -74,6 +81,9 @@
(G GHC.AnnNewtype ) -> "newtype"
(G GHC.AnnOf ) -> "of"
(G GHC.AnnOpenC ) -> "{"
+#if __GLASGOW_HASKELL__ > 710
+ (G GHC.AnnOpenE ) -> "[e|"
+#endif
(G GHC.AnnOpenP ) -> "("
(G GHC.AnnOpenPE ) -> "$("
(G GHC.AnnOpenPTE ) -> "$$("
@@ -104,7 +114,19 @@
(G GHC.AnnThIdSplice ) -> "$"
(G GHC.AnnThIdTySplice ) -> "$$"
(G GHC.AnnEofPos ) -> ""
+#if __GLASGOW_HASKELL__ > 710
+ (G GHC.AnnDarrowU) -> "⇒"
+ (G GHC.AnnDcolonU) -> "∷"
+ (G GHC.AnnForallU) -> "∀"
+ (G GHC.AnnLarrowU) -> "←"
+ (G GHC.AnnLarrowtailU) -> "⤛"
+ (G GHC.AnnRarrowU) -> "→"
+ (G GHC.AnnRarrowtailU) -> "⤜"
+ (G GHC.AnnlarrowtailU) -> "⤙"
+ (G GHC.AnnrarrowtailU) -> "⤚"
+#endif
+#if __GLASGOW_HASKELL__ <= 710
-- | Tries to find a unicode equivalent to a 'KeywordId'.
-- If none exists then fall back to find the ASCII version.
unicodeString :: KeywordId -> String
@@ -113,15 +135,17 @@
unicodeChars :: [(KeywordId, String)]
unicodeChars =
- [ (G GHC.AnnDcolon, "∷")
- , (G GHC.AnnDarrow, "⇒")
+ -- AZ:TODO:make this a Data.Map, doing linear scan each time
+ [ (G GHC.AnnDarrow, "⇒")
+ , (G GHC.AnnDcolon, "∷")
, (G GHC.AnnForall, "∀")
- , (G GHC.AnnRarrow, "→")
, (G GHC.AnnLarrow, "←")
- , (G GHC.Annlarrowtail, "⤙")
- , (G GHC.Annrarrowtail, "⤚")
, (G GHC.AnnLarrowtail, "⤛")
- , (G GHC.AnnRarrowtail, "⤜")]
+ , (G GHC.AnnRarrow, "→")
+ , (G GHC.AnnRarrowtail, "⤜")
+ , (G GHC.Annlarrowtail, "⤙")
+ , (G GHC.Annrarrowtail, "⤚")]
+
{-
From Lexer.x
@@ -139,3 +163,5 @@
,("★", ITstar, unicodeSyntaxEnabled)
-}
+
+#endif
diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
@@ -17,6 +17,7 @@
-- * Module Parsers
, parseModule
+ , parseModuleFromString
, parseModuleWithOptions
, parseModuleWithCpp
@@ -58,6 +59,8 @@
#if __GLASGOW_HASKELL__ <= 710
import qualified OrdList as OL
+#else
+import qualified GHC.LanguageExtensions as LangExt
#endif
import qualified Data.Map as Map
@@ -153,6 +156,21 @@
(Anns, GHC.ParsedSource))
parseModule = parseModuleWithCpp defaultCppOptions normalLayout
+-- | This entry point will work out which language extensions are
+-- required but will _not_ perform CPP processing.
+-- In contrast to `parseModoule` the input source is read from the provided
+-- string; the `FilePath` parameter solely exists to provide a name
+-- in source location annotations.
+parseModuleFromString :: FilePath
+ -> String
+ -> IO (Either (GHC.SrcSpan, String)
+ (Anns, GHC.ParsedSource))
+parseModuleFromString fp s = do
+ GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $
+ GHC.runGhc (Just libdir) $ do
+ dflags <- initDynFlagsPure fp s
+ return $ parseWith dflags fp GHC.parseModule s
+
parseModuleWithOptions :: DeltaOptions
-> FilePath
-> IO (Either (GHC.SrcSpan, String)
@@ -184,7 +202,11 @@
GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $
GHC.runGhc (Just libdir) $ do
dflags <- initDynFlags file
+#if __GLASGOW_HASKELL__ <= 710
let useCpp = GHC.xopt GHC.Opt_Cpp dflags
+#else
+ let useCpp = GHC.xopt LangExt.Cpp dflags
+#endif
(fileContents, injectedComments, dflags') <-
if useCpp
then do
@@ -192,7 +214,7 @@
cppComments <- getCppTokensAsComments cppOptions file
return (contents,cppComments,dflags1)
else do
- txt <- GHC.liftIO $ readFile file
+ txt <- GHC.liftIO $ readFileGhc file
let (contents1,lp) = stripLinePragmas txt
return (contents1,lp,dflags)
return $
@@ -209,6 +231,27 @@
src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file
(dflags1, _, _)
<- GHC.parseDynamicFilePragma dflags0 src_opts
+ -- Turn this on last to avoid T10942
+ let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
+ void $ GHC.setSessionDynFlags dflags2
+ return dflags2
+
+-- | Requires GhcMonad constraint because there is
+-- no pure variant of `parseDynamicFilePragma`. Yet, in constrast to
+-- `initDynFlags`, it does not (try to) read the file at filepath, but
+-- solely depends on the module source in the input string.
+initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags
+initDynFlagsPure fp s = do
+ -- I was told we could get away with using the unsafeGlobalDynFlags.
+ -- as long as `parseDynamicFilePragma` is impure there seems to be
+ -- no reason to use it.
+ dflags0 <- GHC.getSessionDynFlags
+ let pragmaInfo = GHC.getOptions
+ dflags0
+ (GHC.stringToStringBuffer $ s)
+ fp
+ (dflags1, _, _)
+ <- GHC.parseDynamicFilePragma dflags0 pragmaInfo
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
void $ GHC.setSessionDynFlags dflags2
diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
-- | This module provides support for CPP, interpreter directives and line
-- pragmas.
module Language.Haskell.GHC.ExactPrint.Preprocess
@@ -6,12 +7,14 @@
stripLinePragmas
, getCppTokensAsComments
, getPreprocessedSrcDirect
+ , readFileGhc
, CppOptions(..)
, defaultCppOptions
) where
import qualified Bag as GHC
+import qualified DriverPhases as GHC
import qualified DriverPipeline as GHC
import qualified DynFlags as GHC
import qualified ErrUtils as GHC
@@ -21,7 +24,6 @@
import qualified Lexer as GHC
import qualified MonadUtils as GHC
import qualified SrcLoc as GHC
-import qualified DriverPhases as GHC
import qualified StringBuffer as GHC
import SrcLoc (mkSrcSpan, mkSrcLoc)
@@ -35,6 +37,7 @@
import Language.Haskell.GHC.ExactPrint.Utils
import qualified Data.Set as Set
+
-- import Debug.Trace
--
data CppOptions = CppOptions
@@ -187,12 +190,12 @@
-> m (String, GHC.StringBuffer, GHC.DynFlags)
getPreprocessedSrcDirectPrim cppOptions src_fn = do
hsc_env <- GHC.getSession
- let dfs = GHC.extractDynFlags hsc_env
- new_env = GHC.replaceDynFlags hsc_env (injectCppOptions cppOptions dfs)
+ let dfs = GHC.hsc_dflags hsc_env
+ new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }
(dflags', hspp_fn) <-
GHC.liftIO $ GHC.preprocess new_env (src_fn, Just (GHC.Cpp GHC.HsSrcFile))
buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn
- txt <- GHC.liftIO $ readFile hspp_fn
+ txt <- GHC.liftIO $ readFileGhc hspp_fn
return (txt, buf, dflags')
injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
@@ -216,7 +219,7 @@
-- source.
getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)]
getPreprocessorAsComments srcFile = do
- fcontents <- readFile srcFile
+ fcontents <- readFileGhc srcFile
let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')
$ zip [1..] (lines fcontents)
@@ -237,6 +240,13 @@
-- ---------------------------------------------------------------------
+readFileGhc :: FilePath -> IO String
+readFileGhc file = do
+ buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file
+ return (GHC.lexemeToString buf len)
+
+-- ---------------------------------------------------------------------
+
-- Copied over from MissingH, the dependency cause travis to fail
{- | Merge two sorted lists using into a single, sorted whole,
@@ -258,6 +268,4 @@
-- Someone please put this code out of its misery.
| (x `cmp` y) <= EQ = x : mergeBy cmp xs ally
| otherwise = y : mergeBy cmp allx ys
-
-
diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Print.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs
@@ -1,8 +1,9 @@
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
@@ -28,16 +29,15 @@
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Annotate
(AnnotationF(..), Annotated, Annotate(..), annotate)
-import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString, unicodeString)
+import Language.Haskell.GHC.ExactPrint.Lookup
+import Control.Monad.Identity
import Control.Monad.RWS
+import Control.Monad.Trans.Free
import Data.Data (Data)
import Data.List (sortBy, elemIndex)
-import Data.Ord (comparing)
import Data.Maybe (fromMaybe)
-
-import Control.Monad.Trans.Free
-import Control.Monad.Identity
+import Data.Ord (comparing)
import qualified GHC
@@ -142,25 +142,24 @@
printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a
printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m)
where
- go :: (Monad m, Monoid w) => AnnotationF (EP w m a) -> EP w m a
+ go :: AnnotationF (EP w m a) -> EP w m a
go (MarkEOF next) =
- printStringAtMaybeAnn (G GHC.AnnEofPos) "" >> next
+ printStringAtMaybeAnn (G GHC.AnnEofPos) (Just "") >> next
go (MarkPrim kwid mstr next) =
markPrim (G kwid) mstr >> next
-- let annString = fromMaybe (keywordToString kwid) mstr in
-- printStringAtMaybeAnn (G kwid) annString >> next
go (MarkOutside _ kwid next) =
-- markPrim kwid Nothing >> next
- let annString = keywordToString kwid in
- printStringAtMaybeAnnAll kwid annString >> next
+ -- let annString = keywordToString kwid in
+ printStringAtMaybeAnnAll kwid Nothing >> next
-- printStringAtMaybeAnnAll kwid ";" >> next
go (MarkInside akwid next) =
allAnns akwid >> next
go (MarkMany akwid next) =
allAnns akwid >> next
go (MarkOffsetPrim kwid _ mstr next) =
- let annString = fromMaybe (keywordToString (G kwid)) mstr in
- printStringAtMaybeAnn (G kwid) annString >> next
+ printStringAtMaybeAnn (G kwid) mstr >> next
go (WithAST lss action next) =
exactPC lss (printInterpret action) >> next
go (CountAnns kwid next) =
@@ -170,11 +169,13 @@
(if (r <= rigidity) then setLayout else id) (printInterpret action)
next
go (MarkExternal _ akwid s next) =
- printStringAtMaybeAnn (G akwid) s >> next
+ printStringAtMaybeAnn (G akwid) (Just s) >> next
go (StoreOriginalSrcSpan _ next) = storeOriginalSrcSpanPrint >>= next
go (GetSrcSpanForKw _ next) = return GHC.noSrcSpan >>= next
+#if __GLASGOW_HASKELL__ <= 710
go (StoreString _ _ next) =
printStoredString >> next
+#endif
go (AnnotationsToComments _ next) = next
go (WithSortKey ks next) = withSortKey ks >> next
@@ -187,6 +188,7 @@
Nothing -> error "Missing captured SrcSpan"
Just v -> return v
+#if __GLASGOW_HASKELL__ <= 710
printStoredString :: (Monad m, Monoid w) => EP w m ()
printStoredString = do
kd <- gets epAnnKds
@@ -196,8 +198,9 @@
isAnnString _ = False
case filter isAnnString (ghead "printStoredString" kd) of
- ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) ss
+ ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) (Just ss)
_ -> return ()
+#endif
withSortKey :: (Monad m, Monoid w) => [(GHC.SrcSpan, Annotated ())] -> EP w m ()
withSortKey xs = do
@@ -215,7 +218,7 @@
-------------------------------------------------------------------------
allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m ()
-allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString (G kwid))
+allAnns kwid = printStringAtMaybeAnnAll (G kwid) Nothing
-------------------------------------------------------------------------
-- |First move to the given location, then call exactP
@@ -240,7 +243,7 @@
censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a
censorM f m = passM (liftM (\x -> (x,f)) m)
-passM :: (Monoid w, Monad m) => EP w m (a, w -> m w) -> EP w m a
+passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a
passM m = RWST $ \r s -> do
~((a, f),s', EPWriter w) <- runRWST m r s
w' <- f w
@@ -257,8 +260,9 @@
markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()
markPrim kwid mstr =
- let annString = fromMaybe (keywordToString kwid) mstr
- in printStringAtMaybeAnn kwid annString
+ -- let annString = fromMaybe (keywordToString kwid) mstr
+ -- in printStringAtMaybeAnn kwid annString
+ printStringAtMaybeAnn kwid mstr
withContext :: (Monad m, Monoid w)
=> [(KeywordId, DeltaPos)]
@@ -308,18 +312,20 @@
-- ---------------------------------------------------------------------
-printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> String -> EP w m ()
-printStringAtMaybeAnn an str = printStringAtMaybeAnnThen an str (return ())
+printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()
+printStringAtMaybeAnn an mstr = printStringAtMaybeAnnThen an mstr (return ())
-printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> String -> EP w m ()
-printStringAtMaybeAnnAll an str = go
+printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()
+printStringAtMaybeAnnAll an mstr = go
where
- go = printStringAtMaybeAnnThen an str go
+ go = printStringAtMaybeAnnThen an mstr go
-printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> String -> EP w m () -> EP w m ()
-printStringAtMaybeAnnThen an str next = do
+printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -> EP w m ()
+printStringAtMaybeAnnThen an mstr next = do
+ let str = fromMaybe (keywordToString an) mstr
annFinal <- getAnnFinal an
case (annFinal, an) of
+#if __GLASGOW_HASKELL__ <= 710
-- Could be unicode syntax
-- TODO: This is a bit fishy, refactor
(Nothing, G kw) -> do
@@ -330,6 +336,20 @@
res
(\(comments, ma) -> printStringAtLsDelta comments ma (unicodeString (G kw)))
next
+#else
+ -- Could be unicode syntax
+ -- TODO: This is a bit fishy, refactor
+ (Nothing, G kw') -> do
+ let kw = GHC.unicodeAnn kw'
+ let str' = fromMaybe (keywordToString (G kw)) mstr
+ res <- getAnnFinal (G kw)
+ return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res))
+ unless (null res) $ do
+ forM_
+ res
+ (\(comments, ma) -> printStringAtLsDelta comments ma str')
+ next
+#endif
(Just (comments, ma),_) -> printStringAtLsDelta comments ma str >> next
(Nothing, _) -> return () `debug` ("printStringAtMaybeAnn:missed:(an)" ++ show an)
-- Note: do not call next, nothing to chain
@@ -393,7 +413,11 @@
when (isGoodDelta (DP (dr,max 0 dc)))
(do
printCommentAt (undelta p dp colOffset) commentContents
- setPos (undelta p (dp `addDP` dpFromString commentContents) colOffset))
+ let commentDP@(DP (cr,_cc)) = dpFromString commentContents
+ if cr == 0
+ then setPos (undelta p (dp `addDP` commentDP) colOffset)
+ else setPos (undelta p (dp `addDP` commentDP) 1)
+ )
-- ---------------------------------------------------------------------
@@ -424,7 +448,7 @@
if not layout && c == 0
then lift (epWhitespacePrint str) >>= \s -> tell (EPWriter { output = s})
- else lift (epTokenPrint str) >>= \s -> tell (EPWriter { output = s})
+ else lift (epTokenPrint str) >>= \s -> tell (EPWriter { output = s})
newLine :: (Monad m, Monoid w) => EP w m ()
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -34,6 +34,7 @@
, uniqueSrcSpanT
, cloneT
+ , graftT
, getEntryDPT
, setEntryDPT
@@ -143,7 +144,7 @@
runTransformFrom seed ans f = runRWS (runTransformT f) () (ans,seed)
-- |Run a monad transformer stack for the 'TransformT' monad transformer
-runTransformFromT :: (Monad m) => Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])
+runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])
runTransformFromT seed ans f = runRWST (runTransformT f) () (ans,seed)
-- |Log a string to the output of the Monad
@@ -192,11 +193,11 @@
-- ---------------------------------------------------------------------
-- |Make a copy of an AST element, replacing the existing SrcSpans with new
-- ones, and duplicating the matching annotations.
-cloneT :: (Data a,Typeable a) => a -> Transform (a, [(GHC.SrcSpan, GHC.SrcSpan)])
+cloneT :: (Data a) => a -> Transform (a, [(GHC.SrcSpan, GHC.SrcSpan)])
cloneT ast = do
runWriterT $ SYB.everywhereM (return `SYB.ext2M` replaceLocated) ast
where
- replaceLocated :: forall loc a. (Typeable loc,Typeable a, Data a)
+ replaceLocated :: forall loc a. (Typeable loc,Data a)
=> (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] Transform (GHC.GenLocated loc a)
replaceLocated (GHC.L l t) = do
case cast l :: Maybe GHC.SrcSpan of
@@ -210,7 +211,24 @@
Nothing -> return (GHC.L l t)
-- ---------------------------------------------------------------------
+-- |Slightly more general form of cloneT
+graftT :: (Data a) => Anns -> a -> Transform a
+graftT origAnns = SYB.everywhereM (return `SYB.ext2M` replaceLocated)
+ where
+ replaceLocated :: forall loc a. (Typeable loc, Data a)
+ => GHC.GenLocated loc a -> Transform (GHC.GenLocated loc a)
+ replaceLocated (GHC.L l t) = do
+ case cast l :: Maybe GHC.SrcSpan of
+ Just ss -> do
+ newSpan <- uniqueSrcSpanT
+ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) origAnns of
+ Nothing -> anns
+ Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns)
+ return $ fromJust $ cast $ GHC.L newSpan t
+ Nothing -> return (GHC.L l t)
+-- ---------------------------------------------------------------------
+
-- |If a list has been re-ordered or had items added, capture the new order in
-- the appropriate 'annSortKey' attached to the 'Annotation' for the first
-- parameter.
@@ -475,7 +493,11 @@
-- '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) => GHC.LHsBind GHC.RdrName -> GHC.Located b -> Transform ()
+#if __GLASGOW_HASKELL__ <= 710
balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do
+#else
+balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do
+#endif
-- logTr $ "balanceCommentsFB entered"
balanceComments' (last matches) second
balanceCommentsFB f s = balanceComments' f s
@@ -536,7 +558,7 @@
-- |Insert a declaration into an AST element having sub-declarations
-- (@HasDecls@) according to the given location function.
-insertAt :: (Data ast, HasDecls (GHC.Located ast))
+insertAt :: (HasDecls (GHC.Located ast))
=> (GHC.LHsDecl GHC.RdrName
-> [GHC.LHsDecl GHC.RdrName]
-> [GHC.LHsDecl GHC.RdrName])
@@ -549,7 +571,7 @@
-- |Insert a declaration at the beginning or end of the subdecls of the given
-- AST item
-insertAtStart, insertAtEnd :: (Data ast, HasDecls (GHC.Located ast))
+insertAtStart, insertAtEnd :: (HasDecls (GHC.Located ast))
=> GHC.Located ast
-> GHC.LHsDecl GHC.RdrName
-> Transform (GHC.Located ast)
@@ -559,7 +581,7 @@
-- |Insert a declaration at a specific location in the subdecls of the given
-- AST item
-insertAfter, insertBefore :: (Data ast, HasDecls (GHC.Located ast))
+insertAfter, insertBefore :: (HasDecls (GHC.Located ast))
=> GHC.Located old
-> GHC.Located ast
-> GHC.LHsDecl GHC.RdrName
@@ -624,7 +646,11 @@
-- ---------------------------------------------------------------------
instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
+#if __GLASGOW_HASKELL__ <= 710
hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do
+#else
+ hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do
+#endif
decls <- hsDeclsValBinds lb
orderedDecls d decls
@@ -644,7 +670,12 @@
}
modifyAnnsT removeWhere
+#if __GLASGOW_HASKELL__ <= 710
binds' <- replaceDeclsValbinds binds []
+#else
+ binds'' <- replaceDeclsValbinds (GHC.unLoc binds) []
+ let binds' = GHC.L (GHC.getLoc binds) binds''
+#endif
return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds
@@ -652,7 +683,11 @@
logTr "replaceDecls LMatch"
-- Need to throw in a fresh where clause if the binds were empty,
-- in the annotations.
+#if __GLASGOW_HASKELL__ <= 710
case binds of
+#else
+ case GHC.unLoc binds of
+#endif
GHC.EmptyLocalBinds -> do
let
addWhere mkds =
@@ -671,14 +706,23 @@
_ -> return ()
modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds)
+#if __GLASGOW_HASKELL__ <= 710
binds' <- replaceDeclsValbinds binds newBinds
+#else
+ binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newBinds
+ let binds' = GHC.L (GHC.getLoc binds) binds''
+#endif
-- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'
return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
-- ---------------------------------------------------------------------
instance HasDecls (GHC.LHsExpr GHC.RdrName) where
+#if __GLASGOW_HASKELL__ <= 710
hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do
+#else
+ hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do
+#endif
ds <- hsDeclsValBinds decls
orderedDecls ls ds
hsDecls _ = return []
@@ -687,7 +731,12 @@
= do
logTr "replaceDecls HsLet"
modifyAnnsT (captureOrder e newDecls)
+#if __GLASGOW_HASKELL__ <= 710
decls' <- replaceDeclsValbinds decls newDecls
+#else
+ decls'' <- replaceDeclsValbinds (GHC.unLoc decls) newDecls
+ let decls' = GHC.L (GHC.getLoc decls) decls''
+#endif
return (GHC.L l (GHC.HsLet decls' ex))
replaceDecls (GHC.L l (GHC.HsPar e)) newDecls
= do
@@ -711,7 +760,11 @@
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
-- idempotent.
hsDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]
+#if __GLASGOW_HASKELL__ <= 710
hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do
+#else
+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do
+#endif
decls <- hsDeclsValBinds lb
orderedDecls d decls
hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
@@ -740,7 +793,11 @@
logTr "replaceDecls PatBind"
-- Need to throw in a fresh where clause if the binds were empty,
-- in the annotations.
+#if __GLASGOW_HASKELL__ <= 710
case binds of
+#else
+ case GHC.unLoc binds of
+#endif
GHC.EmptyLocalBinds -> do
let
addWhere mkds =
@@ -756,34 +813,71 @@
_ -> return ()
modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)
+#if __GLASGOW_HASKELL__ <= 710
binds' <- replaceDeclsValbinds binds newDecls
+#else
+ binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls
+ let binds' = GHC.L (GHC.getLoc binds) binds''
+#endif
return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d))
replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
-- ---------------------------------------------------------------------
instance HasDecls (GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
+#if __GLASGOW_HASKELL__ <= 710
hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do
+#else
+ hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do
+#endif
decls <- hsDeclsValBinds lb
orderedDecls ls decls
+#if __GLASGOW_HASKELL__ <= 710
hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e
+#else
+ 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.BindStmt _pat e _ _ _)) = hsDecls e
+#endif
hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsDecls e
hsDecls _ = return []
replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls
= do
modifyAnnsT (captureOrder s newDecls)
+#if __GLASGOW_HASKELL__ <= 710
lb' <- replaceDeclsValbinds lb newDecls
+#else
+ 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
= do
e' <- replaceDecls e newDecls
return (GHC.L l (GHC.LastStmt e' se))
+#else
+ replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.LastStmt e' d se))
+#endif
+#if __GLASGOW_HASKELL__ <= 710
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))
+#else
+ 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))
+#endif
+
replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls
= do
e' <- replaceDecls e newDecls
@@ -800,7 +894,7 @@
-- the general case and one specific for a 'GHC.LHsBind'. This is required
-- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot
-- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.
-hasDeclsSybTransform :: (SYB.Data t2, SYB.Typeable t2,Monad m)
+hasDeclsSybTransform :: (SYB.Data t2, Monad m)
=> (forall t. HasDecls t => t -> m t)
-- ^Worker function for the general case
-> (GHC.LHsBind GHC.RdrName -> m (GHC.LHsBind GHC.RdrName))
@@ -844,7 +938,7 @@
-- return anything for these as there is not meaningful 'replaceDecls' for it.
-- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind'
-- decls too, where they are needed for analysis only.
-hsDeclsGeneric :: (SYB.Data t,SYB.Typeable t) => t -> Transform [GHC.LHsDecl GHC.RdrName]
+hsDeclsGeneric :: (SYB.Data t) => t -> Transform [GHC.LHsDecl GHC.RdrName]
hsDeclsGeneric t = q t
where
q = return []
@@ -854,6 +948,7 @@
`SYB.extQ` lstmt
`SYB.extQ` lhsbind
`SYB.extQ` lhsbindd
+ `SYB.extQ` llocalbinds
`SYB.extQ` localbinds
parsedSource (p::GHC.ParsedSource) = hsDecls p
@@ -867,7 +962,11 @@
-- ---------------------------------
lhsbind :: GHC.LHsBind GHC.RdrName -> Transform [GHC.LHsDecl GHC.RdrName]
+#if __GLASGOW_HASKELL__ <= 710
lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do
+#else
+ lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do
+#endif
dss <- mapM hsDecls matches
return (concat dss)
lhsbind p@(GHC.L _ (GHC.PatBind{})) = do
@@ -878,6 +977,11 @@
lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d)
lhsbindd _ = return []
+
+ -- ---------------------------------
+
+ llocalbinds :: GHC.Located (GHC.HsLocalBinds GHC.RdrName) -> Transform [GHC.LHsDecl GHC.RdrName]
+ llocalbinds (GHC.L _ ds) = localbinds ds
-- ---------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -171,7 +171,9 @@
-- Delta to Print when we have to work
-- out details from the original
-- SrcSpan.
+#if __GLASGOW_HASKELL__ <= 710
| AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible.
+#endif
deriving (Eq,Ord)
instance Show KeywordId where
@@ -179,7 +181,9 @@
show AnnSemiSep = "AnnSemiSep"
show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"
show (AnnString s) = "(AnnString " ++ s ++ ")"
+#if __GLASGOW_HASKELL__ <= 710
show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")"
+#endif
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -55,6 +55,7 @@
import Control.Monad.State
+import qualified Data.ByteString as B
import Data.Data (Data, toConstr, showConstr, cast)
import Data.Generics (extQ, ext1Q, ext2Q, gmapQ)
import Data.List (intercalate, sortBy, elemIndex)
@@ -147,7 +148,7 @@
addDP :: DeltaPos -> DeltaPos -> DeltaPos
addDP (DP (a, b)) (DP (c, d)) =
if c >= 1 then DP (a+c, d)
- else DP (a, b + d)
+ else DP (a, b+d)
-- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the
-- remaining delta for the second after the first has been applied.
@@ -297,8 +298,8 @@
dpFromString xs = dpFromString' xs 0 0
where
dpFromString' "" line col = DP (line, col)
- dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0
- dpFromString' (_:cs) line col = dpFromString' cs line (col + 1)
+ dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0
+ dpFromString' (_:cs) line col = dpFromString' cs line (col + 1)
-- ---------------------------------------------------------------------
@@ -328,6 +329,7 @@
generic -- `ext1Q` located
`ext1Q` list
`extQ` string `extQ` fastString `extQ` srcSpan
+ `extQ` bytestring
`extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
`extQ` overLit
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
@@ -341,10 +343,11 @@
indent i = "\n" ++ replicate i ' '
string = show :: String -> String
fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String
+ bytestring = show :: B.ByteString -> String
list l = indent n ++ "["
++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]"
- name = ("{Name: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Name -> String
+ name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String
occName = ("{OccName: "++) . (++"}") . OccName.occNameString
moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String
@@ -356,7 +359,7 @@
)
++"}"
- var = ("{Var: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Var -> String
+ var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String
dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String
overLit :: GHC.HsOverLit GHC.RdrName -> String
@@ -404,6 +407,12 @@
showSDoc_ :: GHC.SDoc -> String
showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
+showSDocDebug_ :: GHC.SDoc -> String
+#if __GLASGOW_HASKELL__ <= 710
+showSDocDebug_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
+#else
+showSDocDebug_ = GHC.showSDocDebug GHC.unsafeGlobalDynFlags
+#endif
-- ---------------------------------------------------------------------
-- Putting these here for the time being, to avoid import loops
diff --git a/tests/PrepareHackage.hs b/tests/PrepareHackage.hs
new file mode 100644
--- /dev/null
+++ b/tests/PrepareHackage.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE OverloadedStrings #-} --
+
+import Data.Char
+import Data.Monoid
+import System.Directory
+import System.FilePath.Posix
+import System.IO
+import Test.CommonUtils
+import Turtle hiding (FilePath,(<.>))
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+import qualified GHC.IO.Handle.Text as GHC
+
+import Test.HUnit
+
+main :: IO ()
+main = do
+ packages <- allCabalPackages
+ -- packages <- allCabalPackagesTest
+ echo (T.pack $ "number of packages:" ++ (show $ length packages))
+ packageDirsFull <- drop 2 <$> getDirectoryContents hackageWorkDir
+ let cond c = c == '.' || c == '-' || isDigit c
+ let packageDirs = map (T.dropWhileEnd cond . T.pack) packageDirsFull
+ isBadPackages <- doesFileExist badpackagesFile
+ badPackages <- if isBadPackages
+ then T.lines <$> T.readFile badpackagesFile
+ else return []
+ let alreadyUnpacked = Set.fromList $ packageDirs ++ badPackages
+ _ <- shell ("mkdir -p " <> (T.pack hackageWorkDir)) empty
+ mapM_ (preparePackage alreadyUnpacked) packages
+
+-- ---------------------------------------------------------------------
+
+preparePackage :: Set.Set Text -> Text -> IO ()
+preparePackage alreadyUnpacked package = do
+ echo $ "preparePackage:" <> package
+ if Set.member package alreadyUnpacked
+ then echo $ "already unpacked:" <> package
+ else preparePackage' package
+
+preparePackage' :: Text -> IO ()
+preparePackage' package = do
+ (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty
+ -- echo (T.pack $ "cabal get:" ++ show dir)
+ echo (T.pack $ show ec)
+ when (ec == ExitSuccess) $ do
+ let bits = T.splitOn " " (head $ T.lines dir)
+ echo (T.pack $ "cabal get:dir=" ++ show (last bits))
+ cleanPackage (last bits)
+ return ()
+
+-- ---------------------------------------------------------------------
+
+-- |Clean up whitespace in a package
+
+cleanPackage :: Text -> IO ()
+cleanPackage dir = do
+ echo ("cleaning:" <> dir)
+ fs <- findSrcFiles (T.unpack dir)
+ let
+ doOne :: FilePath -> IO ()
+ doOne fn = do
+ echo ("doOne:" <> T.pack fn)
+ let tmpFn = fn <.> "clean"
+ clean <- cleanupWhiteSpace fn
+ writeFile tmpFn clean
+ -- writeFileUtf8 tmpFn clean
+ -- T.writeFile tmpFn (T.pack clean) -- convert to Text to deal with encoding issues of is8859 euro symbol
+ removeFile fn
+ renameFile tmpFn fn
+ return ()
+ mapM_ doOne fs
+ echo ("cleaned up:" <> dir)
+
+-- ---------------------------------------------------------------------
+-- | The computation 'writeFile' @file str@ function writes the string @str@,
+-- to the file @file@.
+writeFileUtf8 :: FilePath -> String -> IO ()
+-- writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> hPutStr hdl txt)
+writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt)
+
+-- ---------------------------------------------------------------------
+
+allCabalPackagesTest :: IO [Text]
+allCabalPackagesTest
+ = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"]
+ -- = return ["airship"]
+
+
+allCabalPackages :: IO [Text]
+allCabalPackages = do
+ -- let cmd = "cabal list --simple-output | awk '{ print $1 }' | uniq"
+ let cmd = "cabal list --simple-output | awk '{ print $1 }' | sort | uniq"
+ (_ec,r) <- shellStrict cmd empty
+ let packages = T.lines r
+ echo (T.pack $ show $ take 5 packages)
+ return packages
+
+-- ---------------------------------------------------------------------
+
+-- |strip trailing whitespace, and turn tabs into spaces
+cleanupWhiteSpace :: FilePath -> IO String
+cleanupWhiteSpace file = do
+ contents <- readFileGhc file
+ let cleaned = map cleanupOneLine (lines $ contents)
+ return (unlines cleaned)
+{-
+cleanupWhiteSpace :: FilePath -> IO T.Text
+cleanupWhiteSpace file = do
+ contents <- readFileGhc file
+ let cleaned = map cleanupOneLine (T.lines $ T.pack contents)
+ return (T.unlines cleaned)
+-}
+tabWidth :: Int
+tabWidth = 8
+
+nonBreakingSpace :: Char
+nonBreakingSpace = '\xa0'
+
+cleanupOneLine :: String -> String
+cleanupOneLine str = str'
+ where
+ numSpacesForTab n = tabWidth - (n `mod` tabWidth)
+ -- loop over the line, keeping current pos. Where a tab is found, insert
+ -- spaces until the next tab stop. Discard any trailing whitespace.
+ go col res cur =
+ case cur of
+ [] -> res
+ ('\t':cur') -> go (col + toAdd) ((replicate toAdd ' ') ++ res) cur'
+ where
+ toAdd = numSpacesForTab col
+ ('\xa0':cur') -> go (col + 1) (' ':res) cur'
+
+ -- convert ISO 8859-16 euro symbol to the UTF8 equivalent
+ -- ('\xa4':cur') -> go (col + 1) ('\x20ac':res) cur'
+ (c:cur') ->go (col + 1) (c:res) cur'
+ str1 = go 0 [] str
+ str' = reverse $ dropWhile isSpace str1
+{-
+cleanupOneLine :: T.Text -> T.Text
+cleanupOneLine str = str'
+ where
+ numSpacesForTab n = tabWidth - (n `mod` tabWidth)
+ -- loop over the line, keeping current pos. Where a tab is found, insert
+ -- spaces until the next tab stop. Discard any trailing whitespace.
+ go col res cur =
+ if T.null cur
+ then res
+ else
+ case T.head cur of
+ '\t' -> go (col + toAdd) (res <> T.replicate toAdd " ") (T.tail cur)
+ where
+ toAdd = numSpacesForTab col
+ '\xa0' -> go (col + 1) (T.snoc res ' ') (T.tail cur)
+ -- nonBreakingSpace -> go (col + 1) (T.snoc res ' ') (T.tail cur)
+ c -> go (col + 1) (T.snoc res c) (T.tail cur)
+ str1 = go 0 T.empty str
+ -- str2 = T.map (\c -> if c == nonBreakingSpace then ' ' else c) str1
+ str' = T.dropWhileEnd isSpace str1
+-}
+
+-- ---------------------------------------------------------------------
+
+tt :: IO Counts
+tt = runTestTT $ TestList
+ [ testCleanupOneLine
+ , testTabs
+ ]
+
+testCleanupOneLine :: Test
+testCleanupOneLine = do
+ let
+ makeCase n = (show n
+ ,(replicate n ' ') <> "\t|" <> replicate n ' ' <> "\t"
+ ,(replicate 8 ' ' <> "|"))
+ mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp)
+ where (name,inp,outp) = makeCase n
+ testList "cleanupOneLine" $ map mkTest [1..7]
+
+testTabs :: Test
+testTabs = TestCase $ assertEqual "testTabs" t2tabsExpected (cleanupOneLine t2tabs)
+ where
+ t2tabs = "import Data.Foldable\t\t ( foldMap )"
+ t2tabsExpected ="import Data.Foldable ( foldMap )"
+
+testList :: String -> [Test] -> Test
+testList str ts = TestLabel str (TestList ts)
+
+-- ---------------------------------------------------------------------
+
+pwd :: IO FilePath
+pwd = getCurrentDirectory
+
+mcd :: FilePath -> IO ()
+mcd = setCurrentDirectory
diff --git a/tests/Roundtrip.hs b/tests/Roundtrip.hs
--- a/tests/Roundtrip.hs
+++ b/tests/Roundtrip.hs
@@ -3,68 +3,105 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import System.FilePath
-
-import Data.List hiding (find)
-
-import System.Exit
-
-import System.Directory
-
-import Test.HUnit
-
-import System.FilePath.Find
-
-import Debug.Trace
+import Control.Exception
import Control.Monad
+import Data.Time.Clock
+import Data.Time.Format
+import Debug.Trace
+import System.Directory
import System.Environment
-
-import qualified Data.Set as S
-
-import Test.Common
-
+import System.Exit
+import System.FilePath
+import System.IO
import System.IO.Temp
-import System.IO (hClose, hPutStr)
+import Test.Common
+import Test.CommonUtils
+import Test.HUnit
+import qualified Data.Set as S
+-- ---------------------------------------------------------------------
data Verbosity = Debug | Status | None deriving (Eq, Show, Ord, Enum)
verb :: Verbosity
verb = Debug
-cppFile, parseFailFile, processed :: String
-cppFile = "cpp.txt"
-parseFailFile = "pfail.txt"
-processed = "processed.txt"
+-- ---------------------------------------------------------------------
writeCPP :: FilePath -> IO ()
-writeCPP fp = appendFile cppFile (('\n' : fp))
+writeCPP fp = appendFileFlush cppFile (('\n' : fp))
+writeError = writeCPP
+
writeParseFail :: FilePath -> String -> IO ()
-writeParseFail fp s = appendFile parseFailFile (('\n' : (fp ++ " " ++ s)))
+writeParseFail fp _s = appendFileFlush parseFailFile (('\n' : fp))
+-- writeParseFail fp s = appendFileFlush parseFailFile (('\n' : (fp ++ " " ++ s)))
writeProcessed :: FilePath -> IO ()
-writeProcessed fp = appendFile processed (('\n' : fp))
+writeProcessed fp = appendFileFlush processed (('\n' : fp))
+writeFailed :: FilePath -> IO ()
+writeFailed fp = appendFileFlush processedFailFile (('\n' : fp))
+writeLog :: String -> IO ()
+writeLog msg = appendFileFlush logFile (('\n' : msg))
+getTimeStamp :: IO String
+getTimeStamp = do
+ t <- getCurrentTime
+ return $ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M%S")) t
+
+writeFailure :: FilePath -> String -> IO ()
+writeFailure fp db = do
+ ts <- getTimeStamp
+ let outname = failuresDir takeFileName fp <.> ts <.> "out"
+ writeFile outname db
+
+appendFileFlush :: FilePath -> String -> IO ()
+appendFileFlush f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt >> hFlush hdl)
+
+-- ---------------------------------------------------------------------
+
+readFileIfPresent fileName = do
+ isPresent <- doesFileExist fileName
+ if isPresent
+ then lines <$> readFile fileName
+ else return []
+
+-- ---------------------------------------------------------------------
+
main :: IO ()
main = do
+ createDirectoryIfMissing True workDir
+ createDirectoryIfMissing True configDir
+ createDirectoryIfMissing True failuresDir
as <- getArgs
case as of
[] -> putStrLn "Must enter directory to process"
["failures"] -> do
- fs <- lines <$> readFile "origfailures.txt"
+ fs <- lines <$> readFile origFailuresFile
() <$ runTests (TestList (map mkParserTest fs))
["clean"] -> do
putStrLn "Cleaning..."
- writeFile "processed.txt" ""
- writeFile "pfail.txt" ""
- writeFile "cpp.txt" ""
- removeDirectoryRecursive "tests/roundtrip"
- createDirectory "tests/roundtrip"
+ writeFile processed ""
+ writeFile parseFailFile ""
+ writeFile cppFile ""
+ writeFile logFile ""
+ writeFile processedFailFile ""
+ removeDirectoryRecursive failuresDir
+ createDirectory failuresDir
putStrLn "Done."
- ds -> () <$ (runTests =<< (TestList <$> mapM tests ds))
+ -- ds -> () <$ (runTests =<< (TestList <$> mapM tests ds))
+ ds -> do
+ !blackList <- readFileIfPresent blackListed
+ !knownFailures <- readFileIfPresent knownFailuresFile
+ !processedList <- lines <$> readFile processed
+ !cppList <- lines <$> readFile cppFile
+ !parseFailList <- lines <$> readFile parseFailFile
+ let done = S.fromList (processedList ++ cppList ++ blackList ++ knownFailures ++ parseFailList)
+ tsts <- TestList <$> mapM (tests done) ds
+ runTests tsts
+ return ()
runTests :: Test -> IO Counts
runTests t = do
@@ -73,41 +110,17 @@
putStrLn $ "Verbosity: " ++ show verb
runTestTT t
-tests :: FilePath -> IO Test
-tests dir = do
- done <- S.fromList . lines <$> readFile processed
+tests :: S.Set String -> FilePath -> IO Test
+tests done dir = do
roundTripHackage done dir
-- Selection:
--- Given base directory finds all haskell source files
-findSrcFiles :: FilePath -> IO [FilePath]
-findSrcFiles = find filterDirectory filterFilename
-
-filterDirectory :: FindClause Bool
-filterDirectory =
- p <$> fileName
- where
- p x
- | "." `isPrefixOf` x = False
- | otherwise = True
-
-filterFilename :: FindClause Bool
-filterFilename = do
- ext <- extension
- fname <- fileName
- return (ext == ".hs" && p fname)
- where
- p x
- | "refactored" `isInfixOf` x = False
- | "Setup.hs" `isInfixOf` x = False
- | "HLint.hs" `isInfixOf` x = False -- HLint config files
- | otherwise = True
-
-- Hackage dir
roundTripHackage :: S.Set String -> FilePath -> IO Test
roundTripHackage done hackageDir = do
packageDirs <- drop 2 <$> getDirectoryContents hackageDir
+ when (verb <= Debug) (traceShowM hackageDir)
when (verb <= Debug) (traceShowM packageDirs)
TestList <$> mapM (roundTripPackage done) (zip [0..] (map (hackageDir ) packageDirs))
@@ -122,16 +135,20 @@
mkParserTest :: FilePath -> Test
mkParserTest fp =
- TestCase (do r <- either (\(ParseFailure _ s) -> exitFailure) return
- =<< roundTripTest fp
- writeProcessed fp
- unless (status r == Success) (writeFailure fp (debugTxt r))
- assertBool fp (status r == Success))
+ TestLabel fp $
+ TestCase (do writeLog $ "starting:" ++ fp
+ r1 <- catchAny (roundTripTest fp) $ \e -> do
+ writeError fp
+ throwIO e
+ case r1 of
+ Left (ParseFailure _ s) -> do
+ writeParseFail fp s
+ exitFailure
+ Right r -> do
+ writeProcessed fp
+ unless (status r == Success) (writeFailure fp (debugTxt r) >> writeFailed fp)
+ assertBool fp (status r == Success))
+catchAny :: IO a -> (SomeException -> IO a) -> IO a
+catchAny = Control.Exception.catch
-writeFailure :: FilePath -> String -> IO ()
-writeFailure fp db = do
- let outdir = "tests" "roundtrip"
- outname = takeFileName fp <.> "out"
- (fname, handle) <- openTempFile outdir outname
- (hPutStr handle db >> hClose handle)
diff --git a/tests/Static.hs b/tests/Static.hs
--- a/tests/Static.hs
+++ b/tests/Static.hs
@@ -2,12 +2,13 @@
module Main where
-- Static site generator for failing tests
-import Data.Algorithm.Diff (getDiff)
+import Data.Algorithm.Diff (getGroupedDiff)
import Data.Algorithm.DiffOutput (ppDiff)
import System.Directory
import System.FilePath
+import Test.CommonUtils
import Control.Monad
import Debug.Trace
@@ -19,6 +20,7 @@
main :: IO ()
main = do
+ createDirectoryIfMissing True failuresHtmlDir
n <- getArgs
case readMaybe =<< listToMaybe n of
Nothing -> site 100
@@ -27,12 +29,13 @@
site :: Int -> IO ()
site n = do
putStrLn $ "Generating site for first: " ++ show n
- failPaths <- filterM doesFileExist =<< (map ("tests/roundtrip" ) . take n <$> getDirectoryContents "tests/roundtrip")
+ failPaths <- filterM doesFileExist =<< (map (failuresDir ) . take n <$> getDirectoryContents failuresDir)
traceShowM failPaths
fails <- mapM parseFail failPaths
- writeFile "origfailures.txt" (intercalate "\n" (map getfname fails))
- writeFile "failures/failures.html" (makeIndex failPaths)
- let padded = "failures.html" : (map makeFailLink failPaths ++ ["failures.html"])
+ writeFile origFailuresFile (intercalate "\n" (map getfname fails))
+ -- writeFile "failures/failures.html" (makeIndex failPaths)
+ writeFile (failuresHtmlDir failuresHtmlFile) (makeIndex failPaths)
+ let padded = failuresHtmlFile : (map makeFailLink failPaths ++ [failuresHtmlFile])
let resolved = zipWith (\x (y,z) -> (x, y, z)) padded (zip (tail padded) (tail (tail padded)))
mapM_ (uncurry page) (zip resolved fails)
@@ -51,23 +54,32 @@
page (prev, out, next) (Failure res fname) = do
-- traceM out
original <- readFile fname
- let diff = getDiff (tokenize original) (tokenize res)
- let l = length (lines res)
- if (l > 50000)
- then putStrLn ("Skipping: " ++ fname) >> print l
+ -- let diff = getDiff (tokenize original) (tokenize res)
+ let lres = lines res
+ let maxLines = 50000
+ let diff = getGroupedDiff (lines original) (take maxLines lres)
+ let l = length lres
+ if (l > maxLines)
+ then do -- putStrLn ("Skipping: " ++ fname) >> print l
+ let resTrunc = (intercalate "\n" $ take maxLines lres)
+ ++ "\n*****************TRUNCATED*******"
+ writeFile (failuresHtmlDir out) (mkPage fname (ppDiff diff) prev next original resTrunc)
else
- writeFile ("failures" out) (mkPage (ppDiff diff) prev next original res)
+ -- writeFile ("failures" out) (mkPage (ppDiff diff) prev next original res)
+ writeFile (failuresHtmlDir out) (mkPage fname (ppDiff diff) prev next original res)
where
tokenize :: String -> [[String]]
tokenize s = map (:[]) . lines $ s
-mkPage :: String -> String -> String -> String -> String -> String
-mkPage diff prev next original printed =
+mkPage :: FilePath -> String -> String -> String -> String -> String -> String
+mkPage filename diff prev next original printed =
intercalate ""
[mkLink prev "prev"
- , mkLink "failures.html" "home"
+ , mkLink failuresHtmlFile "home"
, mkLink next "next"
, ""
+ , "" ++ filename ++ "
"
+ , ""
, "" ++ diff ++ "
"
, "original
"
, "" ++ original ++ "
"
@@ -81,6 +93,7 @@
data Failure = Failure String FilePath
+getfname :: Failure -> FilePath
getfname (Failure _ fp) = fp
parseFail :: FilePath -> IO Failure
diff --git a/tests/Test.hs b/tests/Test.hs
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -1,10 +1,11 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE CPP #-}
-- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests.
module Main where
-import Language.Haskell.GHC.ExactPrint.Utils (showGhc)
+import Language.Haskell.GHC.ExactPrint.Utils ( showGhc )
-- import qualified FastString as GHC
-- import qualified GHC as GHC
@@ -30,6 +31,8 @@
-- import Debug.Trace
+-- ---------------------------------------------------------------------
+
data GHCVersion = GHC710 | GHC8 deriving (Eq, Ord, Show)
ghcVersion :: GHCVersion
@@ -43,8 +46,9 @@
-- | Directories to automatically find roundtrip tests
testDirs :: [FilePath]
testDirs =
- "ghc710" : ["ghc8" | ghcVersion >= GHC8]
-
+ case ghcVersion of
+ GHC710 -> ["ghc710-only","ghc710"]
+ GHC8 -> ["ghc710", "ghc8"]
-- ---------------------------------------------------------------------
@@ -71,32 +75,48 @@
findTests :: IO Test
findTests = testList "Round-trip tests" <$> mapM findTestsDir testDirs
+listTests :: IO ()
+listTests = do
+ let
+ ftd dir = do
+ let fp = testPrefix dir
+ fs <- getDirectoryContents fp
+ let testFiles = sort $ filter (".hs" `isSuffixOf`) fs
+ return (zip [0::Integer ..] testFiles)
+ files <- mapM ftd testDirs
+ putStrLn $ "round trip tests:" ++ show (zip testDirs files)
+
findTestsDir :: FilePath -> IO Test
findTestsDir dir = do
let fp = testPrefix dir
fs <- getDirectoryContents fp
- let testFiles = filter (".hs" `isSuffixOf`) fs
+ let testFiles = sort $ filter (".hs" `isSuffixOf`) fs
return $ testList dir (map (mkParserTest dir) testFiles)
mkTests :: IO Test
mkTests = do
+ -- listTests
roundTripTests <- findTests
- return $ TestList [roundTripTests, transformTests, failingTests]
+ return $ TestList [internalTests,roundTripTests, transformTests, failingTests]
-- Tests that will fail until https://phabricator.haskell.org/D907 lands in a
-- future GHC
failingTests :: Test
failingTests = testList "Failing tests"
[
- -- Require current master #10313 / Phab:D907
- mkTestModBad "Deprecation.hs"
- , mkTestModBad "MultiLineWarningPragma.hs"
- , mkTestModBad "UnicodeRules.hs"
-
-- Tests requiring future GHC modifications
+ mkTestModBad "InfixOperator.hs"
+
+#if __GLASGOW_HASKELL__ > 710
+ , mkTestModBad "overloadedlabelsrun04.hs"
+#else
, mkTestModBad "UnicodeSyntax.hs"
- , mkTestModBad "InfixOperator.hs"
+ , mkTestModBad "UnicodeRules.hs"
+ , mkTestModBad "Deprecation.hs"
+ , mkTestModBad "MultiLineWarningPragma.hs"
+#endif
+
]
@@ -129,26 +149,27 @@
tt' :: IO (Counts,Int)
tt' = runTestText (putTextToHandle stdout True) $ TestList [
- -- , mkTestModChange changeLayoutLet2 "LayoutLet2.hs"
- -- , mkTestModChange changeLayoutLet3 "LayoutLet3.hs"
- -- , mkTestModChange changeLayoutLet3 "LayoutLet4.hs"
- -- , mkTestModChange changeRename1 "Rename1.hs"
- -- , mkTestModChange changeRename2 "Rename2.hs"
- -- , mkTestModChange changeLayoutIn1 "LayoutIn1.hs"
- -- , mkTestModChange changeLayoutIn3 "LayoutIn3.hs"
- -- , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs"
- -- , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs"
- -- , mkTestModChange changeLayoutIn4 "LayoutIn4.hs"
- -- , mkTestModChange changeLocToName "LocToName.hs"
- -- , mkTestModChange changeLetIn1 "LetIn1.hs"
- -- , mkTestModChange changeWhereIn4 "WhereIn4.hs"
- -- , mkTestModChange changeAddDecl "AddDecl.hs"
- -- mkTestModChange changeLocalDecls "LocalDecls.hs"
- -- , mkTestModChange changeLocalDecls2 "LocalDecls2.hs"
- -- , mkTestModChange changeWhereIn3a "WhereIn3a.hs"
- -- , mkTestModChange changeRenameCase1 "RenameCase1.hs"
- -- , mkTestModChange changeRenameCase2 "RenameCase2.hs"
- mkTestModBad "QuasiQuote2.hs"
+ -- mkParserTest "ghc710" "Unicode.hs"
+
+ -- , mkParserTest "ghc8" "BundleExport.hs"
+ -- , mkParserTest "ghc8" "ExportSyntax.hs"
+ -- , mkParserTest "ghc8" "T10689a.hs"
+ -- , mkParserTest "ghc8" "Test10313.hs"
+ -- , mkParserTest "ghc8" "Test11018.hs"
+ -- , mkParserTest "ghc8" "determ004.hs"
+ -- , mkParserTest "ghc8" "export-class.hs"
+ -- , mkParserTest "ghc8" "export-syntax.hs"
+ -- , mkParserTest "ghc8" "export-type.hs"
+ -- , mkParserTest "ghc8" "overloadedlabelsrun04.hs"
+ -- mkParserTest "ghc710" "RdrNames.hs"
+ mkParserTest "ghc710" "Process1.hs"
+ -- mkParserTest "ghc8" "T10620.hs"
+ -- mkParserTest "ghc8" "Vta1.hs"
+ -- , mkParserTest "ghc8" "Vta2.hs"
+ -- , mkParserTest "failing" "Deprecation.hs"
+ -- , mkParserTest "failing" "MultiLineWarningPragma.hs"
+ -- , mkParserTest "failing" "UnicodeRules.hs"
+ -- , mkParserTest "failing" "UnicodeSyntax.hs"
]
testsTT :: Test
@@ -167,6 +188,35 @@
then exitFailure
else return () -- exitSuccess
+-- ---------------------------------------------------------------------
+
+ii :: IO ()
+ii = do
+ cnts <- fst <$> runTestText (putTextToHandle stdout True) internalTests
+ putStrLn $ show cnts
+ if errors cnts > 0 || failures cnts > 0
+ then exitFailure
+ else return () -- exitSuccess
+
+internalTests :: Test
+internalTests = testList "Internal tests"
+ [
+ -- testCleanupOneLine
+ ]
+
+{-
+testCleanupOneLine :: Test
+testCleanupOneLine = do
+ let
+ makeCase n = (show n
+ ,(T.replicate n " ") <> "\t|" <> T.replicate n " " <> "\t"
+ ,(T.replicate 8 " " <> "|"))
+ mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp)
+ where (name,inp,outp) = makeCase n
+ testList "cleanupOneLine" $ map mkTest [1..7]
+-}
+
+-- ---------------------------------------------------------------------
pwd :: IO FilePath
pwd = getCurrentDirectory
diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs
--- a/tests/Test/Common.hs
+++ b/tests/Test/Common.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -38,6 +39,11 @@
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
+#if __GLASGOW_HASKELL__ <= 710
+#else
+import qualified GHC.LanguageExtensions as LangExt
+#endif
+
import qualified Data.Map as Map
import Data.List hiding (find)
@@ -103,15 +109,20 @@
genTest :: Changer -> FilePath -> FilePath -> IO Report
genTest f origFile expectedFile = do
res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile
- expected <- GHC.liftIO $ readFile expectedFile
- orig <- GHC.liftIO $ readFile origFile
- let pristine = removeSpaces expected
+ expected <- GHC.liftIO $ readFileGhc expectedFile
+ orig <- GHC.liftIO $ readFileGhc origFile
+ -- let pristine = removeSpaces expected
+ let pristine = expected
case res of
Left (ss, m) -> return . Left $ ParseFailure ss m
Right (apianns, injectedComments, dflags, pmod) -> do
(printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments)
+#if __GLASGOW_HASKELL__ <= 710
let useCpp = GHC.xopt GHC.Opt_Cpp dflags
+#else
+ let useCpp = GHC.xopt LangExt.Cpp dflags
+#endif
printed = trimPrinted printed'
-- let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments
-- Clang cpp adds an extra newline character
@@ -182,3 +193,4 @@
case mm of
[] -> return Nothing
fs -> return (Just (snd $ head fs))
+
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
--- a/tests/Test/Transform.hs
+++ b/tests/Test/Transform.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Test.Transform where
@@ -5,7 +6,6 @@
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Parsers
-
import qualified Bag as GHC
import qualified GHC as GHC
import qualified OccName as GHC
@@ -105,7 +105,11 @@
doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p
replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
+#if __GLASGOW_HASKELL__ <= 710
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do
+#else
+ replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do
+#endif
newSpan <- uniqueSrcSpanT
let
newAnnKey = AnnKey newSpan (CN "HsValBinds")
@@ -125,10 +129,14 @@
let decls = [s,d]
-- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
modifyAnnsT (captureOrderAnnKey newAnnKey decls)
- return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs
- (GHC.HsValBinds
- (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])
- [GHC.L ls sig])))))
+ let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])
+ [GHC.L ls sig]))
+#if __GLASGOW_HASKELL__ <= 710
+ return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds)))
+#else
+ bindSpan <- uniqueSrcSpanT
+ return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds))))
+#endif
replaceLocalBinds x = return x
-- putStrLn $ "log:" ++ intercalate "\n" w
return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')
@@ -149,7 +157,11 @@
doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p
replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
+#if __GLASGOW_HASKELL__ <= 710
replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do
+#else
+ replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do
+#endif
a1 <- getAnnsT
a' <- case sigs of
[] -> return a1
@@ -161,10 +173,14 @@
let decls = s:d:oldDecls
-- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
modifyAnnsT (captureOrder m decls)
- return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs
- (GHC.HsValBinds
+ let binds' = (GHC.HsValBinds
(GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)
- (GHC.L ls sig:sigs))))))
+ (GHC.L ls sig:sigs)))
+#if __GLASGOW_HASKELL__ <= 710
+ return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds')))
+#else
+ return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds'))))
+#endif
replaceLocalBinds x = return x
-- putStrLn $ "log:" ++ intercalate "\n" w
return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')
@@ -239,6 +255,7 @@
changeLayoutLet5 :: Changer
changeLayoutLet5 ans parsed = return (ans,rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed)
+-- AZ:TODO: the GHC 8 version only needs to consider Located RdrName
rename :: (SYB.Data a) => String -> [(Pos, Pos)] -> a -> a
rename newNameStr spans a
= SYB.everywhere ( SYB.mkT replaceRdr
@@ -263,11 +280,19 @@
replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName
replaceHsVar (GHC.L ln (GHC.HsVar _))
+#if __GLASGOW_HASKELL__ <= 710
| cond ln = GHC.L ln (GHC.HsVar newName)
+#else
+ | cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName))
+#endif
replaceHsVar x = x
replacePat (GHC.L ln (GHC.VarPat _))
+#if __GLASGOW_HASKELL__ <= 710
| cond ln = GHC.L ln (GHC.VarPat newName)
+#else
+ | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))
+#endif
replacePat x = x
@@ -294,11 +319,19 @@
= return (ans,SYB.everywhere (SYB.mkT replace) parsed)
where
replace :: GHC.HsExpr GHC.RdrName -> GHC.HsExpr GHC.RdrName
+#if __GLASGOW_HASKELL__ <= 710
replace (GHC.HsLet localDecls expr@(GHC.L _ _))
+#else
+ replace (GHC.HsLet (GHC.L lb localDecls) expr@(GHC.L _ _))
+#endif
=
let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls
bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls
+#if __GLASGOW_HASKELL__ <= 710
in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr)
+#else
+ in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr)
+#endif
replace x = x
@@ -446,7 +479,11 @@
[d1,d2] <- hsDecls lp
balanceComments d1 d2
+#if __GLASGOW_HASKELL__ <= 710
let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1
+#else
+ let GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1
+#endif
balanceComments m1 m2
(d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do
@@ -549,12 +586,20 @@
doRmDecl = do
let
go :: GHC.HsExpr GHC.RdrName -> Transform (GHC.HsExpr GHC.RdrName)
+#if __GLASGOW_HASKELL__ <= 710
go (GHC.HsLet lb expr) = do
+#else
+ go (GHC.HsLet (GHC.L l lb) expr) = do
+#endif
decs <- hsDeclsValBinds lb
let dec = last decs
transferEntryDPT (head decs) dec
lb' <- replaceDeclsValbinds lb [dec]
+#if __GLASGOW_HASKELL__ <= 710
return (GHC.HsLet lb' expr)
+#else
+ return (GHC.HsLet (GHC.L l lb') expr)
+#endif
go x = return x
SYB.everywhereM (SYB.mkM go) lp
@@ -610,8 +655,13 @@
let doRmDecl = do
tlDecs <- hsDecls lp
let (s1:d1:d2) = tlDecs
+#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
+ (GHC.L l (GHC.SigD (GHC.TypeSig names typ))) = s1
+ s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ)))
+#endif
replaceDecls lp (s1':d1:d2)
let (lp',(ans',_),_w) = runTransform ans doRmDecl
diff --git a/tests/examples/failing/OverloadedLabelsRun04_A.hs b/tests/examples/failing/OverloadedLabelsRun04_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/failing/OverloadedLabelsRun04_A.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}
+module OverloadedLabelsRun04_A where
+
+import GHC.OverloadedLabels
+import Language.Haskell.TH
+
+instance IsLabel x (Q [Dec]) where
+ fromLabel _ = [d| main = putStrLn "Ok" |]
diff --git a/tests/examples/failing/overloadedlabelsrun04.hs b/tests/examples/failing/overloadedlabelsrun04.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/failing/overloadedlabelsrun04.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}
+
+import OverloadedLabelsRun04_A
+
+-- Who knew that there were so many ways that a line could start with
+-- a # sign in Haskell? None of these are overloaded labels:
+#line 7 "overloadedlabelsrun04.hs"
+# 8 "overloadedlabelsrun04.hs"
+#!notashellscript
+#pragma foo
+
+-- But this one is:
+#foo
diff --git a/tests/examples/failing/overloadedlabelsrun04.hs.bad b/tests/examples/failing/overloadedlabelsrun04.hs.bad
new file mode 100644
--- /dev/null
+++ b/tests/examples/failing/overloadedlabelsrun04.hs.bad
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}
+
+import OverloadedLabelsRun04_A
+
+
+
+
+
+#!notashellscript
+
+-- But this one is:
+-- a # sign in Haskell? None of these are overloaded labels:
+
+
+
+
+
+#foo
diff --git a/tests/examples/ghc710/CoreIr.hs b/tests/examples/ghc710/CoreIr.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc710/CoreIr.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Llvm.Data.CoreIr
+ ( module Llvm.Data.CoreIr
+ , module Llvm.Data.Shared
+ , module Llvm.Data.IrType
+ , module Data.Word
+ , Label
+ ) where
+import Llvm.Data.Shared
+import Llvm.Data.IrType
+import Compiler.Hoopl (Label)
+import Data.Int
+import Data.Word (Word8, Word16, Word32, Word64)
+import Data.DoubleWord
+
+data Conversion s v where {
+ AddrSpaceCast :: T (Type s P) v -> Type s P -> Conversion s v;
+ } deriving (Eq, Ord, Show)
+
diff --git a/tests/examples/ghc710/DataDecl.hs b/tests/examples/ghc710/DataDecl.hs
--- a/tests/examples/ghc710/DataDecl.hs
+++ b/tests/examples/ghc710/DataDecl.hs
@@ -22,7 +22,7 @@
G1C :: Double -> G1 a
data G2 a :: * where
- G2A { g2a :: a, g2b :: Int } :: G2 a
+ G2A :: { g2a :: a, g2b :: Int } -> G2 a
G2C :: Double -> G2 a
diff --git a/tests/examples/ghc710/HashQQ.hs b/tests/examples/ghc710/HashQQ.hs
--- a/tests/examples/ghc710/HashQQ.hs
+++ b/tests/examples/ghc710/HashQQ.hs
@@ -33,7 +33,7 @@
application/andrew-inset ez |]
-testComplex = assertBool "" ([$istr|
+testComplex = assertBool "" ([istr|
ok
#{Foo 4 "Great!" : [Foo 3 "Scott!"]}
then
diff --git a/tests/examples/ghc710/MachineTypes.hs b/tests/examples/ghc710/MachineTypes.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc710/MachineTypes.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module
+ Control.Arrow.Machine.Types
+where
+
+import qualified Control.Category as Cat
+import Data.Profunctor (Profunctor, dimap, rmap)
+import Control.Arrow
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Monad.Writer hiding ((<>))
+import Control.Monad.Identity
+import Control.Applicative
+import Data.Foldable as Fd
+import Data.Traversable as Tv
+import Data.Semigroup (Semigroup, (<>))
+import Data.Maybe (fromMaybe, isNothing, isJust)
+import qualified Control.Monad.Trans.Free as F
+import qualified Control.Monad.Trans.Free.Church as F
+import Control.Arrow.Machine.ArrowUtil
+import GHC.Exts (build)
+
+
+-- | To get multiple outputs by one input, the `Phase` parameter is introduced.
+--
+-- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s.
+data Phase = Feed | Sweep | Suspend deriving (Eq, Show)
+
+instance
+ Monoid Phase
+ where
+ mempty = Sweep
+
+ mappend Feed _ = Feed
+ mappend _ Feed = Feed
+ mappend Suspend _ = Suspend
+ mappend _ Suspend = Suspend
+ mappend Sweep Sweep = Sweep
+
+
+type ProcType a b c = ProcessA a b c
+
+-- | The stream transducer arrow.
+--
+-- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`,
+-- `arr`, functions declared in `Control.Arrow.Machine.Utils`,
+-- or arrow combinations of them.
+--
+-- See an introduction at "Control.Arrow.Machine" documentation.
+data ProcessA a b c = ProcessA {
+ feed :: a b (c, ProcessA a b c),
+ sweep :: a b (Maybe c, ProcessA a b c),
+ suspend :: !(b -> c)
+ }
+
+
+-- For internal use
+class
+ (Applicative f, Monad f) => ProcessHelper f
+ where
+ step :: ArrowApply a => ProcessA a b c -> a b (f c, ProcessA a b c)
+ helperToMaybe :: f a -> Maybe a
+ weakly :: a -> f a
+
+ step' :: ArrowApply a => ProcessA a b c -> a (f b) (f c, ProcessA a b c)
+ step' pa = proc hx ->
+ do
+ let mx = helperToMaybe hx
+ maybe
+ (arr $ const (suspend pa <$> hx, pa))
+ (\x -> proc _ -> step pa -< x)
+ mx
+ -<< ()
+
diff --git a/tests/examples/ghc710/Process.hs b/tests/examples/ghc710/Process.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc710/Process.hs
@@ -0,0 +1,717 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Synthesizer.MIDI.CausalIO.Process (
+ Events,
+
+ slice,
+ controllerLinear,
+ controllerExponential,
+ pitchBend,
+ channelPressure,
+ bendWheelPressure,
+ constant,
+
+ Instrument,
+ Bank,
+ GateChunk,
+ noteEvents,
+ embedPrograms,
+ applyInstrument,
+ applyModulatedInstrument,
+ flattenControlSchedule,
+ applyModulation,
+ arrangeStorable,
+ sequenceCore,
+ sequenceModulated,
+ sequenceModulatedMultiProgram,
+ sequenceModulatedMultiProgramVelocityPitch,
+ sequenceStorable,
+
+ -- auxiliary function
+ initWith,
+ mapMaybe,
+ ) where
+
+import qualified Synthesizer.CausalIO.Gate as Gate
+import qualified Synthesizer.CausalIO.Process as PIO
+
+import qualified Synthesizer.MIDI.Value.BendModulation as BM
+import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP
+import qualified Synthesizer.MIDI.Value as MV
+
+import qualified Synthesizer.MIDI.EventList as MIDIEv
+import Synthesizer.MIDI.EventList (StrictTime, )
+
+import qualified Synthesizer.PiecewiseConstant.Signal as PC
+import qualified Synthesizer.Storable.Cut as CutSt
+import qualified Synthesizer.Generic.Cut as CutG
+import qualified Synthesizer.Zip as Zip
+
+import qualified Sound.MIDI.Message.Class.Check as Check
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+
+import Control.DeepSeq (rnf, )
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Data.EventList.Relative.BodyTime as EventListBT
+import qualified Data.EventList.Relative.TimeTime as EventListTT
+import qualified Data.EventList.Relative.TimeMixed as EventListTM
+import qualified Data.EventList.Relative.MixedTime as EventListMT
+import qualified Data.EventList.Absolute.TimeBody as AbsEventList
+
+import qualified Numeric.NonNegative.Wrapper as NonNegW
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealRing as RealRing
+import qualified Algebra.Field as Field
+import qualified Algebra.Additive as Additive
+import qualified Algebra.ToInteger as ToInteger
+
+import qualified Data.StorableVector as SV
+import qualified Data.StorableVector.ST.Strict as SVST
+import Foreign.Storable (Storable, )
+
+import qualified Control.Monad.Trans.Writer as MW
+import qualified Control.Monad.Trans.State as MS
+import qualified Control.Monad.Trans.Class as MT
+import Control.Monad.IO.Class (liftIO, )
+
+import qualified Data.Traversable as Trav
+import Data.Traversable (Traversable, )
+import Data.Foldable (traverse_, )
+
+import Control.Arrow (Arrow, arr, (^<<), (<<^), )
+import Control.Category ((.), )
+
+import qualified Data.Map as Map
+
+import qualified Data.List.HT as ListHT
+import qualified Data.Maybe as Maybe
+import Data.Monoid (Monoid, mempty, mappend, )
+import Data.Maybe (maybeToList, )
+import Data.Tuple.HT (mapFst, mapPair, )
+
+import NumericPrelude.Numeric
+import NumericPrelude.Base hiding ((.), sequence, )
+import Prelude ()
+
+
+type Events event = EventListTT.T StrictTime [event]
+
+
+initWith ::
+ (y -> c) ->
+ c ->
+ PIO.T
+ (Events y)
+ (EventListBT.T PC.ShortStrictTime c)
+initWith f initial =
+ PIO.traverse initial $
+ \evs0 -> do
+ y0 <- MS.get
+ fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $
+ Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0
+
+slice ::
+ (Check.C event) =>
+ (event -> Maybe Int) ->
+ (Int -> y) -> y ->
+ PIO.T
+ (Events event)
+ (EventListBT.T PC.ShortStrictTime y)
+slice select f initial =
+ initWith f initial . mapMaybe select
+
+
+
+mapMaybe ::
+ (Arrow arrow, Functor f) =>
+ (a -> Maybe b) ->
+ arrow (f [a]) (f [b])
+mapMaybe f =
+ arr $ fmap $ Maybe.mapMaybe f
+
+catMaybes ::
+ (Arrow arrow, Functor f) =>
+ arrow (f [Maybe a]) (f [a])
+catMaybes =
+ arr $ fmap Maybe.catMaybes
+
+traverse ::
+ (Traversable f) =>
+ s -> (a -> MS.State s b) ->
+ PIO.T (f [a]) (f [b])
+traverse initial f =
+ PIO.traverse initial (Trav.traverse (Trav.traverse f))
+
+
+controllerLinear ::
+ (Check.C event, Field.C y) =>
+ MIDIEv.Channel ->
+ MIDIEv.Controller ->
+ (y,y) -> y ->
+ PIO.T
+ (Events event)
+ (EventListBT.T PC.ShortStrictTime y)
+controllerLinear chan ctrl bnd initial =
+ slice (Check.controller chan ctrl)
+ (MV.controllerLinear bnd) initial
+
+controllerExponential ::
+ (Check.C event, Trans.C y) =>
+ MIDIEv.Channel ->
+ MIDIEv.Controller ->
+ (y,y) -> y ->
+ PIO.T
+ (Events event)
+ (EventListBT.T PC.ShortStrictTime y)
+controllerExponential chan ctrl bnd initial =
+ slice (Check.controller chan ctrl)
+ (MV.controllerExponential bnd) initial
+
+pitchBend ::
+ (Check.C event, Trans.C y) =>
+ MIDIEv.Channel ->
+ y -> y ->
+ PIO.T
+ (Events event)
+ (EventListBT.T PC.ShortStrictTime y)
+pitchBend chan range center =
+ slice (Check.pitchBend chan)
+ (MV.pitchBend range center) center
+
+channelPressure ::
+ (Check.C event, Trans.C y) =>
+ MIDIEv.Channel ->
+ y -> y ->
+ PIO.T
+ (Events event)
+ (EventListBT.T PC.ShortStrictTime y)
+channelPressure chan maxVal initial =
+ slice (Check.channelPressure chan)
+ (MV.controllerLinear (zero,maxVal)) initial
+
+bendWheelPressure ::
+ (Check.C event, RealRing.C y, Trans.C y) =>
+ MIDIEv.Channel ->
+ Int -> y -> y ->
+ PIO.T
+ (Events event)
+ (EventListBT.T PC.ShortStrictTime (BM.T y))
+bendWheelPressure chan
+ pitchRange wheelDepth pressDepth =
+ let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth
+ in initWith toBM (toBM BWP.deflt)
+ .
+ catMaybes
+ .
+ traverse BWP.deflt (BWP.check chan)
+
+
+-- might be moved to synthesizer-core
+constant ::
+ (Arrow arrow) =>
+ y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y)
+constant y = arr $
+ EventListBT.singleton y .
+ NonNegW.fromNumberMsg "MIDI.CausalIO.constant" .
+ fromIntegral .
+ EventListTT.duration
+
+_constant ::
+ (Arrow arrow, CutG.Read input) =>
+ y -> arrow input (EventListBT.T PC.ShortStrictTime y)
+_constant y = arr $
+ EventListBT.singleton y .
+ NonNegW.fromNumberMsg "MIDI.CausalIO.constant" .
+ CutG.length
+
+
+
+noteEvents ::
+ (Check.C event, Arrow arrow) =>
+ MIDIEv.Channel ->
+ arrow
+ (Events event)
+ (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))
+noteEvents chan =
+ mapMaybe $ MIDIEv.checkNoteEvent chan
+
+
+embedPrograms ::
+ MIDIEv.Program ->
+ PIO.T
+ (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))
+ (Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program)))
+embedPrograms initPgm =
+ catMaybes .
+ traverse initPgm MIDIEv.embedProgramState
+
+
+type GateChunk = Gate.Chunk MIDIEv.Velocity
+type Instrument y chunk = y -> y -> PIO.T GateChunk chunk
+type Bank y chunk = MIDIEv.Program -> Instrument y chunk
+
+
+
+{-
+for distinction of notes with the same pitch
+
+We must use Integer instead of Int, in order to avoid an overflow
+that would invalidate the check for unmatched NoteOffs
+that is based on comparison of the NoteIds.
+We cannot re-use NoteIds easily,
+since the events at one time point are handled out of order.
+-}
+newtype NoteId = NoteId Integer
+ deriving (Show, Eq, Ord)
+
+succNoteId :: NoteId -> NoteId
+succNoteId (NoteId n) = NoteId (n+1)
+
+flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]
+flattenNoteIdRange (start,afterEnd) =
+ takeWhile ( rnf (NonNegW.toNumber t)) .
+ unwrapNoteOffList
+
+instance Monoid NoteOffList where
+ mempty = NoteOffList (EventListTT.pause mempty)
+ mappend (NoteOffList xs) (NoteOffList ys) =
+ NoteOffList (mappend xs ys)
+
+{- |
+The function defined here are based on the interpretation
+of event lists as piecewise constant signals.
+They do not fit to the interpretation of atomic events.
+Because e.g. it makes no sense to split an atomic event into two instances by splitAt,
+and it is also not clear, whether dropping the first chunk
+shall leave a chunk of length zero
+or remove that chunk completely.
+-}
+instance CutG.Transform NoteOffList where
+ take n (NoteOffList xs) =
+ NoteOffList $
+ EventListTT.takeTime
+ (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs
+ drop n (NoteOffList xs) =
+ NoteOffList $
+ EventListTT.dropTime
+ (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs
+ splitAt n (NoteOffList xs) =
+ mapPair (NoteOffList, NoteOffList) $
+ EventListTT.splitAtTime
+ (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs
+
+ -- cf. ChunkySize.dropMarginRem
+ dropMarginRem =
+ CutG.dropMarginRemChunky
+ (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList)
+
+ reverse (NoteOffList xs) =
+ NoteOffList . EventListTT.reverse $ xs
+
+
+findEvent ::
+ (a -> Bool) ->
+ Events a -> (Events a, Maybe a)
+findEvent p =
+ EventListTT.foldr
+ (\t -> mapFst (EventListMT.consTime t))
+ (\evs rest ->
+ case ListHT.break p evs of
+ (prefix, suffix) ->
+ mapFst (EventListMT.consBody prefix) $
+ case suffix of
+ [] -> rest
+ ev:_ -> (EventListTT.pause mempty, Just ev))
+ (EventListBT.empty, Nothing)
+
+gateFromNoteOffs ::
+ (MIDIEv.Pitch, NoteId) ->
+ NoteOffList ->
+ GateChunk
+gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) =
+ let dur = EventListTT.duration noteOffs
+ (sustain, mEnd) =
+ findEvent
+ (\bnd ->
+ case bnd of
+ -- AllNotesOff -> True
+ NoteBoundary endPitch _ noteId ->
+ pitchNoteId == (endPitch, noteId))
+ noteOffs
+ in Gate.chunk dur $
+ flip fmap mEnd $ \end ->
+ (EventListTT.duration sustain,
+ case end of
+ NoteBoundary _ endVel _ -> endVel
+ {-
+ AllNotesOff -> VoiceMsg.normalVelocity -} )
+
+
+data NoteBoundary a =
+ NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a
+-- | AllSoundOff
+ deriving (Eq, Show)
+
+{- |
+We count NoteIds per pitch,
+such that the pair (pitch,noteId) identifies a note.
+We treat nested notes in a first-in-first-out order (FIFO).
+E.g.
+
+> On, On, On, Off, Off, Off
+
+is interpreted as
+
+> On 0, On 1, On 2, Off 0, Off 1, Off 2
+
+NoteOffs without previous NoteOns are thrown away.
+-}
+assignNoteIds ::
+ (Traversable f) =>
+ PIO.T
+ (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])
+ (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])
+assignNoteIds =
+ fmap concat
+ ^<<
+ traverse Map.empty (\bnd ->
+ case bnd of
+ MIDIEv.AllNotesOff -> do
+ notes <- MS.get
+ MS.put Map.empty
+ return $
+ concatMap (\(pitch, range) ->
+ map
+ (\noteId ->
+ NoteBoundary pitch VoiceMsg.normalVelocity
+ (noteId, Nothing))
+ (flattenNoteIdRange range)) $
+ Map.toList notes
+ MIDIEv.NoteBoundary pitch vel mpgm ->
+ fmap (fmap (\noteId ->
+ NoteBoundary pitch vel (noteId,mpgm))) $
+ case mpgm of
+ Nothing -> do
+ mNoteId <- MS.gets (Map.lookup pitch)
+ case mNoteId of
+ Nothing -> return []
+ Just (nextNoteOffId, nextNoteOnId) ->
+ if nextNoteOffId >= nextNoteOnId
+ then return []
+ else do
+ MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId))
+ return [nextNoteOffId]
+ Just _ -> do
+ mNoteId <- MS.gets (Map.lookup pitch)
+ let (nextNoteOffId, nextNoteOnId) =
+ case mNoteId of
+ Nothing -> (NoteId 0, NoteId 0)
+ Just ids -> ids
+
+ MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId))
+ return [nextNoteOnId])
+
+{-# INLINE velFreqBank #-}
+velFreqBank ::
+ (Trans.C y) =>
+ (MIDIEv.Program -> y -> y -> process) ->
+ (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process)
+velFreqBank bank pgm vel pitch =
+ bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch)
+
+applyInstrumentCore ::
+ (Arrow arrow) =>
+ ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->
+ (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
+ PIO.T gateCtrl chunk) ->
+ arrow
+ (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
+ (Zip.T
+ NoteOffList
+ (Events (PIO.T noteOffListCtrl chunk)))
+applyInstrumentCore makeGate bank = arr $
+ uncurry Zip.Cons .
+ mapFst NoteOffList .
+ EventListTT.unzip .
+ fmap (ListHT.unzipEithers . fmap (\ev ->
+ case ev of
+-- MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff
+ NoteBoundary pitch vel (noteId, mpgm) ->
+ case mpgm of
+ Nothing -> Left $ NoteBoundary pitch vel noteId
+ Just pgm ->
+ Right $
+ bank pgm vel pitch
+ <<^
+ makeGate (pitch, noteId)))
+
+applyInstrument ::
+ (Arrow arrow) =>
+ (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
+ PIO.T GateChunk chunk) ->
+ arrow
+ (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
+ (Zip.T
+ NoteOffList
+ (Events (PIO.T NoteOffList chunk)))
+applyInstrument bank =
+ applyInstrumentCore gateFromNoteOffs bank
+
+
+type ModulatedBank y ctrl chunk =
+ MIDIEv.Program -> y -> y ->
+ PIO.T (Zip.T GateChunk ctrl) chunk
+
+applyModulatedInstrument ::
+ (Arrow arrow, CutG.Read ctrl) =>
+ (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
+ PIO.T (Zip.T GateChunk ctrl) chunk) ->
+ arrow
+ (Zip.T
+ (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
+ ctrl)
+ (Zip.T
+ (Zip.T NoteOffList ctrl)
+ (Events (PIO.T (Zip.T NoteOffList ctrl) chunk)))
+applyModulatedInstrument bank =
+ (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) ->
+ Zip.Cons (Zip.Cons noteOffs ctrl) events)
+ ^<<
+ Zip.arrowFirst
+ (applyInstrumentCore
+ (Zip.arrowFirst . gateFromNoteOffs) bank)
+
+
+{- |
+Turn an event list with bundles of elements
+into an event list with single events.
+ToDo: Move to event-list package?
+-}
+flatten ::
+ (NonNeg.C time) =>
+ a ->
+ EventListTT.T time [a] ->
+ EventListTT.T time a
+flatten empty =
+ EventListTT.foldr
+ EventListMT.consTime
+ (\bt xs ->
+ uncurry EventListMT.consBody $
+ case bt of
+ [] -> (empty, xs)
+ b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs))
+ EventListBT.empty
+
+
+flattenControlSchedule ::
+ (Monoid chunk, Arrow arrow) =>
+ arrow
+ (Zip.T ctrl
+ (EventListTT.T StrictTime [PIO.T ctrl chunk]))
+ (Zip.T ctrl
+ (EventListTT.T StrictTime (PIO.T ctrl chunk)))
+flattenControlSchedule = arr $
+ \(Zip.Cons ctrl evs) ->
+ -- Zip.consChecked "flattenControlSchedule" ctrl $
+ Zip.Cons ctrl $
+ flatten (arr (const mempty)) evs
+
+
+
+data CausalState a b =
+ forall state.
+ CausalState
+ (a -> state -> IO (b, state))
+ (state -> IO ())
+ state
+
+_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)
+_applyChunkSimple (CausalState next delete state0) input = do
+ (output, state1) <- next input state0
+ return (output, CausalState next delete state1)
+
+applyChunk ::
+ (CutG.Read a, CutG.Read b) =>
+ CausalState a b -> a -> IO (b, Maybe (CausalState a b))
+applyChunk (CausalState next delete state0) input = do
+ (output, state1) <- next input state0
+ cs <-
+ if CutG.length output < CutG.length input
+ then do
+ delete state1
+ return Nothing
+ else return $ Just $ CausalState next delete state1
+ return (output, cs)
+
+-- could be moved to synthesizer-core
+applyModulation ::
+ (CutG.Transform ctrl, CutG.NormalForm ctrl,
+ CutG.Read chunk,
+ Monoid time, ToInteger.C time) =>
+ PIO.T
+ (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))
+ (EventListTT.T time chunk)
+applyModulation = PIO.Cons
+ (\(Zip.Cons ctrl evs) acc0 -> do
+ acc1 <- mapM (flip applyChunk ctrl) acc0
+ let (accChunks, acc2) = unzip acc1
+
+ (newChunks, newAcc) <-
+ MW.runWriterT $
+ flip MS.evalStateT ctrl $
+ EventListTT.mapM
+ (\time -> do
+ ctrl_ <- MS.gets (CutG.drop (fromIntegral time))
+ MS.put ctrl_
+ return (case CutG.evaluateHead ctrl_ of () -> time))
+ (\(PIO.Cons next create delete) -> do
+ state0 <- liftIO create
+ (chunk, state1) <-
+ liftIO . applyChunk (CausalState next delete state0)
+ =<< MS.get
+ MT.lift $ MW.tell $ maybeToList state1
+ return chunk)
+ evs
+
+ return
+ (EventListTM.prependBodyEnd
+ (EventList.fromPairList $
+ map ((,) mempty) accChunks)
+ newChunks,
+ Maybe.catMaybes acc2 ++ newAcc))
+
+ (return [])
+ (mapM_ (\(CausalState _ close state) -> close state))
+
+-- move synthesizer-core:CausalIO
+arrangeStorable ::
+ (Arrow arrow, Storable a, Additive.C a) =>
+ arrow
+ (EventListTT.T StrictTime (SV.Vector a))
+ (SV.Vector a)
+arrangeStorable =
+ arr $ \evs ->
+ SVST.runSTVector (do
+ v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero
+ mapM_ (uncurry $ CutSt.addChunkToBuffer v) $
+ AbsEventList.toPairList $
+ AbsEventList.mapTime fromIntegral $
+ EventList.toAbsoluteEventList 0 $
+ EventListTM.switchTimeR const evs
+ return v)
+
+
+
+sequenceCore ::
+ (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) =>
+ MIDIEv.Channel ->
+ Bank y chunk ->
+ PIO.T (Events event) (EventListTT.T StrictTime chunk)
+sequenceCore channel bank =
+ applyModulation
+ .
+ flattenControlSchedule
+ .
+ applyInstrument (velFreqBank bank)
+ .
+ assignNoteIds
+ .
+ embedPrograms (VoiceMsg.toProgram 0)
+ .
+ noteEvents channel
+
+
+sequenceModulated ::
+ (Check.C event, Monoid chunk, CutG.Read chunk,
+ CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>
+ MIDIEv.Channel ->
+ ModulatedBank y ctrl chunk ->
+ PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
+sequenceModulated channel bank =
+ applyModulation
+ .
+ flattenControlSchedule
+ .
+ applyModulatedInstrument (velFreqBank bank)
+ .
+ Zip.arrowFirst
+ (assignNoteIds
+ .
+ embedPrograms (VoiceMsg.toProgram 0)
+ .
+ noteEvents channel)
+
+
+sequenceModulatedMultiProgram ::
+ (Check.C event, Monoid chunk, CutG.Read chunk,
+ CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>
+ MIDIEv.Channel ->
+ MIDIEv.Program ->
+ ModulatedBank y ctrl chunk ->
+ PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
+sequenceModulatedMultiProgram channel initPgm bank =
+ applyModulation
+ .
+ flattenControlSchedule
+ .
+ applyModulatedInstrument (velFreqBank bank)
+ .
+ Zip.arrowFirst
+ (assignNoteIds
+ .
+ embedPrograms initPgm
+ .
+ noteEvents channel)
+
+
+-- | may replace the other functions
+sequenceModulatedMultiProgramVelocityPitch ::
+ (Check.C event, Monoid chunk, CutG.Read chunk,
+ CutG.Transform ctrl, CutG.NormalForm ctrl) =>
+ MIDIEv.Channel ->
+ MIDIEv.Program ->
+ (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
+ PIO.T (Zip.T GateChunk ctrl) chunk) ->
+ PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
+sequenceModulatedMultiProgramVelocityPitch channel initPgm bank =
+ applyModulation
+ .
+ flattenControlSchedule
+ .
+ applyModulatedInstrument bank
+ .
+ Zip.arrowFirst
+ (assignNoteIds
+ .
+ embedPrograms initPgm
+ .
+ noteEvents channel)
+
+
+sequenceStorable ::
+ (Check.C event, Storable a, Additive.C a, Trans.C y) =>
+ MIDIEv.Channel ->
+ Bank y (SV.Vector a) ->
+ PIO.T (Events event) (SV.Vector a)
+sequenceStorable channel bank =
+ arrangeStorable
+ .
+ sequenceCore channel bank
diff --git a/tests/examples/ghc710/Process1.hs b/tests/examples/ghc710/Process1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc710/Process1.hs
@@ -0,0 +1,7 @@
+module Synthesizer.MIDI.CausalIO.Process1 where
+
+gateFromNoteOffs=
+ let dur = 1
+ in (d, 3
+ {-
+ AllNotesOff -> VoiceMsg.normalVelocity -} )
diff --git a/tests/examples/ghc710/QuasiQuote.hs b/tests/examples/ghc710/QuasiQuote.hs
--- a/tests/examples/ghc710/QuasiQuote.hs
+++ b/tests/examples/ghc710/QuasiQuote.hs
@@ -20,7 +20,7 @@
{-# LANGUAGE QuasiQuotes #-}
-testComplex = assertBool "" ([$istr|
+testComplex = assertBool "" ([istr|
ok
#{Foo 4 "Great!" : [Foo 3 "Scott!"]}
then
diff --git a/tests/examples/ghc710/TypeFamilies.hs b/tests/examples/ghc710/TypeFamilies.hs
deleted file mode 100644
--- a/tests/examples/ghc710/TypeFamilies.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html
-
-import Control.Concurrent.STM
-import Control.Concurrent.MVar
-import Data.Foldable (forM_)
-import Data.IORef
-
-class IOStore store where
- newIO :: a -> IO (store a)
- getIO :: store a -> IO a
- putIO :: store a -> a -> IO ()
-
-instance IOStore MVar where
- newIO = newMVar
- getIO = readMVar
- putIO mvar a = modifyMVar_ mvar (return . const a)
-
-instance IOStore IORef where
- newIO = newIORef
- getIO = readIORef
- putIO ioref a = modifyIORef ioref (const a)
-
-type Present = String
-storePresentsIO :: IOStore store => [Present] -> IO (store [Present])
-storePresentsIO xs = do
- store <- newIO []
- forM_ xs $ \x -> do
- old <- getIO store
- putIO store (x : old)
- return store
-
--- Type family version
-
-class Store store where
- type StoreMonad store :: * -> *
- new :: a -> (StoreMonad store) (store a)
- get :: store a -> (StoreMonad store) a
- put :: store a -> a -> (StoreMonad store) ()
-
-instance Store IORef where
- type StoreMonad IORef = IO
- new = newIORef
- get = readIORef
- put ioref a = modifyIORef ioref (const a)
-
-instance Store TVar where
- type StoreMonad TVar = STM
- new = newTVar
- get = readTVar
- put ioref a = modifyTVar ioref (const a)
-
-storePresents :: (Store store, Monad (StoreMonad store))
- => [Present] -> (StoreMonad store) (store [Present])
-storePresents xs = do
- store <- new []
- forM_ xs $ \x -> do
- old <- get store
- put store (x : old)
- return store
-
-type family (++) (a :: [k]) (b :: [k]) :: [k] where
- '[] ++ b = b
- (a ': as) ++ b = a ': (as ++ b)
-
-type family (f :: * -> *) |> (s :: * -> *) :: * -> *
-
-type instance f |> Union s = Union (f :> s)
-
-type family Compare (a :: k) (b :: k') :: Ordering where
- Compare '() '() = EQ
-
-type family (r1 :++: r2); infixr 5 :++:
-type instance r :++: Nil = r
-type instance r1 :++: r2 :> a = (r1 :++: r2) :> a
diff --git a/tests/examples/ghc8/A.hs b/tests/examples/ghc8/A.hs
--- a/tests/examples/ghc8/A.hs
+++ b/tests/examples/ghc8/A.hs
@@ -1,3 +1,4 @@
module A where
-data A = A
+class A a where
+ has :: a
diff --git a/tests/examples/ghc8/B.hs b/tests/examples/ghc8/B.hs
--- a/tests/examples/ghc8/B.hs
+++ b/tests/examples/ghc8/B.hs
@@ -1,8 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
module B where
-import A
-
-b :: Maybe a
-b = Nothing
+class B a where
+ has :: a
diff --git a/tests/examples/ghc8/BadTelescope.hs b/tests/examples/ghc8/BadTelescope.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BadTelescope.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeInType #-}
+
+module BadTelescope where
+
+import Data.Kind
+
+data SameKind :: k -> k -> *
+
+data X a k (b :: k) (c :: SameKind a b)
diff --git a/tests/examples/ghc8/BadTelescope2.hs b/tests/examples/ghc8/BadTelescope2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BadTelescope2.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeInType, ExplicitForAll #-}
+
+module BadTelescope2 where
+
+import Data.Kind
+import Data.Proxy
+
+data SameKind :: k -> k -> *
+
+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/ghc8/BadTelescope3.hs b/tests/examples/ghc8/BadTelescope3.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BadTelescope3.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeInType, ExplicitForAll #-}
+
+module BadTelescope3 where
+
+import Data.Kind
+
+data SameKind :: k -> k -> *
+
+type S a k (b :: k) = SameKind a b
diff --git a/tests/examples/ghc8/BadTelescope4.hs b/tests/examples/ghc8/BadTelescope4.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BadTelescope4.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ExistentialQuantification, TypeInType #-}
+module BadTelescope4 where
+
+import Data.Proxy
+import Data.Kind
+
+data SameKind :: k -> k -> *
+
+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/ghc8/Base.hs b/tests/examples/ghc8/Base.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Base.hs
@@ -0,0 +1,6 @@
+module Base (AClass(..), BClass()) where
+
+import Extends (BClass ())
+
+class AClass a where
+ has :: a
diff --git a/tests/examples/ghc8/Bundle.hs b/tests/examples/ghc8/Bundle.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Bundle.hs
@@ -0,0 +1,9 @@
+module Bundle(A(..)) where
+
+import BundleInternal (A(..))
+
+foo = MkA 5
+baz = NoA
+
+qux (MkA x) = x
+qux NoA = 0
diff --git a/tests/examples/ghc8/Bundle1.hs b/tests/examples/ghc8/Bundle1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Bundle1.hs
@@ -0,0 +1,9 @@
+module Associated1(A(..)) where
+
+import BundleInternal1 (A(..))
+
+foo = MkA 5
+baz = NoA
+
+qux (MkA x) = x
+qux NoA = 0
diff --git a/tests/examples/ghc8/BundleExport.hs b/tests/examples/ghc8/BundleExport.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BundleExport.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+module BundleExport(P(.., A), Q(B)) where
+
+data P = P
+
+data Q = Q
+
+pattern A = P
+pattern B = Q
diff --git a/tests/examples/ghc8/BundleInternal.hs b/tests/examples/ghc8/BundleInternal.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BundleInternal.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module BundleInternal (A(NewA,MkA, NoA)) where
+
+newtype A = NewA (Maybe Int)
+
+pattern MkA n = NewA (Just n)
+
+pattern NoA = NewA Nothing
diff --git a/tests/examples/ghc8/BundleInternal1.hs b/tests/examples/ghc8/BundleInternal1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/BundleInternal1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module BundleInternal1 (A(NewA,MkA, NoA)) where
+
+newtype A = NewA (Maybe Int)
+
+pattern MkA n = NewA (Just n)
+
+pattern NoA = NewA Nothing
diff --git a/tests/examples/ghc8/CustomTypeErrors01.hs b/tests/examples/ghc8/CustomTypeErrors01.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/CustomTypeErrors01.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds, UndecidableInstances #-}
+module T1 where
+import GHC.TypeLits
+
+
+data MyType = MyType
+
+instance
+ TypeError (Text "Values of type 'MyType' cannot be compared for equality.")
+ => Eq MyType where (==) = undefined
+
+err x = x == MyType
+
+
diff --git a/tests/examples/ghc8/CustomTypeErrors02.hs b/tests/examples/ghc8/CustomTypeErrors02.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/CustomTypeErrors02.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DataKinds, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-}
+module T2 where
+
+import GHC.TypeLits
+
+type family IntRep a where
+ IntRep Int = Integer
+ IntRep Integer = Integer
+ IntRep Bool = Integer
+ IntRep a = TypeError (Text "The type '" :<>: ShowType a :<>:
+ Text "' cannot be represented as an integer.")
+
+convert :: Num (IntRep a) => a -> IntRep a
+convert _ = 5
+
+err = convert id
+
+
diff --git a/tests/examples/ghc8/CustomTypeErrors03.hs b/tests/examples/ghc8/CustomTypeErrors03.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/CustomTypeErrors03.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DataKinds #-}
+module T3 where
+
+import GHC.TypeLits
+
+f :: TypeError (Text "This is a type error")
+f = undefined
diff --git a/tests/examples/ghc8/Dep1.hs b/tests/examples/ghc8/Dep1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Dep1.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TypeInType #-}
+
+module Dep1 where
+
+import Data.Kind
+
+data Proxy k (a :: k) = P
+
+x :: Proxy * Int
+x = P
+
+y :: Proxy Bool True
+y = P
diff --git a/tests/examples/ghc8/Dep2.hs b/tests/examples/ghc8/Dep2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Dep2.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PolyKinds, GADTs #-}
+
+module Dep2 where
+
+data G (a :: k) where
+ G1 :: G Int
+ G2 :: G Maybe
diff --git a/tests/examples/ghc8/Dep3.hs b/tests/examples/ghc8/Dep3.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Dep3.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-}
+
+module Dep3 where
+
+import Data.Kind
+import GHC.Exts ( Constraint )
+
+type Star1 = *
+
+data Id1 (a :: Star1) where
+ Id1 :: a -> Id1 a
+
+data Id1' :: Star1 -> * where
+ Id1' :: a -> Id1' a
+
+type family Star2 x where
+ Star2 x = *
+
+data Id2a (a :: Star2 Constraint) = Id2a a
+
+
+data Id2 (a :: Star2 Constraint) where
+ Id2 :: a -> Id2 a
+
+data Id2' :: Star2 Constraint -> * where
+ Id2' :: a -> Id2' a
diff --git a/tests/examples/ghc8/DepFail1.hs b/tests/examples/ghc8/DepFail1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/DepFail1.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeInType #-}
+
+module DepFail1 where
+
+data Proxy k (a :: k) = P
+
+z :: Proxy Bool
+z = P
+
+a :: Proxy Int Bool
+a = P
diff --git a/tests/examples/ghc8/Deprecation.hs b/tests/examples/ghc8/Deprecation.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Deprecation.hs
@@ -0,0 +1,16 @@
+
+module Deprecation
+{-# Deprecated ["This is a module \"deprecation\"",
+ "multi-line",
+ "with unicode: Frère" ] #-}
+ ( foo )
+ where
+
+{-# DEPRECATEd foo
+ ["This is a multi-line",
+ "deprecation message",
+ "for foo"] #-}
+foo :: Int
+foo = 4
+
+{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
diff --git a/tests/examples/ghc8/DsStrict.hs b/tests/examples/ghc8/DsStrict.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/DsStrict.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE Strict #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+module Main where
+
+import Debug.Trace
+
+f0 a = "fun"
+f0' ~a = "fun2"
+
+f1 ~n =
+ case n of
+ a -> "case"
+f1' ~n =
+ case n of
+ ~a -> "case2"
+
+f2 = \a -> "lamda"
+f2' = \ ~a -> "lambda2"
+
+newtype Age = MkAge Int
+
+f4, f4' :: Age -> String
+f4 (MkAge a) = "newtype"
+f4' ~(MkAge a) = "newtype2"
+
+main :: IO ()
+main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs
+ where fs =
+ [("fun",f0 )
+ ,("fun lazy",f0')
+ ,("case",f1)
+ ,("case lazy",f1')
+ ,("lambda",f2)
+ ,("lambda lazy",f2')
+ ,("newtype",(\ ~i -> f4 (MkAge i)))
+ ,("newtype lazy",(\ ~i -> f4' (MkAge i)))]
+ v n = trace ("evaluated in " ++ n) 1
diff --git a/tests/examples/ghc8/DsStrictFail.hs b/tests/examples/ghc8/DsStrictFail.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/DsStrictFail.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE Strict #-}
+module Main where
+
+main = let False = True
+ in return ()
diff --git a/tests/examples/ghc8/DsStrictLet.hs b/tests/examples/ghc8/DsStrictLet.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/DsStrictLet.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE Strict #-}
+module Main where
+
+import Debug.Trace
+
+main = let False = trace "no binders" False -- evaluated
+
+ a :: a -> a
+ a = trace "polymorphic" id -- evaluated
+
+ f :: Eq a => a -> a -> Bool
+ f = trace "overloaded" (==) -- not evaluated
+
+ xs :: [Int]
+ xs = (trace "recursive" (:) 1 xs) -- evaluated
+ in return ()
diff --git a/tests/examples/ghc8/DsStrictWarn.hs b/tests/examples/ghc8/DsStrictWarn.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/DsStrictWarn.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
+{-# LANGUAGE Strict #-}
+module DsStrictWarn where
+
+-- should warn about non-exhaustive pattern match
+w :: String -> String
+w x = let (_:_) = x in "1"
diff --git a/tests/examples/ghc8/Eq.hs b/tests/examples/ghc8/Eq.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Eq.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies,
+ RankNTypes, FlexibleContexts, TemplateHaskell,
+ UndecidableInstances, GADTs, DefaultSignatures #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Singletons.Prelude.Eq
+-- Copyright : (C) 2013 Richard Eisenberg
+-- License : BSD-style (see LICENSE)
+-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu)
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Defines the SEq singleton version of the Eq type class.
+--
+-----------------------------------------------------------------------------
+
+module Data.Singletons.Prelude.Eq (
+ PEq(..), SEq(..),
+ (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$)
+ ) where
+
+import Data.Singletons.Prelude.Bool
+import Data.Singletons
+import Data.Singletons.Single
+import Data.Singletons.Prelude.Instances
+import Data.Singletons.Util
+import Data.Singletons.Promote
+import Data.Type.Equality
+
+-- NB: These must be defined by hand because of the custom handling of the
+-- default for (:==) to use Data.Type.Equality.==
+
+-- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)',
+-- then it defaults to a use of '(==)', from @Data.Type.Equality@.
+class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where
+ type (:==) (x :: a) (y :: a) :: Bool
+ type (:/=) (x :: a) (y :: a) :: Bool
+
+ type (x :: a) :== (y :: a) = x == y
+ type (x :: a) :/= (y :: a) = Not (x :== y)
+
+infix 4 :==
+infix 4 :/=
+
+$(genDefunSymbols [''(:==), ''(:/=)])
+
+-- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required
+-- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'.
+class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where
+ -- | Boolean equality on singletons
+ (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b)
+ infix 4 %:==
+
+ -- | Boolean disequality on singletons
+ (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b)
+ default (%:/=) :: forall (a :: k) (b :: k).
+ ((a :/= b) ~ Not (a :== b))
+ => Sing a -> Sing b -> Sing (a :/= b)
+ a %:/= b = sNot (a %:== b)
+ infix 4 %:/=
+
+$(singEqInstances basicTypes)
diff --git a/tests/examples/ghc8/ExprSigLocal.hs b/tests/examples/ghc8/ExprSigLocal.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/ExprSigLocal.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}
+
+module ExprSigLocal where
+
+-- We expect this to compile fine,
+-- reporting that '_' stands 'a'
+
+y :: forall b. b->b
+y = ((\x -> x) :: forall a. a -> _)
+
+g :: forall a. a -> _
+g x = x
diff --git a/tests/examples/ghc8/Extends.hs b/tests/examples/ghc8/Extends.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Extends.hs
@@ -0,0 +1,4 @@
+module Extends where
+
+class BClass b where
+ has :: b
diff --git a/tests/examples/ghc8/FrontendPlugin.hs b/tests/examples/ghc8/FrontendPlugin.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/FrontendPlugin.hs
@@ -0,0 +1,52 @@
+module FrontendPlugin where
+
+import GhcPlugins
+import qualified GHC
+import GHC ( Ghc, LoadHowMuch(..) )
+
+import DriverPipeline hiding ( hsc_env )
+import DriverPhases
+import System.Exit
+import Control.Monad
+import Data.List
+
+frontendPlugin :: FrontendPlugin
+frontendPlugin = defaultFrontendPlugin {
+ frontend = doMake
+ }
+
+-- Copypasted from ghc/Main.hs
+doMake :: [String] -> [(String,Maybe Phase)] -> Ghc ()
+doMake opts srcs = do
+ liftIO $ print opts
+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs
+
+ haskellish (f,Nothing) =
+ looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f
+ haskellish (_,Just phase) =
+ phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm
+ , StopLn]
+
+ hsc_env <- GHC.getSession
+
+ -- if we have no haskell sources from which to do a dependency
+ -- analysis, then just do one-shot compilation and/or linking.
+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+ -- we expect.
+ if (null hs_srcs)
+ then liftIO (oneShot hsc_env StopLn srcs)
+ else do
+
+ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+ non_hs_srcs
+ dflags <- GHC.getSessionDynFlags
+ let dflags' = dflags { ldInputs = map (FileOption "") o_files
+ ++ ldInputs dflags }
+ _ <- GHC.setSessionDynFlags dflags'
+
+ targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+ GHC.setTargets targets
+ ok_flag <- GHC.load LoadAllTargets
+
+ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+ return ()
diff --git a/tests/examples/ghc8/Generate.hs b/tests/examples/ghc8/Generate.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Generate.hs
@@ -0,0 +1,7 @@
+import Control.Monad (forM_)
+
+main :: IO ()
+main = forM_ [0..0xffff] $ \i -> do
+ putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits"
+ putStrLn $ ".asciz \"Section " ++ show i ++ "\""
+ putStrLn ""
diff --git a/tests/examples/ghc8/KindEqualities.hs b/tests/examples/ghc8/KindEqualities.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/KindEqualities.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+
+module KindEqualities where
+
+data TyRep1 :: * -> * where
+ TyInt1 :: TyRep1 Int
+ TyBool1 :: TyRep1 Bool
+
+zero1 :: forall a. TyRep1 a -> a
+zero1 TyInt1 = 0
+zero1 TyBool1 = False
+
+data Proxy (a :: k) = P
+
+data TyRep :: k -> * where
+ TyInt :: TyRep Int
+ TyBool :: TyRep Bool
+ TyMaybe :: TyRep Maybe
+ TyApp :: TyRep a -> TyRep b -> TyRep (a b)
+
+zero :: forall (a :: *). TyRep a -> a
+zero TyInt = 0
+zero TyBool = False
+zero (TyApp TyMaybe _) = Nothing
diff --git a/tests/examples/ghc8/KindEqualities2.hs b/tests/examples/ghc8/KindEqualities2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 -> * 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 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/ghc8/KindLevels.hs b/tests/examples/ghc8/KindLevels.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/KindLevels.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds, PolyKinds #-}
+
+module KindLevels where
+
+data A
+data B :: A -> *
+data C :: B a -> *
+data D :: C b -> *
+data E :: D c -> *
diff --git a/tests/examples/ghc8/LiteralsTest2.hs b/tests/examples/ghc8/LiteralsTest2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/LiteralsTest2.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE MagicHash #-}
+module LiteralsTest2 where
+
+x,y :: Int
+x = 0003
+y = 0x04
+
+s :: String
+s = "\x20"
+
+c :: Char
+c = '\x20'
+
+d :: Double
+d = 0.00
+
+blah = x
+ where
+ charH = '\x41'#
+ intH = 0004#
+ wordH = 005##
+ floatH = 3.20#
+ doubleH = 04.16##
+ x = 1
diff --git a/tests/examples/ghc8/Main.hs b/tests/examples/ghc8/Main.hs
--- a/tests/examples/ghc8/Main.hs
+++ b/tests/examples/ghc8/Main.hs
@@ -1,11 +1,14 @@
-{-# LANGUAGE QuasiQuotes, ViewPatterns #-}
+-- Copyright (C) 2015, Luke Iannini
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
module Main where
+import Printf ( pr )
-import A
+foreign import ccall "talkToCxx" talkToCxx :: IO ()
+main :: IO ()
main = do
- case 1 of
- [foo|x|] -> print x
- case 1 of
- [bar| print fixed_var
+ putStrLn ( $(pr "Hello From Template Haskell!") )
+ talkToCxx
diff --git a/tests/examples/ghc8/MonadFailErrors.hs b/tests/examples/ghc8/MonadFailErrors.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/MonadFailErrors.hs
@@ -0,0 +1,95 @@
+-- Test purpose:
+-- Break properly if MonadFail is live
+
+{-# LANGUAGE MonadFailDesugaring #-}
+
+module MonadFailWarnings where
+
+import Control.Monad.Fail
+import Control.Monad.ST
+import Data.Functor.Identity
+
+
+
+general :: Monad m => m a
+general = do
+ Just x <- undefined
+ undefined
+
+
+
+general' :: MonadFail m => m a
+general' = do
+ Just x <- undefined
+ undefined
+
+
+
+identity :: Identity a
+identity = do
+ Just x <- undefined
+ undefined
+
+
+
+io :: IO a
+io = do
+ Just x <- undefined
+ undefined
+
+
+
+st :: ST s a
+st = do
+ Just x <- undefined
+ undefined
+
+
+
+reader :: r -> a
+reader = do
+ Just x <- undefined
+ undefined
+
+
+
+newtype Newtype a = Newtype a
+newtypeMatch :: Identity a
+newtypeMatch = do
+ Newtype x <- undefined
+ undefined
+
+
+
+data Data a = Data a
+singleConMatch :: Identity a
+singleConMatch = do
+ Data x <- undefined
+ undefined
+
+
+
+data Maybe' a = Nothing' | Just' a
+instance Functor Maybe' where fmap = undefined
+instance Applicative Maybe' where pure = undefined; (<*>) = undefined
+instance Monad Maybe' where (>>=) = undefined
+instance MonadFail Maybe' where fail = undefined
+customFailable :: Maybe' a
+customFailable = do
+ Just x <- undefined
+ undefined
+
+
+wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a
+wildcardx = do
+ x <- undefined
+ undefined
+explicitlyIrrefutable = do
+ ~(x:y) <- undefined
+ undefined
+wildcard_ = do
+ _ <- undefined
+ undefined
+tuple = do
+ (a,b) <- undefined
+ undefined
diff --git a/tests/examples/ghc8/MonadFailWarnings.hs b/tests/examples/ghc8/MonadFailWarnings.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/MonadFailWarnings.hs
@@ -0,0 +1,107 @@
+-- Test purpose:
+-- Ensure that MonadFail warnings are issued correctly if the warning flag
+-- is enabled
+
+{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-}
+
+module MonadFailWarnings where
+
+import Control.Monad.Fail
+import Control.Monad.ST
+import Data.Functor.Identity
+
+
+
+-- should warn, because the do-block gets a general Monad constraint,
+-- but should have MonadFail
+general :: Monad m => m a
+general = do
+ Just x <- undefined
+ undefined
+
+
+
+-- should NOT warn, because the constraint is correct
+general' :: MonadFail m => m a
+general' = do
+ Just x <- undefined
+ undefined
+
+
+
+-- should warn, because Identity isn't MonadFail
+identity :: Identity a
+identity = do
+ Just x <- undefined
+ undefined
+
+
+
+-- should NOT warn, because IO is MonadFail
+io :: IO a
+io = do
+ Just x <- undefined
+ undefined
+
+
+
+-- should warn, because (ST s) is not MonadFail
+st :: ST s a
+st = do
+ Just x <- undefined
+ undefined
+
+
+
+-- should warn, because (r ->) is not MonadFail
+reader :: r -> a
+reader = do
+ Just x <- undefined
+ undefined
+
+
+
+-- should NOT warn, because matching against newtype
+newtype Newtype a = Newtype a
+newtypeMatch :: Identity a
+newtypeMatch = do
+ Newtype x <- undefined
+ undefined
+
+
+
+-- should NOT warn, because Data has only one constructor
+data Data a = Data a
+singleConMatch :: Identity a
+singleConMatch = do
+ Data x <- undefined
+ undefined
+
+
+
+-- should NOT warn, because Maybe' has a MonadFail instance
+data Maybe' a = Nothing' | Just' a
+instance Functor Maybe' where fmap = undefined
+instance Applicative Maybe' where pure = undefined; (<*>) = undefined
+instance Monad Maybe' where (>>=) = undefined
+instance MonadFail Maybe' where fail = undefined
+customFailable :: Maybe' a
+customFailable = do
+ Just x <- undefined
+ undefined
+
+
+-- should NOT warn, because patterns always match
+wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a
+wildcardx = do
+ x <- undefined
+ undefined
+explicitlyIrrefutable = do
+ ~(x:y) <- undefined
+ undefined
+wildcard_ = do
+ _ <- undefined
+ undefined
+tuple = do
+ (a,b) <- undefined
+ undefined
diff --git a/tests/examples/ghc8/MonadFailWarningsDisabled.hs b/tests/examples/ghc8/MonadFailWarningsDisabled.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/MonadFailWarningsDisabled.hs
@@ -0,0 +1,94 @@
+-- Test purpose:
+-- Make sure that not enabling MonadFail warnings makes code compile just
+-- as it did in < 8.0
+
+module MonadFailWarnings where
+
+import Control.Monad.Fail
+import Control.Monad.ST
+import Data.Functor.Identity
+
+
+
+general :: Monad m => m a
+general = do
+ Just x <- undefined
+ undefined
+
+
+
+general' :: MonadFail m => m a
+general' = do
+ Just x <- undefined
+ undefined
+
+
+
+identity :: Identity a
+identity = do
+ Just x <- undefined
+ undefined
+
+
+
+io :: IO a
+io = do
+ Just x <- undefined
+ undefined
+
+
+
+st :: ST s a
+st = do
+ Just x <- undefined
+ undefined
+
+
+
+reader :: r -> a
+reader = do
+ Just x <- undefined
+ undefined
+
+
+
+newtype Newtype a = Newtype a
+newtypeMatch :: Identity a
+newtypeMatch = do
+ Newtype x <- undefined
+ undefined
+
+
+
+data Data a = Data a
+singleConMatch :: Identity a
+singleConMatch = do
+ Data x <- undefined
+ undefined
+
+
+
+data Maybe' a = Nothing' | Just' a
+instance Functor Maybe' where fmap = undefined
+instance Applicative Maybe' where pure = undefined; (<*>) = undefined
+instance Monad Maybe' where (>>=) = undefined
+instance MonadFail Maybe' where fail = undefined
+customFailable :: Maybe' a
+customFailable = do
+ Just x <- undefined
+ undefined
+
+
+wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a
+wildcardx = do
+ x <- undefined
+ undefined
+explicitlyIrrefutable = do
+ ~(x:y) <- undefined
+ undefined
+wildcard_ = do
+ _ <- undefined
+ undefined
+tuple = do
+ (a,b) <- undefined
+ undefined
diff --git a/tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs b/tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs
@@ -0,0 +1,14 @@
+-- Test purpose:
+-- RebindableSyntax does not play that well with MonadFail, so here we ensure
+-- that when both settings are enabled we get the proper warning.
+
+{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-}
+{-# LANGUAGE RebindableSyntax #-}
+
+module MonadFailWarningsWithRebindableSyntax where
+
+import Prelude
+
+test1 f g = do
+ Just x <- f
+ g
diff --git a/tests/examples/ghc8/MultiLineWarningPragma.hs b/tests/examples/ghc8/MultiLineWarningPragma.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/MultiLineWarningPragma.hs
@@ -0,0 +1,18 @@
+
+{-# WARNING Logic
+ , mkSolver
+ , mkSimpleSolver
+ , mkSolverForLogic
+ , solverSetParams
+ , solverPush
+ , solverPop
+ , solverReset
+ , solverGetNumScopes
+ , solverAssertCnstr
+ , solverAssertAndTrack
+ , solverCheck
+ , solverCheckAndGetModel
+ , solverGetReasonUnknown
+ "New Z3 API support is still incomplete and fragile: \
+ \you may experience segmentation faults!"
+ #-}
diff --git a/tests/examples/ghc8/MultiWayIf.hs b/tests/examples/ghc8/MultiWayIf.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/MultiWayIf.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE MultiWayIf #-}
+module MultiWayIf where
+
+foo = if | test1 -> e1
+ | test2 witharg -> e2
+ | otherwise -> def
+
+bar = if { | test1 -> if { | test2 -> e1
+ | test3 -> e2 }
+ | test4 -> e3
+ }
+
+-- taken from GHC's test suite
+x = 10
+x1 = if | x < 10 -> "< 10" | otherwise -> ""
+x2 = if | x < 10 -> "< 10"
+ | otherwise -> ""
+x3 = if | x < 10 -> "< 10"
+ | otherwise -> ""
+x4 = if | True -> "yes"
+x5 = if | True -> if | False -> 1 | True -> 2
+
+x6 = if | x < 10 -> if | True -> "yes"
+ | False -> "no"
+ | otherwise -> "maybe"
+
+x7 = (if | True -> 0)
+
+-- issue #98
+spam = if | () <- () -> ()
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail04_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail04_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail04_A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where
+
+data U = MkU { x :: Bool, y :: Bool }
+data V = MkV { x :: Int }
+data Unused = MkUnused { unused :: Bool }
+
+u = MkU False True
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail06_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail06_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail06_A.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -fwarn-unused-binds #-}
+
+module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where
+
+data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool }
+ deriving Show
+data V = MkV { x :: Int } | MkV2 { y :: Bool }
+data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool }
+
+u = MkU False True
+
+z MkU2{used_locally=used_locally} = used_locally
+
+getX MkU{x=x} = x
+getY MkV2{y=y} = y
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail10_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail10_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail10_A.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+module OverloadedRecFldsFail10_A where
+
+data family F a
+data instance F Int = MkFInt { foo :: Int }
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail10_B.hs b/tests/examples/ghc8/OverloadedRecFldsFail10_B.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail10_B.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module OverloadedRecFldsFail10_B (F(..)) where
+
+import OverloadedRecFldsFail10_A hiding (foo)
+
+data instance F Bool = MkFBool { foo :: Int }
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail10_C.hs b/tests/examples/ghc8/OverloadedRecFldsFail10_C.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail10_C.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}
+module OverloadedRecFldsFail10_C (F(..)) where
+
+import OverloadedRecFldsFail10_A
+
+data instance F Char = MkFChar { foo :: Char }
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail11_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail11_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail11_A.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module OverloadedRecFldsFail11_A where
+
+{-# WARNING foo "Warning on a record field" #-}
+data S = MkS { foo :: Bool }
+data T = MkT { foo :: Int }
diff --git a/tests/examples/ghc8/OverloadedRecFldsFail12_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail12_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsFail12_A.hs
@@ -0,0 +1,5 @@
+module OverloadedRecFldsFail12_A where
+
+{-# WARNING foo "Deprecated foo" #-}
+{-# WARNING bar "Deprecated bar" #-}
+data T = MkT { foo :: Int, bar :: Int }
diff --git a/tests/examples/ghc8/OverloadedRecFldsRun02_A.hs b/tests/examples/ghc8/OverloadedRecFldsRun02_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/OverloadedRecFldsRun02_A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where
+
+data U = MkU { x :: Bool, y :: Bool }
+data V = MkV { x :: Int }
+data Unused = MkUnused { unused :: Bool }
+
+u = MkU False True
diff --git a/tests/examples/ghc8/ParenFunBind.hs b/tests/examples/ghc8/ParenFunBind.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/ParenFunBind.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/tests/examples/ghc8/ParenTypeSynonym.hs b/tests/examples/ghc8/ParenTypeSynonym.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/ParenTypeSynonym.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
+module ParenTypeSynonym where
+
+type Is = (~)
diff --git a/tests/examples/ghc8/PluralS.hs b/tests/examples/ghc8/PluralS.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/PluralS.hs
@@ -0,0 +1,27 @@
+-- Test purpose:
+--
+-- Ensure the plural "s" in warnings is only shown if there are more than
+-- one entries
+
+{-# OPTIONS_GHC -Wredundant-constraints #-}
+{-# OPTIONS_GHC -Wtype-defaults #-}
+
+module PluralS () where
+
+
+
+-- Defaulting type classes
+
+defaultingNum = 123 `seq` ()
+
+defaultingNumAndShow = show 123
+
+
+
+-- Redundant constraints
+
+redundantNum :: (Num a, Num a) => a
+redundantNum = 123
+
+redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a
+redundantMultiple = 123
diff --git a/tests/examples/ghc8/PolyInstances.hs b/tests/examples/ghc8/PolyInstances.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/PolyInstances.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables,
+ UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module PolyInstances where
+
+import GHC.Exts
+import Data.Proxy
+
+class C (a :: k)
+
+instance (C a, C b) => C (a b)
+
+data Dict :: Constraint -> *
+
+instance C Dict
+
+foo :: C p => proxy p -> ()
+foo = undefined
+
+bar :: forall (p :: Constraint) proxy. C p => proxy p -> ()
+bar _ = foo (Proxy :: Proxy (Dict p))
diff --git a/tests/examples/ghc8/PopCnt.hs b/tests/examples/ghc8/PopCnt.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/PopCnt.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-}
+module Main where
+
+import GHC.Exts
+
+foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int#
+
+main = print (I# (popcnt32 0xffff#))
+
diff --git a/tests/examples/ghc8/Primop.hs b/tests/examples/ghc8/Primop.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Primop.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE GHCForeignImportPrim, MagicHash,
+ UnliftedFFITypes, UnboxedTuples #-}
+
+import GHC.Exts
+
+foreign import prim "dummy"
+ dummy :: Word# -> Word#
+
+foreign import prim "dummy2"
+ dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #)
diff --git a/tests/examples/ghc8/Printf.hs b/tests/examples/ghc8/Printf.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Printf.hs
@@ -0,0 +1,34 @@
+-- Copyright (C) 2015, Luke Iannini
+
+{-# LANGUAGE TemplateHaskell #-}
+module Printf where
+
+-- Skeletal printf from the paper:
+-- http://research.microsoft.com/pubs/67015/meta-haskell.pdf
+-- It needs to be in a separate module to the one where
+-- you intend to use it.
+
+-- Import some Template Haskell syntax
+import Language.Haskell.TH
+
+-- Describe a format string
+data Format = D | S | L String
+
+-- Parse a format string. This is left largely to you
+-- as we are here interested in building our first ever
+-- Template Haskell program and not in building printf.
+parse :: String -> [Format]
+parse s = [ L s ]
+
+-- Generate Haskell source code from a parsed representation
+-- of the format string. This code will be spliced into
+-- the module which calls "pr", at compile time.
+gen :: [Format] -> Q Exp
+gen [D] = [| \n -> show n |]
+gen [S] = [| \s -> s |]
+gen [L s] = stringE s
+
+-- Here we generate the Haskell code for the splice
+-- from an input format string.
+pr :: String -> Q Exp
+pr s = gen (parse s)
diff --git a/tests/examples/ghc8/PromotedClass.hs b/tests/examples/ghc8/PromotedClass.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/PromotedClass.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeInType, GADTs #-}
+
+module PromotedClass where
+
+import Data.Proxy
+
+data X a where
+ MkX :: Show a => a -> X a
+
+foo :: Proxy ('MkX 'True)
+foo = Proxy
diff --git a/tests/examples/ghc8/RAE_T32a.hs b/tests/examples/ghc8/RAE_T32a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 :: *) :: k -> *
+
+data TyArr' (a :: *) (b :: *) :: *
+type TyArr (a :: *) (b :: *) = TyArr' a b -> *
+type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2
+data TyPi' (a :: *) (b :: TyArr a *) :: *
+type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> *
+type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b
+$(return [])
+
+data MkStar (p :: *) (x :: TyArr' p *)
+type instance MkStar p @@ x = *
+$(return [])
+
+data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where
+ Sigma ::
+ forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a).
+ Sing * 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 :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a)
+ (sp :: Sing * 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/ghc8/RAE_T32b.hs b/tests/examples/ghc8/RAE_T32b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 :: *) :: k -> *
+
+data TyArr (a :: *) (b :: *) :: *
+type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2
+$(return [])
+
+data Sigma (p :: *) (r :: TyArr p * -> *) :: * where
+ Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a).
+ Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r
+$(return [])
+
+data instance Sing (Sigma p r) (x :: Sigma p r) :: * where
+ SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a)
+ (sp :: Sing * p) (sr :: Sing (TyArr 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)
diff --git a/tests/examples/ghc8/Rae31.hs b/tests/examples/ghc8/Rae31.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Rae31.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds,
+ TypeFamilies, TypeInType #-}
+
+module A where
+
+import Data.Kind
+
+data family Sing (k :: *) :: k -> *
+type Sing' (x :: k) = Sing k x
+data TyFun' (a :: *) (b :: *) :: *
+type TyFun (a :: *) (b :: *) = TyFun' a b -> *
+type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2
+data TyPi' (a :: *) (b :: TyFun a *) :: *
+type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> *
+type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b
+$(return [])
+
+data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> *
+type instance (@@) (A a b) c = *
+$(return [])
+data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> *
+type instance (@@) (B a) b = TyPi a (A a b)
+$(return [])
+data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *)
diff --git a/tests/examples/ghc8/RaeBlogPost.hs b/tests/examples/ghc8/RaeBlogPost.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 -> *
+data C :: B a -> *
+data D :: C b -> *
+data E :: D c -> *
+-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> *
+
+-- 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 :: * -> Nat -> * 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 *
+data U = Star (*)
+ | Bool Bool
+
+-- kind synonym
+type Monadish = * -> *
+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, * really does have type *.
+type Star = (* :: (* :: (* :: *)))
diff --git a/tests/examples/ghc8/RenamingStar.hs b/tests/examples/ghc8/RenamingStar.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/RenamingStar.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeInType #-}
+
+module RenamingStar where
+
+data Foo :: *
diff --git a/tests/examples/ghc8/SelfDep.hs b/tests/examples/ghc8/SelfDep.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/SelfDep.hs
@@ -0,0 +1,3 @@
+module SelfDep where
+
+data T :: T -> *
diff --git a/tests/examples/ghc8/SemigroupWarnings.hs b/tests/examples/ghc8/SemigroupWarnings.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/SemigroupWarnings.hs
@@ -0,0 +1,34 @@
+-- Test purpose:
+-- Ensure that missing semigroup warnings are issued
+-- correctly if the warning flag is enabled
+
+{-# OPTIONS_GHC -fwarn-semigroup #-}
+
+module SemigroupWarnings where
+
+
+
+import Data.Semigroup
+
+
+
+-- Bad instance, should complain about missing Semigroup parent
+data LacksSemigroup
+instance Monoid LacksSemigroup where
+ mempty = undefined
+ mappend = undefined
+
+
+
+-- Correct instance, should not warn
+data HasSemigroup
+instance Semigroup HasSemigroup where
+ (<>) = undefined
+instance Monoid HasSemigroup where
+ mempty = undefined
+ mappend = undefined
+
+
+
+-- Should issue a Prelude clash warning
+(<>) = undefined
diff --git a/tests/examples/ghc8/SigTvKinds.hs b/tests/examples/ghc8/SigTvKinds.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/SigTvKinds.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PolyKinds #-}
+
+module SigTvKinds where
+
+data T (a :: k1) x = MkT (S a ())
+data S (b :: k2) y = MkS (T b ())
+ -- tests TcTyClsDecls.no_sig_tv
diff --git a/tests/examples/ghc8/SigTvKinds2.hs b/tests/examples/ghc8/SigTvKinds2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/SigTvKinds2.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PolyKinds #-}
+
+module SigTvKinds2 where
+
+data SameKind :: k -> k -> *
+
+data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
diff --git a/tests/examples/ghc8/T10041.hs b/tests/examples/ghc8/T10041.hs
--- a/tests/examples/ghc8/T10041.hs
+++ b/tests/examples/ghc8/T10041.hs
diff --git a/tests/examples/ghc8/T10045.hs b/tests/examples/ghc8/T10045.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10045.hs
@@ -0,0 +1,8 @@
+module T10045 where
+
+newtype Meta = Meta ()
+
+foo (Meta ws1) =
+ let copy :: _
+ copy w from = copy w True
+ in copy ws1 False
diff --git a/tests/examples/ghc8/T10196Fail1.hs b/tests/examples/ghc8/T10196Fail1.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T10196Fail1.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module T10196Fail1 where
-
--- Constructors are not allowed to start with a modifier letter.
-data Foo = ᵦfoo
diff --git a/tests/examples/ghc8/T10196Fail2.hs b/tests/examples/ghc8/T10196Fail2.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T10196Fail2.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module T10196Fail2 where
-
--- Variables are not allowed to start with a modifier letter.
-ᵦ = 1
diff --git a/tests/examples/ghc8/T10196Fail3.hs b/tests/examples/ghc8/T10196Fail3.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T10196Fail3.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module T10196Fail3 where
-
--- Modifier letters are not allowed in the middle of an identifier.
--- And this should not be lexed as 2 separate identifiers either.
-xᵦx :: Int
-xᵦx = 1
diff --git a/tests/examples/ghc8/T10215.hs b/tests/examples/ghc8/T10215.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10215.hs
@@ -0,0 +1,9 @@
+testF :: Float -> Bool
+testF x = x == 0 && not (isNegativeZero x)
+
+testD :: Double -> Bool
+testD x = x == 0 && not (isNegativeZero x)
+
+main :: IO ()
+main = do print $ testF (-0.0)
+ print $ testD (-0.0)
diff --git a/tests/examples/ghc8/T10267.hs b/tests/examples/ghc8/T10267.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10267.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10267 where
+
+import Language.Haskell.TH
+import T10267a
+
+[d| i :: a -> a
+ i = _foo
+
+ j :: a -> a
+ j x = _ |]
+
+$(return [
+ SigD (mkName "k")
+ (ForallT [PlainTV (mkName "a")]
+ []
+ (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
+ , FunD (mkName "k")
+ [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []]
+ ])
+
+$(return [
+ SigD (mkName "l")
+ (ForallT [PlainTV (mkName "a")]
+ []
+ (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
+ , FunD (mkName "l")
+ [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []]
+ ])
+
+foo :: a -> a
+foo x = $varX
diff --git a/tests/examples/ghc8/T10267a.hs b/tests/examples/ghc8/T10267a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10267a.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10267a where
+
+import Language.Haskell.TH
+
+varX :: Q Exp
+varX = [| x |]
diff --git a/tests/examples/ghc8/T10279.hs b/tests/examples/ghc8/T10279.hs
--- a/tests/examples/ghc8/T10279.hs
+++ b/tests/examples/ghc8/T10279.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
module T10279 where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
diff --git a/tests/examples/ghc8/T10318.hs b/tests/examples/ghc8/T10318.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10318.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances,
+ FlexibleInstances, TypeFamilies,
+ UndecidableSuperClasses #-}
+
+module T10318 where
+
+-- | Product of non-zero elements always non-zero.
+-- Every integral domain has a field of fractions.
+-- The field of fractions of any field is itself.
+class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a))
+ => IntegralDomain a where
+ type Frac a :: *
+ embed :: a -> Frac a
+
+instance IntegralDomain Integer where
+ type Frac Integer = Rational
+ embed = fromInteger
+
+instance IntegralDomain Rational where
+ type Frac Rational = Rational
+ embed = id
+
+g :: IntegralDomain a => a -> a
+g x = g x
+
+h :: a -> Frac a
+h x = h x
+
+-- This is the test function
+
+f :: IntegralDomain a => a -> Frac a
+f x = g (h (h x))
+ -- Given: IntegralDomain (Frac a)
+ -- Wanted: IntegralDomain (Frac (Frac a))
+
diff --git a/tests/examples/ghc8/T10361a.hs b/tests/examples/ghc8/T10361a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10361a.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+module T10361a where
+
+class C1 a where
+ type T1 a
+ type instance T1 a = Char
+
+class C2 a where -- equivalent to C1
+ type T2 a
+ type instance T2 a = Char
+
+class C3 a where -- equivalent to C1, C2
+ type T3 a
+ type instance T3 a = Char
+
+data A = B
+ deriving C1
+
+deriving instance C2 A
+
+instance C3 A
+
+test1 :: T1 A
+test1 = 'x'
+
+test2 :: T2 A
+test2 = 'x'
+
+test3 :: T3 A
+test3 = 'x'
diff --git a/tests/examples/ghc8/T10361b.hs b/tests/examples/ghc8/T10361b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10361b.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T10361b where
+
+import GHC.Generics
+
+---------------------------------------------------------------------
+class Convert a where
+ type Result a
+ type instance Result a = GResult (Rep a)
+
+ convert :: a -> Result a
+ default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a)
+ convert x = gconvert (from x)
+
+instance Convert Float where
+ type Result Float = Float
+ convert = id
+
+instance Convert Int where
+ type Result Int = Int
+ convert = id
+
+---------------------------------------------------------------------
+class GConvert f where
+ type GResult f
+ gconvert :: f p -> GResult f
+
+instance (Convert c) => GConvert (K1 i c) where
+ type GResult (K1 i c) = Result c
+ gconvert (K1 x) = convert x
+
+instance (GConvert f) => GConvert (M1 i t f) where
+ type GResult (M1 i t f) = GResult f
+ gconvert (M1 x) = gconvert x
+
+instance (GConvert f, GConvert g) => GConvert (f :*: g) where
+ type GResult (f :*: g) = (GResult f, GResult g)
+ gconvert (x :*: y) = (gconvert x, gconvert y)
+
+---------------------------------------------------------------------
+
+data Data1 = Data1 Int Float
+ deriving (Generic)
+
+instance Convert Data1
+
+val :: (Int, Float)
+val = convert $ Data1 0 0.0
+
+data Data2 = Data2 Int Float
+ deriving (Generic, Convert)
diff --git a/tests/examples/ghc8/T10370.hs b/tests/examples/ghc8/T10370.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10370.hs
@@ -0,0 +1,1002 @@
+module Out where
+import Control.Monad (forever)
+a1 :: IO (); a1 = forever $ putStrLn "a1"
+a2 :: IO (); a2 = forever $ putStrLn "a2"
+a3 :: IO (); a3 = forever $ putStrLn "a3"
+a4 :: IO (); a4 = forever $ putStrLn "a4"
+a5 :: IO (); a5 = forever $ putStrLn "a5"
+a6 :: IO (); a6 = forever $ putStrLn "a6"
+a7 :: IO (); a7 = forever $ putStrLn "a7"
+a8 :: IO (); a8 = forever $ putStrLn "a8"
+a9 :: IO (); a9 = forever $ putStrLn "a9"
+a10 :: IO (); a10 = forever $ putStrLn "a10"
+a11 :: IO (); a11 = forever $ putStrLn "a11"
+a12 :: IO (); a12 = forever $ putStrLn "a12"
+a13 :: IO (); a13 = forever $ putStrLn "a13"
+a14 :: IO (); a14 = forever $ putStrLn "a14"
+a15 :: IO (); a15 = forever $ putStrLn "a15"
+a16 :: IO (); a16 = forever $ putStrLn "a16"
+a17 :: IO (); a17 = forever $ putStrLn "a17"
+a18 :: IO (); a18 = forever $ putStrLn "a18"
+a19 :: IO (); a19 = forever $ putStrLn "a19"
+a20 :: IO (); a20 = forever $ putStrLn "a20"
+a21 :: IO (); a21 = forever $ putStrLn "a21"
+a22 :: IO (); a22 = forever $ putStrLn "a22"
+a23 :: IO (); a23 = forever $ putStrLn "a23"
+a24 :: IO (); a24 = forever $ putStrLn "a24"
+a25 :: IO (); a25 = forever $ putStrLn "a25"
+a26 :: IO (); a26 = forever $ putStrLn "a26"
+a27 :: IO (); a27 = forever $ putStrLn "a27"
+a28 :: IO (); a28 = forever $ putStrLn "a28"
+a29 :: IO (); a29 = forever $ putStrLn "a29"
+a30 :: IO (); a30 = forever $ putStrLn "a30"
+a31 :: IO (); a31 = forever $ putStrLn "a31"
+a32 :: IO (); a32 = forever $ putStrLn "a32"
+a33 :: IO (); a33 = forever $ putStrLn "a33"
+a34 :: IO (); a34 = forever $ putStrLn "a34"
+a35 :: IO (); a35 = forever $ putStrLn "a35"
+a36 :: IO (); a36 = forever $ putStrLn "a36"
+a37 :: IO (); a37 = forever $ putStrLn "a37"
+a38 :: IO (); a38 = forever $ putStrLn "a38"
+a39 :: IO (); a39 = forever $ putStrLn "a39"
+a40 :: IO (); a40 = forever $ putStrLn "a40"
+a41 :: IO (); a41 = forever $ putStrLn "a41"
+a42 :: IO (); a42 = forever $ putStrLn "a42"
+a43 :: IO (); a43 = forever $ putStrLn "a43"
+a44 :: IO (); a44 = forever $ putStrLn "a44"
+a45 :: IO (); a45 = forever $ putStrLn "a45"
+a46 :: IO (); a46 = forever $ putStrLn "a46"
+a47 :: IO (); a47 = forever $ putStrLn "a47"
+a48 :: IO (); a48 = forever $ putStrLn "a48"
+a49 :: IO (); a49 = forever $ putStrLn "a49"
+a50 :: IO (); a50 = forever $ putStrLn "a50"
+a51 :: IO (); a51 = forever $ putStrLn "a51"
+a52 :: IO (); a52 = forever $ putStrLn "a52"
+a53 :: IO (); a53 = forever $ putStrLn "a53"
+a54 :: IO (); a54 = forever $ putStrLn "a54"
+a55 :: IO (); a55 = forever $ putStrLn "a55"
+a56 :: IO (); a56 = forever $ putStrLn "a56"
+a57 :: IO (); a57 = forever $ putStrLn "a57"
+a58 :: IO (); a58 = forever $ putStrLn "a58"
+a59 :: IO (); a59 = forever $ putStrLn "a59"
+a60 :: IO (); a60 = forever $ putStrLn "a60"
+a61 :: IO (); a61 = forever $ putStrLn "a61"
+a62 :: IO (); a62 = forever $ putStrLn "a62"
+a63 :: IO (); a63 = forever $ putStrLn "a63"
+a64 :: IO (); a64 = forever $ putStrLn "a64"
+a65 :: IO (); a65 = forever $ putStrLn "a65"
+a66 :: IO (); a66 = forever $ putStrLn "a66"
+a67 :: IO (); a67 = forever $ putStrLn "a67"
+a68 :: IO (); a68 = forever $ putStrLn "a68"
+a69 :: IO (); a69 = forever $ putStrLn "a69"
+a70 :: IO (); a70 = forever $ putStrLn "a70"
+a71 :: IO (); a71 = forever $ putStrLn "a71"
+a72 :: IO (); a72 = forever $ putStrLn "a72"
+a73 :: IO (); a73 = forever $ putStrLn "a73"
+a74 :: IO (); a74 = forever $ putStrLn "a74"
+a75 :: IO (); a75 = forever $ putStrLn "a75"
+a76 :: IO (); a76 = forever $ putStrLn "a76"
+a77 :: IO (); a77 = forever $ putStrLn "a77"
+a78 :: IO (); a78 = forever $ putStrLn "a78"
+a79 :: IO (); a79 = forever $ putStrLn "a79"
+a80 :: IO (); a80 = forever $ putStrLn "a80"
+a81 :: IO (); a81 = forever $ putStrLn "a81"
+a82 :: IO (); a82 = forever $ putStrLn "a82"
+a83 :: IO (); a83 = forever $ putStrLn "a83"
+a84 :: IO (); a84 = forever $ putStrLn "a84"
+a85 :: IO (); a85 = forever $ putStrLn "a85"
+a86 :: IO (); a86 = forever $ putStrLn "a86"
+a87 :: IO (); a87 = forever $ putStrLn "a87"
+a88 :: IO (); a88 = forever $ putStrLn "a88"
+a89 :: IO (); a89 = forever $ putStrLn "a89"
+a90 :: IO (); a90 = forever $ putStrLn "a90"
+a91 :: IO (); a91 = forever $ putStrLn "a91"
+a92 :: IO (); a92 = forever $ putStrLn "a92"
+a93 :: IO (); a93 = forever $ putStrLn "a93"
+a94 :: IO (); a94 = forever $ putStrLn "a94"
+a95 :: IO (); a95 = forever $ putStrLn "a95"
+a96 :: IO (); a96 = forever $ putStrLn "a96"
+a97 :: IO (); a97 = forever $ putStrLn "a97"
+a98 :: IO (); a98 = forever $ putStrLn "a98"
+a99 :: IO (); a99 = forever $ putStrLn "a99"
+a100 :: IO (); a100 = forever $ putStrLn "a100"
+a101 :: IO (); a101 = forever $ putStrLn "a101"
+a102 :: IO (); a102 = forever $ putStrLn "a102"
+a103 :: IO (); a103 = forever $ putStrLn "a103"
+a104 :: IO (); a104 = forever $ putStrLn "a104"
+a105 :: IO (); a105 = forever $ putStrLn "a105"
+a106 :: IO (); a106 = forever $ putStrLn "a106"
+a107 :: IO (); a107 = forever $ putStrLn "a107"
+a108 :: IO (); a108 = forever $ putStrLn "a108"
+a109 :: IO (); a109 = forever $ putStrLn "a109"
+a110 :: IO (); a110 = forever $ putStrLn "a110"
+a111 :: IO (); a111 = forever $ putStrLn "a111"
+a112 :: IO (); a112 = forever $ putStrLn "a112"
+a113 :: IO (); a113 = forever $ putStrLn "a113"
+a114 :: IO (); a114 = forever $ putStrLn "a114"
+a115 :: IO (); a115 = forever $ putStrLn "a115"
+a116 :: IO (); a116 = forever $ putStrLn "a116"
+a117 :: IO (); a117 = forever $ putStrLn "a117"
+a118 :: IO (); a118 = forever $ putStrLn "a118"
+a119 :: IO (); a119 = forever $ putStrLn "a119"
+a120 :: IO (); a120 = forever $ putStrLn "a120"
+a121 :: IO (); a121 = forever $ putStrLn "a121"
+a122 :: IO (); a122 = forever $ putStrLn "a122"
+a123 :: IO (); a123 = forever $ putStrLn "a123"
+a124 :: IO (); a124 = forever $ putStrLn "a124"
+a125 :: IO (); a125 = forever $ putStrLn "a125"
+a126 :: IO (); a126 = forever $ putStrLn "a126"
+a127 :: IO (); a127 = forever $ putStrLn "a127"
+a128 :: IO (); a128 = forever $ putStrLn "a128"
+a129 :: IO (); a129 = forever $ putStrLn "a129"
+a130 :: IO (); a130 = forever $ putStrLn "a130"
+a131 :: IO (); a131 = forever $ putStrLn "a131"
+a132 :: IO (); a132 = forever $ putStrLn "a132"
+a133 :: IO (); a133 = forever $ putStrLn "a133"
+a134 :: IO (); a134 = forever $ putStrLn "a134"
+a135 :: IO (); a135 = forever $ putStrLn "a135"
+a136 :: IO (); a136 = forever $ putStrLn "a136"
+a137 :: IO (); a137 = forever $ putStrLn "a137"
+a138 :: IO (); a138 = forever $ putStrLn "a138"
+a139 :: IO (); a139 = forever $ putStrLn "a139"
+a140 :: IO (); a140 = forever $ putStrLn "a140"
+a141 :: IO (); a141 = forever $ putStrLn "a141"
+a142 :: IO (); a142 = forever $ putStrLn "a142"
+a143 :: IO (); a143 = forever $ putStrLn "a143"
+a144 :: IO (); a144 = forever $ putStrLn "a144"
+a145 :: IO (); a145 = forever $ putStrLn "a145"
+a146 :: IO (); a146 = forever $ putStrLn "a146"
+a147 :: IO (); a147 = forever $ putStrLn "a147"
+a148 :: IO (); a148 = forever $ putStrLn "a148"
+a149 :: IO (); a149 = forever $ putStrLn "a149"
+a150 :: IO (); a150 = forever $ putStrLn "a150"
+a151 :: IO (); a151 = forever $ putStrLn "a151"
+a152 :: IO (); a152 = forever $ putStrLn "a152"
+a153 :: IO (); a153 = forever $ putStrLn "a153"
+a154 :: IO (); a154 = forever $ putStrLn "a154"
+a155 :: IO (); a155 = forever $ putStrLn "a155"
+a156 :: IO (); a156 = forever $ putStrLn "a156"
+a157 :: IO (); a157 = forever $ putStrLn "a157"
+a158 :: IO (); a158 = forever $ putStrLn "a158"
+a159 :: IO (); a159 = forever $ putStrLn "a159"
+a160 :: IO (); a160 = forever $ putStrLn "a160"
+a161 :: IO (); a161 = forever $ putStrLn "a161"
+a162 :: IO (); a162 = forever $ putStrLn "a162"
+a163 :: IO (); a163 = forever $ putStrLn "a163"
+a164 :: IO (); a164 = forever $ putStrLn "a164"
+a165 :: IO (); a165 = forever $ putStrLn "a165"
+a166 :: IO (); a166 = forever $ putStrLn "a166"
+a167 :: IO (); a167 = forever $ putStrLn "a167"
+a168 :: IO (); a168 = forever $ putStrLn "a168"
+a169 :: IO (); a169 = forever $ putStrLn "a169"
+a170 :: IO (); a170 = forever $ putStrLn "a170"
+a171 :: IO (); a171 = forever $ putStrLn "a171"
+a172 :: IO (); a172 = forever $ putStrLn "a172"
+a173 :: IO (); a173 = forever $ putStrLn "a173"
+a174 :: IO (); a174 = forever $ putStrLn "a174"
+a175 :: IO (); a175 = forever $ putStrLn "a175"
+a176 :: IO (); a176 = forever $ putStrLn "a176"
+a177 :: IO (); a177 = forever $ putStrLn "a177"
+a178 :: IO (); a178 = forever $ putStrLn "a178"
+a179 :: IO (); a179 = forever $ putStrLn "a179"
+a180 :: IO (); a180 = forever $ putStrLn "a180"
+a181 :: IO (); a181 = forever $ putStrLn "a181"
+a182 :: IO (); a182 = forever $ putStrLn "a182"
+a183 :: IO (); a183 = forever $ putStrLn "a183"
+a184 :: IO (); a184 = forever $ putStrLn "a184"
+a185 :: IO (); a185 = forever $ putStrLn "a185"
+a186 :: IO (); a186 = forever $ putStrLn "a186"
+a187 :: IO (); a187 = forever $ putStrLn "a187"
+a188 :: IO (); a188 = forever $ putStrLn "a188"
+a189 :: IO (); a189 = forever $ putStrLn "a189"
+a190 :: IO (); a190 = forever $ putStrLn "a190"
+a191 :: IO (); a191 = forever $ putStrLn "a191"
+a192 :: IO (); a192 = forever $ putStrLn "a192"
+a193 :: IO (); a193 = forever $ putStrLn "a193"
+a194 :: IO (); a194 = forever $ putStrLn "a194"
+a195 :: IO (); a195 = forever $ putStrLn "a195"
+a196 :: IO (); a196 = forever $ putStrLn "a196"
+a197 :: IO (); a197 = forever $ putStrLn "a197"
+a198 :: IO (); a198 = forever $ putStrLn "a198"
+a199 :: IO (); a199 = forever $ putStrLn "a199"
+a200 :: IO (); a200 = forever $ putStrLn "a200"
+a201 :: IO (); a201 = forever $ putStrLn "a201"
+a202 :: IO (); a202 = forever $ putStrLn "a202"
+a203 :: IO (); a203 = forever $ putStrLn "a203"
+a204 :: IO (); a204 = forever $ putStrLn "a204"
+a205 :: IO (); a205 = forever $ putStrLn "a205"
+a206 :: IO (); a206 = forever $ putStrLn "a206"
+a207 :: IO (); a207 = forever $ putStrLn "a207"
+a208 :: IO (); a208 = forever $ putStrLn "a208"
+a209 :: IO (); a209 = forever $ putStrLn "a209"
+a210 :: IO (); a210 = forever $ putStrLn "a210"
+a211 :: IO (); a211 = forever $ putStrLn "a211"
+a212 :: IO (); a212 = forever $ putStrLn "a212"
+a213 :: IO (); a213 = forever $ putStrLn "a213"
+a214 :: IO (); a214 = forever $ putStrLn "a214"
+a215 :: IO (); a215 = forever $ putStrLn "a215"
+a216 :: IO (); a216 = forever $ putStrLn "a216"
+a217 :: IO (); a217 = forever $ putStrLn "a217"
+a218 :: IO (); a218 = forever $ putStrLn "a218"
+a219 :: IO (); a219 = forever $ putStrLn "a219"
+a220 :: IO (); a220 = forever $ putStrLn "a220"
+a221 :: IO (); a221 = forever $ putStrLn "a221"
+a222 :: IO (); a222 = forever $ putStrLn "a222"
+a223 :: IO (); a223 = forever $ putStrLn "a223"
+a224 :: IO (); a224 = forever $ putStrLn "a224"
+a225 :: IO (); a225 = forever $ putStrLn "a225"
+a226 :: IO (); a226 = forever $ putStrLn "a226"
+a227 :: IO (); a227 = forever $ putStrLn "a227"
+a228 :: IO (); a228 = forever $ putStrLn "a228"
+a229 :: IO (); a229 = forever $ putStrLn "a229"
+a230 :: IO (); a230 = forever $ putStrLn "a230"
+a231 :: IO (); a231 = forever $ putStrLn "a231"
+a232 :: IO (); a232 = forever $ putStrLn "a232"
+a233 :: IO (); a233 = forever $ putStrLn "a233"
+a234 :: IO (); a234 = forever $ putStrLn "a234"
+a235 :: IO (); a235 = forever $ putStrLn "a235"
+a236 :: IO (); a236 = forever $ putStrLn "a236"
+a237 :: IO (); a237 = forever $ putStrLn "a237"
+a238 :: IO (); a238 = forever $ putStrLn "a238"
+a239 :: IO (); a239 = forever $ putStrLn "a239"
+a240 :: IO (); a240 = forever $ putStrLn "a240"
+a241 :: IO (); a241 = forever $ putStrLn "a241"
+a242 :: IO (); a242 = forever $ putStrLn "a242"
+a243 :: IO (); a243 = forever $ putStrLn "a243"
+a244 :: IO (); a244 = forever $ putStrLn "a244"
+a245 :: IO (); a245 = forever $ putStrLn "a245"
+a246 :: IO (); a246 = forever $ putStrLn "a246"
+a247 :: IO (); a247 = forever $ putStrLn "a247"
+a248 :: IO (); a248 = forever $ putStrLn "a248"
+a249 :: IO (); a249 = forever $ putStrLn "a249"
+a250 :: IO (); a250 = forever $ putStrLn "a250"
+a251 :: IO (); a251 = forever $ putStrLn "a251"
+a252 :: IO (); a252 = forever $ putStrLn "a252"
+a253 :: IO (); a253 = forever $ putStrLn "a253"
+a254 :: IO (); a254 = forever $ putStrLn "a254"
+a255 :: IO (); a255 = forever $ putStrLn "a255"
+a256 :: IO (); a256 = forever $ putStrLn "a256"
+a257 :: IO (); a257 = forever $ putStrLn "a257"
+a258 :: IO (); a258 = forever $ putStrLn "a258"
+a259 :: IO (); a259 = forever $ putStrLn "a259"
+a260 :: IO (); a260 = forever $ putStrLn "a260"
+a261 :: IO (); a261 = forever $ putStrLn "a261"
+a262 :: IO (); a262 = forever $ putStrLn "a262"
+a263 :: IO (); a263 = forever $ putStrLn "a263"
+a264 :: IO (); a264 = forever $ putStrLn "a264"
+a265 :: IO (); a265 = forever $ putStrLn "a265"
+a266 :: IO (); a266 = forever $ putStrLn "a266"
+a267 :: IO (); a267 = forever $ putStrLn "a267"
+a268 :: IO (); a268 = forever $ putStrLn "a268"
+a269 :: IO (); a269 = forever $ putStrLn "a269"
+a270 :: IO (); a270 = forever $ putStrLn "a270"
+a271 :: IO (); a271 = forever $ putStrLn "a271"
+a272 :: IO (); a272 = forever $ putStrLn "a272"
+a273 :: IO (); a273 = forever $ putStrLn "a273"
+a274 :: IO (); a274 = forever $ putStrLn "a274"
+a275 :: IO (); a275 = forever $ putStrLn "a275"
+a276 :: IO (); a276 = forever $ putStrLn "a276"
+a277 :: IO (); a277 = forever $ putStrLn "a277"
+a278 :: IO (); a278 = forever $ putStrLn "a278"
+a279 :: IO (); a279 = forever $ putStrLn "a279"
+a280 :: IO (); a280 = forever $ putStrLn "a280"
+a281 :: IO (); a281 = forever $ putStrLn "a281"
+a282 :: IO (); a282 = forever $ putStrLn "a282"
+a283 :: IO (); a283 = forever $ putStrLn "a283"
+a284 :: IO (); a284 = forever $ putStrLn "a284"
+a285 :: IO (); a285 = forever $ putStrLn "a285"
+a286 :: IO (); a286 = forever $ putStrLn "a286"
+a287 :: IO (); a287 = forever $ putStrLn "a287"
+a288 :: IO (); a288 = forever $ putStrLn "a288"
+a289 :: IO (); a289 = forever $ putStrLn "a289"
+a290 :: IO (); a290 = forever $ putStrLn "a290"
+a291 :: IO (); a291 = forever $ putStrLn "a291"
+a292 :: IO (); a292 = forever $ putStrLn "a292"
+a293 :: IO (); a293 = forever $ putStrLn "a293"
+a294 :: IO (); a294 = forever $ putStrLn "a294"
+a295 :: IO (); a295 = forever $ putStrLn "a295"
+a296 :: IO (); a296 = forever $ putStrLn "a296"
+a297 :: IO (); a297 = forever $ putStrLn "a297"
+a298 :: IO (); a298 = forever $ putStrLn "a298"
+a299 :: IO (); a299 = forever $ putStrLn "a299"
+a300 :: IO (); a300 = forever $ putStrLn "a300"
+a301 :: IO (); a301 = forever $ putStrLn "a301"
+a302 :: IO (); a302 = forever $ putStrLn "a302"
+a303 :: IO (); a303 = forever $ putStrLn "a303"
+a304 :: IO (); a304 = forever $ putStrLn "a304"
+a305 :: IO (); a305 = forever $ putStrLn "a305"
+a306 :: IO (); a306 = forever $ putStrLn "a306"
+a307 :: IO (); a307 = forever $ putStrLn "a307"
+a308 :: IO (); a308 = forever $ putStrLn "a308"
+a309 :: IO (); a309 = forever $ putStrLn "a309"
+a310 :: IO (); a310 = forever $ putStrLn "a310"
+a311 :: IO (); a311 = forever $ putStrLn "a311"
+a312 :: IO (); a312 = forever $ putStrLn "a312"
+a313 :: IO (); a313 = forever $ putStrLn "a313"
+a314 :: IO (); a314 = forever $ putStrLn "a314"
+a315 :: IO (); a315 = forever $ putStrLn "a315"
+a316 :: IO (); a316 = forever $ putStrLn "a316"
+a317 :: IO (); a317 = forever $ putStrLn "a317"
+a318 :: IO (); a318 = forever $ putStrLn "a318"
+a319 :: IO (); a319 = forever $ putStrLn "a319"
+a320 :: IO (); a320 = forever $ putStrLn "a320"
+a321 :: IO (); a321 = forever $ putStrLn "a321"
+a322 :: IO (); a322 = forever $ putStrLn "a322"
+a323 :: IO (); a323 = forever $ putStrLn "a323"
+a324 :: IO (); a324 = forever $ putStrLn "a324"
+a325 :: IO (); a325 = forever $ putStrLn "a325"
+a326 :: IO (); a326 = forever $ putStrLn "a326"
+a327 :: IO (); a327 = forever $ putStrLn "a327"
+a328 :: IO (); a328 = forever $ putStrLn "a328"
+a329 :: IO (); a329 = forever $ putStrLn "a329"
+a330 :: IO (); a330 = forever $ putStrLn "a330"
+a331 :: IO (); a331 = forever $ putStrLn "a331"
+a332 :: IO (); a332 = forever $ putStrLn "a332"
+a333 :: IO (); a333 = forever $ putStrLn "a333"
+a334 :: IO (); a334 = forever $ putStrLn "a334"
+a335 :: IO (); a335 = forever $ putStrLn "a335"
+a336 :: IO (); a336 = forever $ putStrLn "a336"
+a337 :: IO (); a337 = forever $ putStrLn "a337"
+a338 :: IO (); a338 = forever $ putStrLn "a338"
+a339 :: IO (); a339 = forever $ putStrLn "a339"
+a340 :: IO (); a340 = forever $ putStrLn "a340"
+a341 :: IO (); a341 = forever $ putStrLn "a341"
+a342 :: IO (); a342 = forever $ putStrLn "a342"
+a343 :: IO (); a343 = forever $ putStrLn "a343"
+a344 :: IO (); a344 = forever $ putStrLn "a344"
+a345 :: IO (); a345 = forever $ putStrLn "a345"
+a346 :: IO (); a346 = forever $ putStrLn "a346"
+a347 :: IO (); a347 = forever $ putStrLn "a347"
+a348 :: IO (); a348 = forever $ putStrLn "a348"
+a349 :: IO (); a349 = forever $ putStrLn "a349"
+a350 :: IO (); a350 = forever $ putStrLn "a350"
+a351 :: IO (); a351 = forever $ putStrLn "a351"
+a352 :: IO (); a352 = forever $ putStrLn "a352"
+a353 :: IO (); a353 = forever $ putStrLn "a353"
+a354 :: IO (); a354 = forever $ putStrLn "a354"
+a355 :: IO (); a355 = forever $ putStrLn "a355"
+a356 :: IO (); a356 = forever $ putStrLn "a356"
+a357 :: IO (); a357 = forever $ putStrLn "a357"
+a358 :: IO (); a358 = forever $ putStrLn "a358"
+a359 :: IO (); a359 = forever $ putStrLn "a359"
+a360 :: IO (); a360 = forever $ putStrLn "a360"
+a361 :: IO (); a361 = forever $ putStrLn "a361"
+a362 :: IO (); a362 = forever $ putStrLn "a362"
+a363 :: IO (); a363 = forever $ putStrLn "a363"
+a364 :: IO (); a364 = forever $ putStrLn "a364"
+a365 :: IO (); a365 = forever $ putStrLn "a365"
+a366 :: IO (); a366 = forever $ putStrLn "a366"
+a367 :: IO (); a367 = forever $ putStrLn "a367"
+a368 :: IO (); a368 = forever $ putStrLn "a368"
+a369 :: IO (); a369 = forever $ putStrLn "a369"
+a370 :: IO (); a370 = forever $ putStrLn "a370"
+a371 :: IO (); a371 = forever $ putStrLn "a371"
+a372 :: IO (); a372 = forever $ putStrLn "a372"
+a373 :: IO (); a373 = forever $ putStrLn "a373"
+a374 :: IO (); a374 = forever $ putStrLn "a374"
+a375 :: IO (); a375 = forever $ putStrLn "a375"
+a376 :: IO (); a376 = forever $ putStrLn "a376"
+a377 :: IO (); a377 = forever $ putStrLn "a377"
+a378 :: IO (); a378 = forever $ putStrLn "a378"
+a379 :: IO (); a379 = forever $ putStrLn "a379"
+a380 :: IO (); a380 = forever $ putStrLn "a380"
+a381 :: IO (); a381 = forever $ putStrLn "a381"
+a382 :: IO (); a382 = forever $ putStrLn "a382"
+a383 :: IO (); a383 = forever $ putStrLn "a383"
+a384 :: IO (); a384 = forever $ putStrLn "a384"
+a385 :: IO (); a385 = forever $ putStrLn "a385"
+a386 :: IO (); a386 = forever $ putStrLn "a386"
+a387 :: IO (); a387 = forever $ putStrLn "a387"
+a388 :: IO (); a388 = forever $ putStrLn "a388"
+a389 :: IO (); a389 = forever $ putStrLn "a389"
+a390 :: IO (); a390 = forever $ putStrLn "a390"
+a391 :: IO (); a391 = forever $ putStrLn "a391"
+a392 :: IO (); a392 = forever $ putStrLn "a392"
+a393 :: IO (); a393 = forever $ putStrLn "a393"
+a394 :: IO (); a394 = forever $ putStrLn "a394"
+a395 :: IO (); a395 = forever $ putStrLn "a395"
+a396 :: IO (); a396 = forever $ putStrLn "a396"
+a397 :: IO (); a397 = forever $ putStrLn "a397"
+a398 :: IO (); a398 = forever $ putStrLn "a398"
+a399 :: IO (); a399 = forever $ putStrLn "a399"
+a400 :: IO (); a400 = forever $ putStrLn "a400"
+a401 :: IO (); a401 = forever $ putStrLn "a401"
+a402 :: IO (); a402 = forever $ putStrLn "a402"
+a403 :: IO (); a403 = forever $ putStrLn "a403"
+a404 :: IO (); a404 = forever $ putStrLn "a404"
+a405 :: IO (); a405 = forever $ putStrLn "a405"
+a406 :: IO (); a406 = forever $ putStrLn "a406"
+a407 :: IO (); a407 = forever $ putStrLn "a407"
+a408 :: IO (); a408 = forever $ putStrLn "a408"
+a409 :: IO (); a409 = forever $ putStrLn "a409"
+a410 :: IO (); a410 = forever $ putStrLn "a410"
+a411 :: IO (); a411 = forever $ putStrLn "a411"
+a412 :: IO (); a412 = forever $ putStrLn "a412"
+a413 :: IO (); a413 = forever $ putStrLn "a413"
+a414 :: IO (); a414 = forever $ putStrLn "a414"
+a415 :: IO (); a415 = forever $ putStrLn "a415"
+a416 :: IO (); a416 = forever $ putStrLn "a416"
+a417 :: IO (); a417 = forever $ putStrLn "a417"
+a418 :: IO (); a418 = forever $ putStrLn "a418"
+a419 :: IO (); a419 = forever $ putStrLn "a419"
+a420 :: IO (); a420 = forever $ putStrLn "a420"
+a421 :: IO (); a421 = forever $ putStrLn "a421"
+a422 :: IO (); a422 = forever $ putStrLn "a422"
+a423 :: IO (); a423 = forever $ putStrLn "a423"
+a424 :: IO (); a424 = forever $ putStrLn "a424"
+a425 :: IO (); a425 = forever $ putStrLn "a425"
+a426 :: IO (); a426 = forever $ putStrLn "a426"
+a427 :: IO (); a427 = forever $ putStrLn "a427"
+a428 :: IO (); a428 = forever $ putStrLn "a428"
+a429 :: IO (); a429 = forever $ putStrLn "a429"
+a430 :: IO (); a430 = forever $ putStrLn "a430"
+a431 :: IO (); a431 = forever $ putStrLn "a431"
+a432 :: IO (); a432 = forever $ putStrLn "a432"
+a433 :: IO (); a433 = forever $ putStrLn "a433"
+a434 :: IO (); a434 = forever $ putStrLn "a434"
+a435 :: IO (); a435 = forever $ putStrLn "a435"
+a436 :: IO (); a436 = forever $ putStrLn "a436"
+a437 :: IO (); a437 = forever $ putStrLn "a437"
+a438 :: IO (); a438 = forever $ putStrLn "a438"
+a439 :: IO (); a439 = forever $ putStrLn "a439"
+a440 :: IO (); a440 = forever $ putStrLn "a440"
+a441 :: IO (); a441 = forever $ putStrLn "a441"
+a442 :: IO (); a442 = forever $ putStrLn "a442"
+a443 :: IO (); a443 = forever $ putStrLn "a443"
+a444 :: IO (); a444 = forever $ putStrLn "a444"
+a445 :: IO (); a445 = forever $ putStrLn "a445"
+a446 :: IO (); a446 = forever $ putStrLn "a446"
+a447 :: IO (); a447 = forever $ putStrLn "a447"
+a448 :: IO (); a448 = forever $ putStrLn "a448"
+a449 :: IO (); a449 = forever $ putStrLn "a449"
+a450 :: IO (); a450 = forever $ putStrLn "a450"
+a451 :: IO (); a451 = forever $ putStrLn "a451"
+a452 :: IO (); a452 = forever $ putStrLn "a452"
+a453 :: IO (); a453 = forever $ putStrLn "a453"
+a454 :: IO (); a454 = forever $ putStrLn "a454"
+a455 :: IO (); a455 = forever $ putStrLn "a455"
+a456 :: IO (); a456 = forever $ putStrLn "a456"
+a457 :: IO (); a457 = forever $ putStrLn "a457"
+a458 :: IO (); a458 = forever $ putStrLn "a458"
+a459 :: IO (); a459 = forever $ putStrLn "a459"
+a460 :: IO (); a460 = forever $ putStrLn "a460"
+a461 :: IO (); a461 = forever $ putStrLn "a461"
+a462 :: IO (); a462 = forever $ putStrLn "a462"
+a463 :: IO (); a463 = forever $ putStrLn "a463"
+a464 :: IO (); a464 = forever $ putStrLn "a464"
+a465 :: IO (); a465 = forever $ putStrLn "a465"
+a466 :: IO (); a466 = forever $ putStrLn "a466"
+a467 :: IO (); a467 = forever $ putStrLn "a467"
+a468 :: IO (); a468 = forever $ putStrLn "a468"
+a469 :: IO (); a469 = forever $ putStrLn "a469"
+a470 :: IO (); a470 = forever $ putStrLn "a470"
+a471 :: IO (); a471 = forever $ putStrLn "a471"
+a472 :: IO (); a472 = forever $ putStrLn "a472"
+a473 :: IO (); a473 = forever $ putStrLn "a473"
+a474 :: IO (); a474 = forever $ putStrLn "a474"
+a475 :: IO (); a475 = forever $ putStrLn "a475"
+a476 :: IO (); a476 = forever $ putStrLn "a476"
+a477 :: IO (); a477 = forever $ putStrLn "a477"
+a478 :: IO (); a478 = forever $ putStrLn "a478"
+a479 :: IO (); a479 = forever $ putStrLn "a479"
+a480 :: IO (); a480 = forever $ putStrLn "a480"
+a481 :: IO (); a481 = forever $ putStrLn "a481"
+a482 :: IO (); a482 = forever $ putStrLn "a482"
+a483 :: IO (); a483 = forever $ putStrLn "a483"
+a484 :: IO (); a484 = forever $ putStrLn "a484"
+a485 :: IO (); a485 = forever $ putStrLn "a485"
+a486 :: IO (); a486 = forever $ putStrLn "a486"
+a487 :: IO (); a487 = forever $ putStrLn "a487"
+a488 :: IO (); a488 = forever $ putStrLn "a488"
+a489 :: IO (); a489 = forever $ putStrLn "a489"
+a490 :: IO (); a490 = forever $ putStrLn "a490"
+a491 :: IO (); a491 = forever $ putStrLn "a491"
+a492 :: IO (); a492 = forever $ putStrLn "a492"
+a493 :: IO (); a493 = forever $ putStrLn "a493"
+a494 :: IO (); a494 = forever $ putStrLn "a494"
+a495 :: IO (); a495 = forever $ putStrLn "a495"
+a496 :: IO (); a496 = forever $ putStrLn "a496"
+a497 :: IO (); a497 = forever $ putStrLn "a497"
+a498 :: IO (); a498 = forever $ putStrLn "a498"
+a499 :: IO (); a499 = forever $ putStrLn "a499"
+a500 :: IO (); a500 = forever $ putStrLn "a500"
+a501 :: IO (); a501 = forever $ putStrLn "a501"
+a502 :: IO (); a502 = forever $ putStrLn "a502"
+a503 :: IO (); a503 = forever $ putStrLn "a503"
+a504 :: IO (); a504 = forever $ putStrLn "a504"
+a505 :: IO (); a505 = forever $ putStrLn "a505"
+a506 :: IO (); a506 = forever $ putStrLn "a506"
+a507 :: IO (); a507 = forever $ putStrLn "a507"
+a508 :: IO (); a508 = forever $ putStrLn "a508"
+a509 :: IO (); a509 = forever $ putStrLn "a509"
+a510 :: IO (); a510 = forever $ putStrLn "a510"
+a511 :: IO (); a511 = forever $ putStrLn "a511"
+a512 :: IO (); a512 = forever $ putStrLn "a512"
+a513 :: IO (); a513 = forever $ putStrLn "a513"
+a514 :: IO (); a514 = forever $ putStrLn "a514"
+a515 :: IO (); a515 = forever $ putStrLn "a515"
+a516 :: IO (); a516 = forever $ putStrLn "a516"
+a517 :: IO (); a517 = forever $ putStrLn "a517"
+a518 :: IO (); a518 = forever $ putStrLn "a518"
+a519 :: IO (); a519 = forever $ putStrLn "a519"
+a520 :: IO (); a520 = forever $ putStrLn "a520"
+a521 :: IO (); a521 = forever $ putStrLn "a521"
+a522 :: IO (); a522 = forever $ putStrLn "a522"
+a523 :: IO (); a523 = forever $ putStrLn "a523"
+a524 :: IO (); a524 = forever $ putStrLn "a524"
+a525 :: IO (); a525 = forever $ putStrLn "a525"
+a526 :: IO (); a526 = forever $ putStrLn "a526"
+a527 :: IO (); a527 = forever $ putStrLn "a527"
+a528 :: IO (); a528 = forever $ putStrLn "a528"
+a529 :: IO (); a529 = forever $ putStrLn "a529"
+a530 :: IO (); a530 = forever $ putStrLn "a530"
+a531 :: IO (); a531 = forever $ putStrLn "a531"
+a532 :: IO (); a532 = forever $ putStrLn "a532"
+a533 :: IO (); a533 = forever $ putStrLn "a533"
+a534 :: IO (); a534 = forever $ putStrLn "a534"
+a535 :: IO (); a535 = forever $ putStrLn "a535"
+a536 :: IO (); a536 = forever $ putStrLn "a536"
+a537 :: IO (); a537 = forever $ putStrLn "a537"
+a538 :: IO (); a538 = forever $ putStrLn "a538"
+a539 :: IO (); a539 = forever $ putStrLn "a539"
+a540 :: IO (); a540 = forever $ putStrLn "a540"
+a541 :: IO (); a541 = forever $ putStrLn "a541"
+a542 :: IO (); a542 = forever $ putStrLn "a542"
+a543 :: IO (); a543 = forever $ putStrLn "a543"
+a544 :: IO (); a544 = forever $ putStrLn "a544"
+a545 :: IO (); a545 = forever $ putStrLn "a545"
+a546 :: IO (); a546 = forever $ putStrLn "a546"
+a547 :: IO (); a547 = forever $ putStrLn "a547"
+a548 :: IO (); a548 = forever $ putStrLn "a548"
+a549 :: IO (); a549 = forever $ putStrLn "a549"
+a550 :: IO (); a550 = forever $ putStrLn "a550"
+a551 :: IO (); a551 = forever $ putStrLn "a551"
+a552 :: IO (); a552 = forever $ putStrLn "a552"
+a553 :: IO (); a553 = forever $ putStrLn "a553"
+a554 :: IO (); a554 = forever $ putStrLn "a554"
+a555 :: IO (); a555 = forever $ putStrLn "a555"
+a556 :: IO (); a556 = forever $ putStrLn "a556"
+a557 :: IO (); a557 = forever $ putStrLn "a557"
+a558 :: IO (); a558 = forever $ putStrLn "a558"
+a559 :: IO (); a559 = forever $ putStrLn "a559"
+a560 :: IO (); a560 = forever $ putStrLn "a560"
+a561 :: IO (); a561 = forever $ putStrLn "a561"
+a562 :: IO (); a562 = forever $ putStrLn "a562"
+a563 :: IO (); a563 = forever $ putStrLn "a563"
+a564 :: IO (); a564 = forever $ putStrLn "a564"
+a565 :: IO (); a565 = forever $ putStrLn "a565"
+a566 :: IO (); a566 = forever $ putStrLn "a566"
+a567 :: IO (); a567 = forever $ putStrLn "a567"
+a568 :: IO (); a568 = forever $ putStrLn "a568"
+a569 :: IO (); a569 = forever $ putStrLn "a569"
+a570 :: IO (); a570 = forever $ putStrLn "a570"
+a571 :: IO (); a571 = forever $ putStrLn "a571"
+a572 :: IO (); a572 = forever $ putStrLn "a572"
+a573 :: IO (); a573 = forever $ putStrLn "a573"
+a574 :: IO (); a574 = forever $ putStrLn "a574"
+a575 :: IO (); a575 = forever $ putStrLn "a575"
+a576 :: IO (); a576 = forever $ putStrLn "a576"
+a577 :: IO (); a577 = forever $ putStrLn "a577"
+a578 :: IO (); a578 = forever $ putStrLn "a578"
+a579 :: IO (); a579 = forever $ putStrLn "a579"
+a580 :: IO (); a580 = forever $ putStrLn "a580"
+a581 :: IO (); a581 = forever $ putStrLn "a581"
+a582 :: IO (); a582 = forever $ putStrLn "a582"
+a583 :: IO (); a583 = forever $ putStrLn "a583"
+a584 :: IO (); a584 = forever $ putStrLn "a584"
+a585 :: IO (); a585 = forever $ putStrLn "a585"
+a586 :: IO (); a586 = forever $ putStrLn "a586"
+a587 :: IO (); a587 = forever $ putStrLn "a587"
+a588 :: IO (); a588 = forever $ putStrLn "a588"
+a589 :: IO (); a589 = forever $ putStrLn "a589"
+a590 :: IO (); a590 = forever $ putStrLn "a590"
+a591 :: IO (); a591 = forever $ putStrLn "a591"
+a592 :: IO (); a592 = forever $ putStrLn "a592"
+a593 :: IO (); a593 = forever $ putStrLn "a593"
+a594 :: IO (); a594 = forever $ putStrLn "a594"
+a595 :: IO (); a595 = forever $ putStrLn "a595"
+a596 :: IO (); a596 = forever $ putStrLn "a596"
+a597 :: IO (); a597 = forever $ putStrLn "a597"
+a598 :: IO (); a598 = forever $ putStrLn "a598"
+a599 :: IO (); a599 = forever $ putStrLn "a599"
+a600 :: IO (); a600 = forever $ putStrLn "a600"
+a601 :: IO (); a601 = forever $ putStrLn "a601"
+a602 :: IO (); a602 = forever $ putStrLn "a602"
+a603 :: IO (); a603 = forever $ putStrLn "a603"
+a604 :: IO (); a604 = forever $ putStrLn "a604"
+a605 :: IO (); a605 = forever $ putStrLn "a605"
+a606 :: IO (); a606 = forever $ putStrLn "a606"
+a607 :: IO (); a607 = forever $ putStrLn "a607"
+a608 :: IO (); a608 = forever $ putStrLn "a608"
+a609 :: IO (); a609 = forever $ putStrLn "a609"
+a610 :: IO (); a610 = forever $ putStrLn "a610"
+a611 :: IO (); a611 = forever $ putStrLn "a611"
+a612 :: IO (); a612 = forever $ putStrLn "a612"
+a613 :: IO (); a613 = forever $ putStrLn "a613"
+a614 :: IO (); a614 = forever $ putStrLn "a614"
+a615 :: IO (); a615 = forever $ putStrLn "a615"
+a616 :: IO (); a616 = forever $ putStrLn "a616"
+a617 :: IO (); a617 = forever $ putStrLn "a617"
+a618 :: IO (); a618 = forever $ putStrLn "a618"
+a619 :: IO (); a619 = forever $ putStrLn "a619"
+a620 :: IO (); a620 = forever $ putStrLn "a620"
+a621 :: IO (); a621 = forever $ putStrLn "a621"
+a622 :: IO (); a622 = forever $ putStrLn "a622"
+a623 :: IO (); a623 = forever $ putStrLn "a623"
+a624 :: IO (); a624 = forever $ putStrLn "a624"
+a625 :: IO (); a625 = forever $ putStrLn "a625"
+a626 :: IO (); a626 = forever $ putStrLn "a626"
+a627 :: IO (); a627 = forever $ putStrLn "a627"
+a628 :: IO (); a628 = forever $ putStrLn "a628"
+a629 :: IO (); a629 = forever $ putStrLn "a629"
+a630 :: IO (); a630 = forever $ putStrLn "a630"
+a631 :: IO (); a631 = forever $ putStrLn "a631"
+a632 :: IO (); a632 = forever $ putStrLn "a632"
+a633 :: IO (); a633 = forever $ putStrLn "a633"
+a634 :: IO (); a634 = forever $ putStrLn "a634"
+a635 :: IO (); a635 = forever $ putStrLn "a635"
+a636 :: IO (); a636 = forever $ putStrLn "a636"
+a637 :: IO (); a637 = forever $ putStrLn "a637"
+a638 :: IO (); a638 = forever $ putStrLn "a638"
+a639 :: IO (); a639 = forever $ putStrLn "a639"
+a640 :: IO (); a640 = forever $ putStrLn "a640"
+a641 :: IO (); a641 = forever $ putStrLn "a641"
+a642 :: IO (); a642 = forever $ putStrLn "a642"
+a643 :: IO (); a643 = forever $ putStrLn "a643"
+a644 :: IO (); a644 = forever $ putStrLn "a644"
+a645 :: IO (); a645 = forever $ putStrLn "a645"
+a646 :: IO (); a646 = forever $ putStrLn "a646"
+a647 :: IO (); a647 = forever $ putStrLn "a647"
+a648 :: IO (); a648 = forever $ putStrLn "a648"
+a649 :: IO (); a649 = forever $ putStrLn "a649"
+a650 :: IO (); a650 = forever $ putStrLn "a650"
+a651 :: IO (); a651 = forever $ putStrLn "a651"
+a652 :: IO (); a652 = forever $ putStrLn "a652"
+a653 :: IO (); a653 = forever $ putStrLn "a653"
+a654 :: IO (); a654 = forever $ putStrLn "a654"
+a655 :: IO (); a655 = forever $ putStrLn "a655"
+a656 :: IO (); a656 = forever $ putStrLn "a656"
+a657 :: IO (); a657 = forever $ putStrLn "a657"
+a658 :: IO (); a658 = forever $ putStrLn "a658"
+a659 :: IO (); a659 = forever $ putStrLn "a659"
+a660 :: IO (); a660 = forever $ putStrLn "a660"
+a661 :: IO (); a661 = forever $ putStrLn "a661"
+a662 :: IO (); a662 = forever $ putStrLn "a662"
+a663 :: IO (); a663 = forever $ putStrLn "a663"
+a664 :: IO (); a664 = forever $ putStrLn "a664"
+a665 :: IO (); a665 = forever $ putStrLn "a665"
+a666 :: IO (); a666 = forever $ putStrLn "a666"
+a667 :: IO (); a667 = forever $ putStrLn "a667"
+a668 :: IO (); a668 = forever $ putStrLn "a668"
+a669 :: IO (); a669 = forever $ putStrLn "a669"
+a670 :: IO (); a670 = forever $ putStrLn "a670"
+a671 :: IO (); a671 = forever $ putStrLn "a671"
+a672 :: IO (); a672 = forever $ putStrLn "a672"
+a673 :: IO (); a673 = forever $ putStrLn "a673"
+a674 :: IO (); a674 = forever $ putStrLn "a674"
+a675 :: IO (); a675 = forever $ putStrLn "a675"
+a676 :: IO (); a676 = forever $ putStrLn "a676"
+a677 :: IO (); a677 = forever $ putStrLn "a677"
+a678 :: IO (); a678 = forever $ putStrLn "a678"
+a679 :: IO (); a679 = forever $ putStrLn "a679"
+a680 :: IO (); a680 = forever $ putStrLn "a680"
+a681 :: IO (); a681 = forever $ putStrLn "a681"
+a682 :: IO (); a682 = forever $ putStrLn "a682"
+a683 :: IO (); a683 = forever $ putStrLn "a683"
+a684 :: IO (); a684 = forever $ putStrLn "a684"
+a685 :: IO (); a685 = forever $ putStrLn "a685"
+a686 :: IO (); a686 = forever $ putStrLn "a686"
+a687 :: IO (); a687 = forever $ putStrLn "a687"
+a688 :: IO (); a688 = forever $ putStrLn "a688"
+a689 :: IO (); a689 = forever $ putStrLn "a689"
+a690 :: IO (); a690 = forever $ putStrLn "a690"
+a691 :: IO (); a691 = forever $ putStrLn "a691"
+a692 :: IO (); a692 = forever $ putStrLn "a692"
+a693 :: IO (); a693 = forever $ putStrLn "a693"
+a694 :: IO (); a694 = forever $ putStrLn "a694"
+a695 :: IO (); a695 = forever $ putStrLn "a695"
+a696 :: IO (); a696 = forever $ putStrLn "a696"
+a697 :: IO (); a697 = forever $ putStrLn "a697"
+a698 :: IO (); a698 = forever $ putStrLn "a698"
+a699 :: IO (); a699 = forever $ putStrLn "a699"
+a700 :: IO (); a700 = forever $ putStrLn "a700"
+a701 :: IO (); a701 = forever $ putStrLn "a701"
+a702 :: IO (); a702 = forever $ putStrLn "a702"
+a703 :: IO (); a703 = forever $ putStrLn "a703"
+a704 :: IO (); a704 = forever $ putStrLn "a704"
+a705 :: IO (); a705 = forever $ putStrLn "a705"
+a706 :: IO (); a706 = forever $ putStrLn "a706"
+a707 :: IO (); a707 = forever $ putStrLn "a707"
+a708 :: IO (); a708 = forever $ putStrLn "a708"
+a709 :: IO (); a709 = forever $ putStrLn "a709"
+a710 :: IO (); a710 = forever $ putStrLn "a710"
+a711 :: IO (); a711 = forever $ putStrLn "a711"
+a712 :: IO (); a712 = forever $ putStrLn "a712"
+a713 :: IO (); a713 = forever $ putStrLn "a713"
+a714 :: IO (); a714 = forever $ putStrLn "a714"
+a715 :: IO (); a715 = forever $ putStrLn "a715"
+a716 :: IO (); a716 = forever $ putStrLn "a716"
+a717 :: IO (); a717 = forever $ putStrLn "a717"
+a718 :: IO (); a718 = forever $ putStrLn "a718"
+a719 :: IO (); a719 = forever $ putStrLn "a719"
+a720 :: IO (); a720 = forever $ putStrLn "a720"
+a721 :: IO (); a721 = forever $ putStrLn "a721"
+a722 :: IO (); a722 = forever $ putStrLn "a722"
+a723 :: IO (); a723 = forever $ putStrLn "a723"
+a724 :: IO (); a724 = forever $ putStrLn "a724"
+a725 :: IO (); a725 = forever $ putStrLn "a725"
+a726 :: IO (); a726 = forever $ putStrLn "a726"
+a727 :: IO (); a727 = forever $ putStrLn "a727"
+a728 :: IO (); a728 = forever $ putStrLn "a728"
+a729 :: IO (); a729 = forever $ putStrLn "a729"
+a730 :: IO (); a730 = forever $ putStrLn "a730"
+a731 :: IO (); a731 = forever $ putStrLn "a731"
+a732 :: IO (); a732 = forever $ putStrLn "a732"
+a733 :: IO (); a733 = forever $ putStrLn "a733"
+a734 :: IO (); a734 = forever $ putStrLn "a734"
+a735 :: IO (); a735 = forever $ putStrLn "a735"
+a736 :: IO (); a736 = forever $ putStrLn "a736"
+a737 :: IO (); a737 = forever $ putStrLn "a737"
+a738 :: IO (); a738 = forever $ putStrLn "a738"
+a739 :: IO (); a739 = forever $ putStrLn "a739"
+a740 :: IO (); a740 = forever $ putStrLn "a740"
+a741 :: IO (); a741 = forever $ putStrLn "a741"
+a742 :: IO (); a742 = forever $ putStrLn "a742"
+a743 :: IO (); a743 = forever $ putStrLn "a743"
+a744 :: IO (); a744 = forever $ putStrLn "a744"
+a745 :: IO (); a745 = forever $ putStrLn "a745"
+a746 :: IO (); a746 = forever $ putStrLn "a746"
+a747 :: IO (); a747 = forever $ putStrLn "a747"
+a748 :: IO (); a748 = forever $ putStrLn "a748"
+a749 :: IO (); a749 = forever $ putStrLn "a749"
+a750 :: IO (); a750 = forever $ putStrLn "a750"
+a751 :: IO (); a751 = forever $ putStrLn "a751"
+a752 :: IO (); a752 = forever $ putStrLn "a752"
+a753 :: IO (); a753 = forever $ putStrLn "a753"
+a754 :: IO (); a754 = forever $ putStrLn "a754"
+a755 :: IO (); a755 = forever $ putStrLn "a755"
+a756 :: IO (); a756 = forever $ putStrLn "a756"
+a757 :: IO (); a757 = forever $ putStrLn "a757"
+a758 :: IO (); a758 = forever $ putStrLn "a758"
+a759 :: IO (); a759 = forever $ putStrLn "a759"
+a760 :: IO (); a760 = forever $ putStrLn "a760"
+a761 :: IO (); a761 = forever $ putStrLn "a761"
+a762 :: IO (); a762 = forever $ putStrLn "a762"
+a763 :: IO (); a763 = forever $ putStrLn "a763"
+a764 :: IO (); a764 = forever $ putStrLn "a764"
+a765 :: IO (); a765 = forever $ putStrLn "a765"
+a766 :: IO (); a766 = forever $ putStrLn "a766"
+a767 :: IO (); a767 = forever $ putStrLn "a767"
+a768 :: IO (); a768 = forever $ putStrLn "a768"
+a769 :: IO (); a769 = forever $ putStrLn "a769"
+a770 :: IO (); a770 = forever $ putStrLn "a770"
+a771 :: IO (); a771 = forever $ putStrLn "a771"
+a772 :: IO (); a772 = forever $ putStrLn "a772"
+a773 :: IO (); a773 = forever $ putStrLn "a773"
+a774 :: IO (); a774 = forever $ putStrLn "a774"
+a775 :: IO (); a775 = forever $ putStrLn "a775"
+a776 :: IO (); a776 = forever $ putStrLn "a776"
+a777 :: IO (); a777 = forever $ putStrLn "a777"
+a778 :: IO (); a778 = forever $ putStrLn "a778"
+a779 :: IO (); a779 = forever $ putStrLn "a779"
+a780 :: IO (); a780 = forever $ putStrLn "a780"
+a781 :: IO (); a781 = forever $ putStrLn "a781"
+a782 :: IO (); a782 = forever $ putStrLn "a782"
+a783 :: IO (); a783 = forever $ putStrLn "a783"
+a784 :: IO (); a784 = forever $ putStrLn "a784"
+a785 :: IO (); a785 = forever $ putStrLn "a785"
+a786 :: IO (); a786 = forever $ putStrLn "a786"
+a787 :: IO (); a787 = forever $ putStrLn "a787"
+a788 :: IO (); a788 = forever $ putStrLn "a788"
+a789 :: IO (); a789 = forever $ putStrLn "a789"
+a790 :: IO (); a790 = forever $ putStrLn "a790"
+a791 :: IO (); a791 = forever $ putStrLn "a791"
+a792 :: IO (); a792 = forever $ putStrLn "a792"
+a793 :: IO (); a793 = forever $ putStrLn "a793"
+a794 :: IO (); a794 = forever $ putStrLn "a794"
+a795 :: IO (); a795 = forever $ putStrLn "a795"
+a796 :: IO (); a796 = forever $ putStrLn "a796"
+a797 :: IO (); a797 = forever $ putStrLn "a797"
+a798 :: IO (); a798 = forever $ putStrLn "a798"
+a799 :: IO (); a799 = forever $ putStrLn "a799"
+a800 :: IO (); a800 = forever $ putStrLn "a800"
+a801 :: IO (); a801 = forever $ putStrLn "a801"
+a802 :: IO (); a802 = forever $ putStrLn "a802"
+a803 :: IO (); a803 = forever $ putStrLn "a803"
+a804 :: IO (); a804 = forever $ putStrLn "a804"
+a805 :: IO (); a805 = forever $ putStrLn "a805"
+a806 :: IO (); a806 = forever $ putStrLn "a806"
+a807 :: IO (); a807 = forever $ putStrLn "a807"
+a808 :: IO (); a808 = forever $ putStrLn "a808"
+a809 :: IO (); a809 = forever $ putStrLn "a809"
+a810 :: IO (); a810 = forever $ putStrLn "a810"
+a811 :: IO (); a811 = forever $ putStrLn "a811"
+a812 :: IO (); a812 = forever $ putStrLn "a812"
+a813 :: IO (); a813 = forever $ putStrLn "a813"
+a814 :: IO (); a814 = forever $ putStrLn "a814"
+a815 :: IO (); a815 = forever $ putStrLn "a815"
+a816 :: IO (); a816 = forever $ putStrLn "a816"
+a817 :: IO (); a817 = forever $ putStrLn "a817"
+a818 :: IO (); a818 = forever $ putStrLn "a818"
+a819 :: IO (); a819 = forever $ putStrLn "a819"
+a820 :: IO (); a820 = forever $ putStrLn "a820"
+a821 :: IO (); a821 = forever $ putStrLn "a821"
+a822 :: IO (); a822 = forever $ putStrLn "a822"
+a823 :: IO (); a823 = forever $ putStrLn "a823"
+a824 :: IO (); a824 = forever $ putStrLn "a824"
+a825 :: IO (); a825 = forever $ putStrLn "a825"
+a826 :: IO (); a826 = forever $ putStrLn "a826"
+a827 :: IO (); a827 = forever $ putStrLn "a827"
+a828 :: IO (); a828 = forever $ putStrLn "a828"
+a829 :: IO (); a829 = forever $ putStrLn "a829"
+a830 :: IO (); a830 = forever $ putStrLn "a830"
+a831 :: IO (); a831 = forever $ putStrLn "a831"
+a832 :: IO (); a832 = forever $ putStrLn "a832"
+a833 :: IO (); a833 = forever $ putStrLn "a833"
+a834 :: IO (); a834 = forever $ putStrLn "a834"
+a835 :: IO (); a835 = forever $ putStrLn "a835"
+a836 :: IO (); a836 = forever $ putStrLn "a836"
+a837 :: IO (); a837 = forever $ putStrLn "a837"
+a838 :: IO (); a838 = forever $ putStrLn "a838"
+a839 :: IO (); a839 = forever $ putStrLn "a839"
+a840 :: IO (); a840 = forever $ putStrLn "a840"
+a841 :: IO (); a841 = forever $ putStrLn "a841"
+a842 :: IO (); a842 = forever $ putStrLn "a842"
+a843 :: IO (); a843 = forever $ putStrLn "a843"
+a844 :: IO (); a844 = forever $ putStrLn "a844"
+a845 :: IO (); a845 = forever $ putStrLn "a845"
+a846 :: IO (); a846 = forever $ putStrLn "a846"
+a847 :: IO (); a847 = forever $ putStrLn "a847"
+a848 :: IO (); a848 = forever $ putStrLn "a848"
+a849 :: IO (); a849 = forever $ putStrLn "a849"
+a850 :: IO (); a850 = forever $ putStrLn "a850"
+a851 :: IO (); a851 = forever $ putStrLn "a851"
+a852 :: IO (); a852 = forever $ putStrLn "a852"
+a853 :: IO (); a853 = forever $ putStrLn "a853"
+a854 :: IO (); a854 = forever $ putStrLn "a854"
+a855 :: IO (); a855 = forever $ putStrLn "a855"
+a856 :: IO (); a856 = forever $ putStrLn "a856"
+a857 :: IO (); a857 = forever $ putStrLn "a857"
+a858 :: IO (); a858 = forever $ putStrLn "a858"
+a859 :: IO (); a859 = forever $ putStrLn "a859"
+a860 :: IO (); a860 = forever $ putStrLn "a860"
+a861 :: IO (); a861 = forever $ putStrLn "a861"
+a862 :: IO (); a862 = forever $ putStrLn "a862"
+a863 :: IO (); a863 = forever $ putStrLn "a863"
+a864 :: IO (); a864 = forever $ putStrLn "a864"
+a865 :: IO (); a865 = forever $ putStrLn "a865"
+a866 :: IO (); a866 = forever $ putStrLn "a866"
+a867 :: IO (); a867 = forever $ putStrLn "a867"
+a868 :: IO (); a868 = forever $ putStrLn "a868"
+a869 :: IO (); a869 = forever $ putStrLn "a869"
+a870 :: IO (); a870 = forever $ putStrLn "a870"
+a871 :: IO (); a871 = forever $ putStrLn "a871"
+a872 :: IO (); a872 = forever $ putStrLn "a872"
+a873 :: IO (); a873 = forever $ putStrLn "a873"
+a874 :: IO (); a874 = forever $ putStrLn "a874"
+a875 :: IO (); a875 = forever $ putStrLn "a875"
+a876 :: IO (); a876 = forever $ putStrLn "a876"
+a877 :: IO (); a877 = forever $ putStrLn "a877"
+a878 :: IO (); a878 = forever $ putStrLn "a878"
+a879 :: IO (); a879 = forever $ putStrLn "a879"
+a880 :: IO (); a880 = forever $ putStrLn "a880"
+a881 :: IO (); a881 = forever $ putStrLn "a881"
+a882 :: IO (); a882 = forever $ putStrLn "a882"
+a883 :: IO (); a883 = forever $ putStrLn "a883"
+a884 :: IO (); a884 = forever $ putStrLn "a884"
+a885 :: IO (); a885 = forever $ putStrLn "a885"
+a886 :: IO (); a886 = forever $ putStrLn "a886"
+a887 :: IO (); a887 = forever $ putStrLn "a887"
+a888 :: IO (); a888 = forever $ putStrLn "a888"
+a889 :: IO (); a889 = forever $ putStrLn "a889"
+a890 :: IO (); a890 = forever $ putStrLn "a890"
+a891 :: IO (); a891 = forever $ putStrLn "a891"
+a892 :: IO (); a892 = forever $ putStrLn "a892"
+a893 :: IO (); a893 = forever $ putStrLn "a893"
+a894 :: IO (); a894 = forever $ putStrLn "a894"
+a895 :: IO (); a895 = forever $ putStrLn "a895"
+a896 :: IO (); a896 = forever $ putStrLn "a896"
+a897 :: IO (); a897 = forever $ putStrLn "a897"
+a898 :: IO (); a898 = forever $ putStrLn "a898"
+a899 :: IO (); a899 = forever $ putStrLn "a899"
+a900 :: IO (); a900 = forever $ putStrLn "a900"
+a901 :: IO (); a901 = forever $ putStrLn "a901"
+a902 :: IO (); a902 = forever $ putStrLn "a902"
+a903 :: IO (); a903 = forever $ putStrLn "a903"
+a904 :: IO (); a904 = forever $ putStrLn "a904"
+a905 :: IO (); a905 = forever $ putStrLn "a905"
+a906 :: IO (); a906 = forever $ putStrLn "a906"
+a907 :: IO (); a907 = forever $ putStrLn "a907"
+a908 :: IO (); a908 = forever $ putStrLn "a908"
+a909 :: IO (); a909 = forever $ putStrLn "a909"
+a910 :: IO (); a910 = forever $ putStrLn "a910"
+a911 :: IO (); a911 = forever $ putStrLn "a911"
+a912 :: IO (); a912 = forever $ putStrLn "a912"
+a913 :: IO (); a913 = forever $ putStrLn "a913"
+a914 :: IO (); a914 = forever $ putStrLn "a914"
+a915 :: IO (); a915 = forever $ putStrLn "a915"
+a916 :: IO (); a916 = forever $ putStrLn "a916"
+a917 :: IO (); a917 = forever $ putStrLn "a917"
+a918 :: IO (); a918 = forever $ putStrLn "a918"
+a919 :: IO (); a919 = forever $ putStrLn "a919"
+a920 :: IO (); a920 = forever $ putStrLn "a920"
+a921 :: IO (); a921 = forever $ putStrLn "a921"
+a922 :: IO (); a922 = forever $ putStrLn "a922"
+a923 :: IO (); a923 = forever $ putStrLn "a923"
+a924 :: IO (); a924 = forever $ putStrLn "a924"
+a925 :: IO (); a925 = forever $ putStrLn "a925"
+a926 :: IO (); a926 = forever $ putStrLn "a926"
+a927 :: IO (); a927 = forever $ putStrLn "a927"
+a928 :: IO (); a928 = forever $ putStrLn "a928"
+a929 :: IO (); a929 = forever $ putStrLn "a929"
+a930 :: IO (); a930 = forever $ putStrLn "a930"
+a931 :: IO (); a931 = forever $ putStrLn "a931"
+a932 :: IO (); a932 = forever $ putStrLn "a932"
+a933 :: IO (); a933 = forever $ putStrLn "a933"
+a934 :: IO (); a934 = forever $ putStrLn "a934"
+a935 :: IO (); a935 = forever $ putStrLn "a935"
+a936 :: IO (); a936 = forever $ putStrLn "a936"
+a937 :: IO (); a937 = forever $ putStrLn "a937"
+a938 :: IO (); a938 = forever $ putStrLn "a938"
+a939 :: IO (); a939 = forever $ putStrLn "a939"
+a940 :: IO (); a940 = forever $ putStrLn "a940"
+a941 :: IO (); a941 = forever $ putStrLn "a941"
+a942 :: IO (); a942 = forever $ putStrLn "a942"
+a943 :: IO (); a943 = forever $ putStrLn "a943"
+a944 :: IO (); a944 = forever $ putStrLn "a944"
+a945 :: IO (); a945 = forever $ putStrLn "a945"
+a946 :: IO (); a946 = forever $ putStrLn "a946"
+a947 :: IO (); a947 = forever $ putStrLn "a947"
+a948 :: IO (); a948 = forever $ putStrLn "a948"
+a949 :: IO (); a949 = forever $ putStrLn "a949"
+a950 :: IO (); a950 = forever $ putStrLn "a950"
+a951 :: IO (); a951 = forever $ putStrLn "a951"
+a952 :: IO (); a952 = forever $ putStrLn "a952"
+a953 :: IO (); a953 = forever $ putStrLn "a953"
+a954 :: IO (); a954 = forever $ putStrLn "a954"
+a955 :: IO (); a955 = forever $ putStrLn "a955"
+a956 :: IO (); a956 = forever $ putStrLn "a956"
+a957 :: IO (); a957 = forever $ putStrLn "a957"
+a958 :: IO (); a958 = forever $ putStrLn "a958"
+a959 :: IO (); a959 = forever $ putStrLn "a959"
+a960 :: IO (); a960 = forever $ putStrLn "a960"
+a961 :: IO (); a961 = forever $ putStrLn "a961"
+a962 :: IO (); a962 = forever $ putStrLn "a962"
+a963 :: IO (); a963 = forever $ putStrLn "a963"
+a964 :: IO (); a964 = forever $ putStrLn "a964"
+a965 :: IO (); a965 = forever $ putStrLn "a965"
+a966 :: IO (); a966 = forever $ putStrLn "a966"
+a967 :: IO (); a967 = forever $ putStrLn "a967"
+a968 :: IO (); a968 = forever $ putStrLn "a968"
+a969 :: IO (); a969 = forever $ putStrLn "a969"
+a970 :: IO (); a970 = forever $ putStrLn "a970"
+a971 :: IO (); a971 = forever $ putStrLn "a971"
+a972 :: IO (); a972 = forever $ putStrLn "a972"
+a973 :: IO (); a973 = forever $ putStrLn "a973"
+a974 :: IO (); a974 = forever $ putStrLn "a974"
+a975 :: IO (); a975 = forever $ putStrLn "a975"
+a976 :: IO (); a976 = forever $ putStrLn "a976"
+a977 :: IO (); a977 = forever $ putStrLn "a977"
+a978 :: IO (); a978 = forever $ putStrLn "a978"
+a979 :: IO (); a979 = forever $ putStrLn "a979"
+a980 :: IO (); a980 = forever $ putStrLn "a980"
+a981 :: IO (); a981 = forever $ putStrLn "a981"
+a982 :: IO (); a982 = forever $ putStrLn "a982"
+a983 :: IO (); a983 = forever $ putStrLn "a983"
+a984 :: IO (); a984 = forever $ putStrLn "a984"
+a985 :: IO (); a985 = forever $ putStrLn "a985"
+a986 :: IO (); a986 = forever $ putStrLn "a986"
+a987 :: IO (); a987 = forever $ putStrLn "a987"
+a988 :: IO (); a988 = forever $ putStrLn "a988"
+a989 :: IO (); a989 = forever $ putStrLn "a989"
+a990 :: IO (); a990 = forever $ putStrLn "a990"
+a991 :: IO (); a991 = forever $ putStrLn "a991"
+a992 :: IO (); a992 = forever $ putStrLn "a992"
+a993 :: IO (); a993 = forever $ putStrLn "a993"
+a994 :: IO (); a994 = forever $ putStrLn "a994"
+a995 :: IO (); a995 = forever $ putStrLn "a995"
+a996 :: IO (); a996 = forever $ putStrLn "a996"
+a997 :: IO (); a997 = forever $ putStrLn "a997"
+a998 :: IO (); a998 = forever $ putStrLn "a998"
+a999 :: IO (); a999 = forever $ putStrLn "a999"
+a1000 :: IO (); a1000 = forever $ putStrLn "a1000"
diff --git a/tests/examples/ghc8/T10487.hs b/tests/examples/ghc8/T10487.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10487.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
+
+module T10487 where
+
+import GHC.Generics
+
+import qualified T10487_M as M
+
+data Name = Name
+
+deriving instance Generic Name
+deriving instance Generic M.Name
diff --git a/tests/examples/ghc8/T10487_M.hs b/tests/examples/ghc8/T10487_M.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10487_M.hs
@@ -0,0 +1,3 @@
+module T10487_M where
+
+data Name = Name
diff --git a/tests/examples/ghc8/T10524.hs b/tests/examples/ghc8/T10524.hs
--- a/tests/examples/ghc8/T10524.hs
+++ b/tests/examples/ghc8/T10524.hs
@@ -6,3 +6,4 @@
newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable)
+-- WrappedFunctor :: forall k. (k -> *) -> k -> *
diff --git a/tests/examples/ghc8/T10549a.hs b/tests/examples/ghc8/T10549a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10549a.hs
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -O #-}
+module Main(main) where
+import GHC.Exts
+main = print 1
+go (Ptr a) = a
diff --git a/tests/examples/ghc8/T10582.hs b/tests/examples/ghc8/T10582.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T10582.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# LANGUAGE Arrows #-}
-
-module T10582 where
-
-(|:) :: Int -> Int -> Int
-(|:) = (+)
diff --git a/tests/examples/ghc8/T10615.hs b/tests/examples/ghc8/T10615.hs
--- a/tests/examples/ghc8/T10615.hs
+++ b/tests/examples/ghc8/T10615.hs
@@ -6,5 +6,3 @@
f2 :: _ -> _f
f2 = const
-
-
diff --git a/tests/examples/ghc8/T10638.hs b/tests/examples/ghc8/T10638.hs
--- a/tests/examples/ghc8/T10638.hs
+++ b/tests/examples/ghc8/T10638.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-}
import Language.Haskell.TH
diff --git a/tests/examples/ghc8/T10662.hs b/tests/examples/ghc8/T10662.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10662.hs
@@ -0,0 +1,4 @@
+main :: IO ()
+main = do
+ return $ let a = "hello" in a
+ return ()
diff --git a/tests/examples/ghc8/T10667.hs b/tests/examples/ghc8/T10667.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10667.hs
@@ -0,0 +1,6 @@
+module A where
+
+-- when used with '-g' debug generation option
+-- '*/*' leaked into a /* comment */ and broke
+-- GNU as.
+x */* y = 42
diff --git a/tests/examples/ghc8/T10678.hs b/tests/examples/ghc8/T10678.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10678.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Prim
+
+main :: IO ()
+main = go 1000000# 10 (2^100)
+
+go :: Int# -> Integer -> Integer -> IO ()
+go 0# _ _ = return ()
+go n# a b = (a + b) `seq` go (n# -# 1#) a b
+{-# NOINLINE go #-}
+
+{-
+This test is based on a strategy from rwbarton relying on the inefficiency
+of `Integer` addition as defined by `integer-gmp` without `runRW#`.
+
+ When I was testing the patch interactively, I measured allocations for,
+ say, a million (large Integer) + (small Integer) additions. If that
+ addition allocates, say, 6 words, then one can fairly reliably write the
+ program so that it will allocate between 6 million and 7 million words,
+ total.
+-}
diff --git a/tests/examples/ghc8/T10734.hs b/tests/examples/ghc8/T10734.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10734.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = do
+ pprint <$> runQ [| do { let { }; return (); } |] >>= putStrLn
+ pprint <$> runQ [| do { let { x = 5 }; return x; } |] >>= putStrLn
+ pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn
diff --git a/tests/examples/ghc8/T10747.hs b/tests/examples/ghc8/T10747.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10747.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T10747 where
+
+pattern head `Cons` tail = head : tail
diff --git a/tests/examples/ghc8/T10767.hs b/tests/examples/ghc8/T10767.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10767.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
+
+module Main where
+
+{- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning:
+
+T10767.hs:43:1: Warning:
+ RULE left-hand side too complicated to desugar
+ Optimised lhs: case cobox_aWY
+ of _ [Occ=Dead] { GHC.Types.Eq# cobox ->
+ genLength @ Int $dSpecList_aWX
+ }
+ Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox ->
+ genLength @ Int $dSpecList_aWX
+ }
+-}
+
+import Data.Proxy
+
+class SpecList a where
+ type List a :: *
+
+ slCase :: List a -> b -> (a -> List a -> b) -> b
+
+data IntList
+ = ILNil
+ | ILCons {-# UNPACK #-} !Int IntList
+ deriving (Show)
+
+instance SpecList Int where
+ type List Int = IntList
+
+ slCase ILNil n _ = n
+ slCase (ILCons i t) _ c = c i t
+
+fromList :: [Int] -> IntList
+fromList [] = ILNil
+fromList (h : t) = ILCons h (fromList t)
+
+lst1 :: IntList
+lst1 = fromList [1..10]
+
+{-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-}
+genLength :: forall a . SpecList a => Proxy a -> List a -> Int
+genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail)
+
+main :: IO ()
+main = print (genLength (Proxy :: Proxy Int) lst1)
diff --git a/tests/examples/ghc8/T10796a.hs b/tests/examples/ghc8/T10796a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10796a.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T10796a where
+
+import Data.Ratio
+import Data.Set (Set, fromList)
+import Language.Haskell.TH.Syntax (liftData)
+
+-- Data instance with toConstr implemented using a variable,
+-- not a data constructor
+splicedSet :: Set Char
+splicedSet = $(liftData (fromList "test"))
+
+-- Infix data constructor
+splicedRatio :: Ratio Int
+splicedRatio = $(liftData (1 % 2 :: Ratio Int))
diff --git a/tests/examples/ghc8/T10796b.hs b/tests/examples/ghc8/T10796b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10796b.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T10796b where
+
+import Data.Set (Set, fromList)
+import Language.Haskell.TH.Quote (dataToPatQ)
+
+badPattern :: Set Char -> Set Char
+badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s
diff --git a/tests/examples/ghc8/T10819.hs b/tests/examples/ghc8/T10819.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10819.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+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") [ConT (mkName "C") `AppT` ConT (mkName "Int")])
+
+thing :: N
+thing = N X
+
+thing1 :: Int
+thing1 = f thing
diff --git a/tests/examples/ghc8/T10819_Lib.hs b/tests/examples/ghc8/T10819_Lib.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10819_Lib.hs
@@ -0,0 +1,7 @@
+module T10819_Lib where
+
+import Language.Haskell.TH.Syntax
+
+doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n
+ [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv]
+ where n = mkName s
diff --git a/tests/examples/ghc8/T10820.hs b/tests/examples/ghc8/T10820.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10820.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE LiberalTypeSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import Language.Haskell.TH.Syntax
+import GHC.LanguageExtensions
+
+main = do
+ print $(isExtEnabled Cpp >>= lift)
+ print $(isExtEnabled LiberalTypeSynonyms >>= lift)
+ print $(isExtEnabled RankNTypes >>= lift)
+ print $(isExtEnabled TypeSynonymInstances >>= lift)
+ print $(isExtEnabled MagicHash >>= lift)
diff --git a/tests/examples/ghc8/T10845.hs b/tests/examples/ghc8/T10845.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10845.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# OPTIONS_GHC -dcore-lint #-}
+
+import GHC.Stack
+
+f1 :: (?loc :: CallStack) => CallStack
+-- we can infer a CallStack for let-binders
+f1 = let y x = (?loc :: CallStack)
+ in y 0
+
+f2 :: (?loc :: CallStack) => CallStack
+-- but only when we would infer an IP.
+-- i.e. the monomorphism restriction prevents us
+-- from inferring a CallStack.
+f2 = let y = (?loc :: CallStack)
+ in y
+
+main :: IO ()
+main = do putStrLn $ prettyCallStack f1
+ putStrLn $ prettyCallStack f2
diff --git a/tests/examples/ghc8/T10846.hs b/tests/examples/ghc8/T10846.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10846.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-}
+
+module Main where
+
+import GHC.Stack
+
+f1 :: (?loc :: CallStack) => String
+f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc
+
+f2 :: (?loc :: CallStack) => _
+f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc
+
+f3 :: (?loc :: CallStack, _) => String
+f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc
+
+main :: IO ()
+main = do
+ putStrLn f1
+ putStrLn f2
+ putStrLn f3
diff --git a/tests/examples/ghc8/T10870.hs b/tests/examples/ghc8/T10870.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10870.hs
@@ -0,0 +1,12 @@
+import Data.Bits
+import Data.Int
+import Data.Word
+
+unsafeShift32R :: (Bits a, Num a) => a -> a
+unsafeShift32R x = unsafeShiftR x 32
+
+main :: IO ()
+main = do
+ print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ]
+ print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ]
+ print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ]
diff --git a/tests/examples/ghc8/T10890.hs b/tests/examples/ghc8/T10890.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10890.hs
@@ -0,0 +1,23 @@
+module Main where
+
+-- Previously GHC was printing this warning:
+--
+-- Main.hs:5:1: Warning:
+-- The import of ‘A.has’ from module ‘A’ is redundant
+--
+-- Main.hs:6:1: Warning:
+-- The import of ‘B.has’ from module ‘B’ is redundant
+
+import A (A (has))
+import B (B (has))
+
+data Blah = Blah
+
+instance A Blah where
+ has = Blah
+
+instance B Blah where
+ has = Blah
+
+main :: IO ()
+main = return ()
diff --git a/tests/examples/ghc8/T10890_1.hs b/tests/examples/ghc8/T10890_1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10890_1.hs
@@ -0,0 +1,22 @@
+module Main where
+
+import Base
+import Extends
+
+-- Previously GHC was giving this false positive:
+--
+-- T10890_1.hs:4:1: Warning:
+-- The import of ‘Extends’ is redundant
+-- except perhaps to import instances from ‘Extends’
+-- To import instances alone, use: import Extends()
+
+data Bar = Bar
+
+instance AClass Bar where
+ has = Bar
+
+instance BClass Bar where
+ has = Bar
+
+main :: IO ()
+main = return ()
diff --git a/tests/examples/ghc8/T10890_2.hs b/tests/examples/ghc8/T10890_2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10890_2.hs
@@ -0,0 +1,17 @@
+module T10890_2 where
+
+-- Previously GHC was printing this warning:
+--
+-- Main.hs:5:1: Warning:
+-- The import of ‘A.has’ from module ‘A’ is redundant
+--
+-- Main.hs:6:1: Warning:
+-- The import of ‘B.has’ from module ‘B’ is redundant
+
+import T10890_2A (A (has))
+import T10890_2B (B (has))
+
+data Blah = Blah
+
+instance A Blah where
+ has = Blah
diff --git a/tests/examples/ghc8/T10890_2A.hs b/tests/examples/ghc8/T10890_2A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10890_2A.hs
@@ -0,0 +1,4 @@
+module T10890_2A where
+
+class A a where
+ has :: a
diff --git a/tests/examples/ghc8/T10890_2B.hs b/tests/examples/ghc8/T10890_2B.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10890_2B.hs
@@ -0,0 +1,4 @@
+module T10890_2B where
+
+class B a where
+ has :: a
diff --git a/tests/examples/ghc8/T10891.hs b/tests/examples/ghc8/T10891.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10891.hs
@@ -0,0 +1,40 @@
+{-# 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/ghc8/T10897a.hs b/tests/examples/ghc8/T10897a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10897a.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T10897a where
+pattern Single :: a -> a
+pattern Single x = x
diff --git a/tests/examples/ghc8/T10897b.hs b/tests/examples/ghc8/T10897b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10897b.hs
@@ -0,0 +1,4 @@
+module B where
+import T10897a
+
+Single y = True
diff --git a/tests/examples/ghc8/T10904.hs b/tests/examples/ghc8/T10904.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10904.hs
@@ -0,0 +1,28 @@
+import Control.Concurrent
+import Control.Monad
+import Foreign
+import Foreign.C.Types
+import System.Environment
+
+
+foreign import ccall safe "finalizerlib.h init_value"
+ init_value :: Ptr CInt -> IO ()
+
+foreign import ccall safe "finalizerlib.h &finalize_value"
+ finalize_value :: FinalizerPtr CInt
+
+
+allocateValue :: IO ()
+allocateValue = do
+ fp <- mallocForeignPtrBytes 10000
+ withForeignPtr fp init_value
+ addForeignPtrFinalizer finalize_value fp
+
+
+main :: IO ()
+main = do
+ [n] <- fmap (fmap read) getArgs
+ _ <- forkIO (loop n)
+ loop n
+ where
+ loop n = replicateM_ n allocateValue
diff --git a/tests/examples/ghc8/T10908.hs b/tests/examples/ghc8/T10908.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10908.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-}
+
+module Bug (Data.List.intercalate, x) where
+
+import qualified Data.List
+
+intercalate = True
+
+x :: Bool
+x = intercalate
diff --git a/tests/examples/ghc8/T10929.hs b/tests/examples/ghc8/T10929.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10929.hs
@@ -0,0 +1,31 @@
+module T10929 where
+
+x1 :: [Integer]
+x1 = [5 .. 3]
+
+x2 :: [Integer]
+x2 = [3 .. 5]
+
+x3 :: [Integer]
+x3 = [5, 3 .. 1]
+
+x4 :: [Integer]
+x4 = [5, (3+0) .. 1]
+
+x5 :: [Integer]
+x5 = [1, 3 .. 5]
+
+x6 :: [Integer]
+x6 = [1, (3+0) .. 5]
+
+x7 :: [Integer]
+x7 = [5, 7 .. 1]
+
+x8 :: [Integer]
+x8 = [5, (7+0) .. 1]
+
+x9 :: [Integer]
+x9 = [3, 1 .. 5]
+
+x10 :: [Integer]
+x10 = [3, (1+0) .. 5]
diff --git a/tests/examples/ghc8/T10931.hs b/tests/examples/ghc8/T10931.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10931.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+module T10931 ( BugC(..) ) where
+
+data IdT f a = IdC (f a)
+
+class ( m ~ Outer m (Inner m) ) => BugC (m :: * -> *) where
+ type Inner m :: * -> *
+ type Outer m :: (* -> *) -> * -> *
+
+ bug :: ( forall n. ( n ~ Outer n (Inner n)
+ , Outer n ~ Outer m
+ )
+ => Inner n a)
+ -> m a
+
+instance BugC (IdT m) where
+ type Inner (IdT m) = m
+ type Outer (IdT m) = IdT
+
+ bug f = IdC f
diff --git a/tests/examples/ghc8/T10934.hs b/tests/examples/ghc8/T10934.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 -> *) -> [u] -> * where
+ RNil :: Rec f '[]
+ (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)
+
+newtype Compose (f :: l -> *) (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/ghc8/T10935.hs b/tests/examples/ghc8/T10935.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10935.hs
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-}
+
+module T10935 where
+
+f x = let y = x+1 in (y,y)
diff --git a/tests/examples/ghc8/T10942.hs b/tests/examples/ghc8/T10942.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10942.hs
@@ -0,0 +1,22 @@
+module Main where
+
+import DynFlags
+import GHC
+
+import Control.Monad.IO.Class (liftIO)
+import System.Environment
+import HeaderInfo
+import Outputable
+import StringBuffer
+
+main :: IO ()
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream
+ `gopt_set` Opt_Haddock
+ filename = "T10942_A.hs"
+ setSessionDynFlags dflags'
+ stringBuffer <- liftIO $ hGetStringBuffer filename
+ liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename))
diff --git a/tests/examples/ghc8/T10942_A.hs b/tests/examples/ghc8/T10942_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10942_A.hs
@@ -0,0 +1,16 @@
+{-
+
+A normal comment, to check if we can still pick up the CPP directive after it.
+
+-}
+-- Check that we can parse a file with leading comments
+
+-- ^ haddock
+-- * haddock
+-- | haddock
+-- $ haddock
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+module T10942 where
+
+main = return ()
diff --git a/tests/examples/ghc8/T10945.hs b/tests/examples/ghc8/T10945.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10945.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10945 where
+
+import Language.Haskell.TH
+
+$$(return [
+ SigD (mkName "m")
+ (ForallT [PlainTV (mkName "a")]
+ []
+ (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
+ , FunD (mkName "m")
+ [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []]
+ ])
diff --git a/tests/examples/ghc8/T10946.hs b/tests/examples/ghc8/T10946.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10946.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10946 where
+
+import Language.Haskell.TH
+
+m :: a -> a
+m x = $$([||_||])
diff --git a/tests/examples/ghc8/T10955dyn.hs b/tests/examples/ghc8/T10955dyn.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10955dyn.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import Foreign
+import Foreign.C.Types
+foreign import ccall "bar" dle :: IO CInt
+
+main = dle >>= print
diff --git a/tests/examples/ghc8/T10962.hs b/tests/examples/ghc8/T10962.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10962.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import GHC.Base
+
+main :: IO ()
+main = do
+ -- Overflow.
+ let (# w1, i1 #) = subWordC# 1## 3##
+ print (W# w1, I# i1)
+
+ -- No overflow.
+ let (# w2, i2 #) = subWordC# 3## 1##
+ print (W# w2, I# i2)
diff --git a/tests/examples/ghc8/T10970a.hs b/tests/examples/ghc8/T10970a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10970a.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+main = do
+#ifndef VERSION_containers
+ putStrLn "OK"
+#endif
+#ifndef MIN_VERSION_base
+ putStrLn "OK"
+#endif
diff --git a/tests/examples/ghc8/T10971a.hs b/tests/examples/ghc8/T10971a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10971a.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-}
+module T10971a where
+
+import Data.Traversable (fmapDefault)
+
+f = \x -> length x
+g = \f x -> fmapDefault f x
+h = \f x -> (fmapDefault f x, length x)
diff --git a/tests/examples/ghc8/T10971b.hs b/tests/examples/ghc8/T10971b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10971b.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-}
+module T10971b where
+import Data.Traversable (fmapDefault)
+f = \x -> length x
+g = \f x -> fmapDefault f x
+h = \f x -> (fmapDefault f x, length x)
diff --git a/tests/examples/ghc8/T10971c.hs b/tests/examples/ghc8/T10971c.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10971c.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-}
+module T10971c where
+
+import Data.Traversable (fmapDefault)
+
+f = \x -> length x
+g = \f x -> fmapDefault f x
+h = \f x -> (fmapDefault f x, length x)
diff --git a/tests/examples/ghc8/T10971d.hs b/tests/examples/ghc8/T10971d.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10971d.hs
@@ -0,0 +1,6 @@
+import T10971c
+
+main = do
+ print $ f (Just 1)
+ print $ g (+1) (Just 5)
+ print $ h (const 5) Nothing
diff --git a/tests/examples/ghc8/T10997.hs b/tests/examples/ghc8/T10997.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10997.hs
@@ -0,0 +1,6 @@
+module T10997 where
+
+import T10997a
+
+foo :: Exp a -> String
+foo Tru = "True"
diff --git a/tests/examples/ghc8/T10997_1.hs b/tests/examples/ghc8/T10997_1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10997_1.hs
@@ -0,0 +1,15 @@
+module T10997_1 where
+
+import T10997_1a
+
+{- With ghc-7.10.2:
+
+ The interface for ‘T10997a’
+ Declaration for Just'
+ Pattern synonym Just':
+ Iface type variable out of scope: k
+ Cannot continue after interface file error
+-}
+
+bar :: (Showable a) => Maybe a -> Maybe a
+bar (Just' a) = Just' a
diff --git a/tests/examples/ghc8/T10997_1a.hs b/tests/examples/ghc8/T10997_1a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10997_1a.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-}
+module T10997_1a where
+
+import GHC.Exts
+
+type family Showable (a :: k) :: Constraint where
+ Showable (a :: *) = (Show a)
+ Showable a = ()
+
+extractJust :: Maybe a -> (Bool, a)
+extractJust (Just a) = (True, a)
+extractJust _ = (False, undefined)
+
+pattern Just' :: Showable a => a -> (Maybe a)
+pattern Just' a <- (extractJust -> (True, a)) where
+ Just' a = Just a
+
diff --git a/tests/examples/ghc8/T10997a.hs b/tests/examples/ghc8/T10997a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10997a.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs, PatternSynonyms #-}
+
+module T10997a where
+
+data Exp ty where
+ LitB :: Bool -> Exp Bool
+
+pattern Tru :: () => b ~ Bool => Exp b
+pattern Tru = LitB True
+
+
diff --git a/tests/examples/ghc8/T10999.hs b/tests/examples/ghc8/T10999.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T10999.hs
@@ -0,0 +1,8 @@
+module T10999 where
+
+import qualified Data.Set as Set
+
+f :: _ => () -> _
+f _ = Set.fromList undefined
+
+g = map fst $ Set.toList $ f ()
diff --git a/tests/examples/ghc8/T11010.hs b/tests/examples/ghc8/T11010.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11010.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-}
+
+module T11010 where
+
+data Expr a where
+ Fun :: String -> (a -> b) -> (Expr a -> Expr b)
+
+pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b)
+pattern IntFun str f x = Fun str f x
+
+-- Alternative syntax for pattern synonyms:
+-- pattern
+-- Suc :: () => (a ~ Int) => Expr a -> Expr Int
+-- Suc n <- IntFun _ _ n where
+-- Suc n = IntFun "suc" (+ 1) n
+pattern Suc :: (a ~ Int) => Expr a -> Expr Int
+pattern Suc n <- IntFun _ _ n where
+ Suc n = IntFun "suc" (+ 1) n
diff --git a/tests/examples/ghc8/T11016.hs b/tests/examples/ghc8/T11016.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11016.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-}
+
+module T11016 where
+
+f1 :: (?x :: Int, _) => Int
+f1 = ?x
+
+f2 :: (?x :: Int) => _
+f2 = ?x
diff --git a/tests/examples/ghc8/T11039.hs b/tests/examples/ghc8/T11039.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11039.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo () where
+
+data A a = A a
+
+pattern Q :: () => (A ~ f) => a -> f a
+pattern Q a = A a
diff --git a/tests/examples/ghc8/T11053.hs b/tests/examples/ghc8/T11053.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11053.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE PatternSynonyms #-}
+-- turn on with -fwarn-missing-pat-syn-sigs
+
+module Foo where
+
+-- Should warn because of missing signature
+pattern T = True
+
+pattern J a = Just a
+
+pattern J1 a <- Just a
+
+pattern J2{b} = Just b
+
+pattern J3{c} <- Just c
+
+pattern F :: Bool
+pattern F = False
diff --git a/tests/examples/ghc8/T11067.hs b/tests/examples/ghc8/T11067.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11067.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module T11067 where
+
+import Data.Monoid
+import GHC.Exts (Constraint)
+
+type family Skolem (p :: k -> Constraint) :: k
+type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1
+
+-- | A quantified constraint
+type Forall (p :: k -> Constraint) = p (Skolem p)
+type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f))
+
+-- These work
+class ForallF Monoid t => Monoid1 t
+instance ForallF Monoid t => Monoid1 t
+
+class ForallF Monoid1 t => Monoid2 t
+instance ForallF Monoid1 t => Monoid2 t
+
+-- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error
+class (f a ~ g a) => H f g a
+instance (f a ~ g a) => H f g a
+
+-- This one gives a superclass cycle error.
+class Forall (H f g) => H1 f g
+instance Forall (H f g) => H1 f g
diff --git a/tests/examples/ghc8/T11071.hs b/tests/examples/ghc8/T11071.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11071.hs
@@ -0,0 +1,28 @@
+module T11071 where
+
+import Data.List (lines)
+import qualified Data.Map as M ()
+import qualified Data.IntMap as M ()
+import qualified Data.IntMap as M () -- just to see if this confused the code
+
+import qualified Data.Ord as Ord hiding (Down)
+
+import qualified Data.Map as M' hiding (size, filter)
+import qualified Data.Map as M' hiding (size)
+import qualified Data.IntMap as M' hiding (size)
+import qualified System.IO as M' () -- unrelated
+
+ignore :: a -> IO ()
+ignore = const (return ())
+
+main = do
+ ignore NoSuchModule.foo -- no such module
+ ignore Data.List.foobar -- does not exist (one import)
+ ignore M.foobar -- does not exist (two imports)
+ ignore M'.foobar -- does not exist (three imports)
+ ignore Data.List.sort -- needs import
+ ignore Data.List.unlines -- needs import, similar to imported
+ ignore M.size -- multiple modules to import from
+ ignore M.valid -- only one module to import from
+ ignore Ord.Down -- explicit hiding
+ ignore M'.size -- hidden and/or missing in import list
diff --git a/tests/examples/ghc8/T11071a.hs b/tests/examples/ghc8/T11071a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11071a.hs
@@ -0,0 +1,16 @@
+module T11071 where
+
+import Data.List (lines)
+import Data.IntMap ()
+import Data.Ord hiding (Down)
+import Prelude hiding (True)
+
+ignore :: a -> IO ()
+ignore = const (return ())
+
+main = do
+ ignore intersperse -- missing in import list (one import)
+ ignore foldl' -- missing in import list (two imports)
+ ignore Down -- explicitly hidden
+ ignore True -- explicitly hidden from prelude (not really special)
+ ignore foobar -- genuinely out of scope
diff --git a/tests/examples/ghc8/T11076.hs b/tests/examples/ghc8/T11076.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11076.hs
@@ -0,0 +1,15 @@
+{-
+ Test case for a problem where GHC had incorrect strictness
+ information for foreign calls with lifted arguments
+ -}
+{-# OPTIONS_GHC -O0 #-}
+module Main where
+
+import T11076A
+import Control.Exception
+x :: Bool
+x = error "OK: x has been forced"
+
+main :: IO ()
+main = print (testBool x) `catch`
+ \(ErrorCall e) -> putStrLn e -- x should be forced
diff --git a/tests/examples/ghc8/T11076A.hs b/tests/examples/ghc8/T11076A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11076A.hs
@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -O #-}
+{-# LANGUAGE MagicHash,
+ ForeignFunctionInterface,
+ UnliftedFFITypes,
+ GHCForeignImportPrim,
+ BangPatterns
+ #-}
+module T11076A where
+
+import GHC.Exts
+import Unsafe.Coerce
+
+{-
+ If the demand type for the foreign call argument is incorrectly strict,
+ the bang pattern can be optimized out
+ -}
+testBool :: Bool -> Int
+testBool !x = I# (cmm_testPrim (unsafeCoerce x))
+{-# INLINE testBool #-}
+
+foreign import prim "testPrim" cmm_testPrim :: Any -> Int#
diff --git a/tests/examples/ghc8/T11077.hs b/tests/examples/ghc8/T11077.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11077.hs
@@ -0,0 +1,3 @@
+module T11077 (module X, foo) where
+import Data.List as X
+foo = undefined
diff --git a/tests/examples/ghc8/T11103.hs b/tests/examples/ghc8/T11103.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11103.hs
@@ -0,0 +1,20 @@
+-- When using DuplicateRecordFields with TemplateHaskell, it is not possible to
+-- reify ambiguous names that are output by reifying field labels.
+-- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs
+
+{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data R = MkR { foo :: Int, bar :: Int }
+data S = MkS { foo :: Int }
+
+$(do info <- reify ''R
+ case info of
+ TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _)
+ -> do { reify bar_n -- This is unambiguous
+ ; reify foo_n -- This is ambiguous
+ ; return []
+ }
+ _ -> error "unexpected result of reify")
diff --git a/tests/examples/ghc8/T11112.hs b/tests/examples/ghc8/T11112.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11112.hs
@@ -0,0 +1,4 @@
+module T11112 where
+
+sort :: Ord s -> [s] -> [s]
+sort xs = xs
diff --git a/tests/examples/ghc8/T11128.hs b/tests/examples/ghc8/T11128.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11128.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances #-}
+
+-- | Test noncanonical-monad-instances warnings
+module T11128 where
+
+import Control.Applicative as A
+import Control.Monad as M
+
+----------------------------------------------------------------------------
+-- minimal definition
+
+data T0 a = T0 a deriving Functor
+
+instance A.Applicative T0 where
+ pure = T0
+ (<*>) = M.ap
+
+instance M.Monad T0 where
+ (>>=) = undefined
+
+----------------------------------------------------------------------------
+-- trigger all 4 warnings
+
+data T1 a = T1 a deriving Functor
+
+instance A.Applicative T1 where
+ pure = return
+ (<*>) = M.ap
+ (*>) = (M.>>)
+
+instance M.Monad T1 where
+ (>>=) = undefined
+ return = T1
+ (>>) = undefined
+
+----------------------------------------------------------------------------
+-- backward compat canonical defintion
+
+data T2 a = T2 a deriving Functor
+
+instance Applicative T2 where
+ pure = T2
+ (<*>) = ap
+ (*>) = undefined
+
+instance M.Monad T2 where
+ (>>=) = undefined
+ return = pure
+ (>>) = (*>)
diff --git a/tests/examples/ghc8/T11136.hs b/tests/examples/ghc8/T11136.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11136.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T11136 where
+
+class C a where
+ type D a
+ type instance D a x = x
diff --git a/tests/examples/ghc8/T11142.hs b/tests/examples/ghc8/T11142.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11142.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeInType, RankNTypes #-}
+
+module T11142 where
+
+import Data.Kind
+
+data SameKind :: k -> k -> *
+
+foo :: forall b. (forall k (a :: k). SameKind a b) -> ()
+foo = undefined
diff --git a/tests/examples/ghc8/T11148.hs b/tests/examples/ghc8/T11148.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11148.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module T11148 where
+
+data family G a b c d
+data instance G Int b Float d = G deriving Functor
+
+data family H a b c d
+data instance H [b] b d c = H deriving Functor
diff --git a/tests/examples/ghc8/T11155.hs b/tests/examples/ghc8/T11155.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11155.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -O -fno-full-laziness #-}
+module T11155 where
+
+foo :: Bool
+{-# NOINLINE foo #-}
+foo = error "rk"
+
+bar x = let t :: Char
+ t = case foo of { True -> 'v'; False -> 'y' }
+ in [t]
+
diff --git a/tests/examples/ghc8/T11164.hs b/tests/examples/ghc8/T11164.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11164.hs
@@ -0,0 +1,3 @@
+module T11164 where
+
+import T11164b (T)
diff --git a/tests/examples/ghc8/T11164a.hs b/tests/examples/ghc8/T11164a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11164a.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T11164a where
+
+data family T a
diff --git a/tests/examples/ghc8/T11164b.hs b/tests/examples/ghc8/T11164b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11164b.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module T11164b where
+
+import T11164a
+
+data instance T Int = MkT
diff --git a/tests/examples/ghc8/T11167.hs b/tests/examples/ghc8/T11167.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11167.hs
@@ -0,0 +1,21 @@
+module T11167 where
+
+data SomeException
+
+newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
+
+runContT' :: ContT r m a -> (a -> m r) -> m r
+runContT' = runContT
+
+catch_ :: IO a -> (SomeException -> IO a) -> IO a
+catch_ = undefined
+
+foo :: IO ()
+foo = (undefined :: ContT () IO a)
+ `runContT` (undefined :: a -> IO ())
+ `catch_` (undefined :: SomeException -> IO ())
+
+foo' :: IO ()
+foo' = (undefined :: ContT () IO a)
+ `runContT'` (undefined :: a -> IO ())
+ `catch_` (undefined :: SomeException -> IO ())
diff --git a/tests/examples/ghc8/T11167_ambig.hs b/tests/examples/ghc8/T11167_ambig.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11167_ambig.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11167_ambig where
+
+data SomeException
+
+newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
+newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r}
+
+runContT' :: ContT r m a -> (a -> m r) -> m r
+runContT' = runContT
+
+catch_ :: IO a -> (SomeException -> IO a) -> IO a
+catch_ = undefined
+
+foo :: IO ()
+foo = (undefined :: ContT () IO a)
+ `runContT` (undefined :: a -> IO ())
+ `catch_` (undefined :: SomeException -> IO ())
+
+foo' :: IO ()
+foo' = (undefined :: ContT () IO a)
+ `runContT'` (undefined :: a -> IO ())
+ `catch_` (undefined :: SomeException -> IO ())
diff --git a/tests/examples/ghc8/T11167_ambiguous_fixity.hs b/tests/examples/ghc8/T11167_ambiguous_fixity.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11167_ambiguous_fixity.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11167_ambiguous_fixity where
+import T11167_ambiguous_fixity_A
+import T11167_ambiguous_fixity_B
+
+x a = (a :: A) `foo` 0
diff --git a/tests/examples/ghc8/T11167_ambiguous_fixity_A.hs b/tests/examples/ghc8/T11167_ambiguous_fixity_A.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11167_ambiguous_fixity_A.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11167_ambiguous_fixity_A where
+data A = MkA { foo :: Int -> Int }
+data C = MkC { foo :: Int -> Int }
+infixr 3 `foo`
diff --git a/tests/examples/ghc8/T11167_ambiguous_fixity_B.hs b/tests/examples/ghc8/T11167_ambiguous_fixity_B.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11167_ambiguous_fixity_B.hs
@@ -0,0 +1,3 @@
+module T11167_ambiguous_fixity_B where
+data B = MkB { foo :: Int -> Int }
+infixl 5 `foo`
diff --git a/tests/examples/ghc8/T11173.hs b/tests/examples/ghc8/T11173.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11173.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11173 where
+import T11173a (A(..))
+
+-- Check that the fixity declaration applied to the field 'foo' is used
+x b = b `foo` b `foo` 0
diff --git a/tests/examples/ghc8/T11173a.hs b/tests/examples/ghc8/T11173a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11173a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11173a where
+
+data A = A { foo :: Int -> Int, bar :: Int -> Int }
+newtype B = B { foo :: Int -> Int }
+infixr 5 `foo`
+infixr 5 `bar`
+
+-- This is well-typed only if the fixity is correctly applied
+y b = b `bar` b `bar` 0
diff --git a/tests/examples/ghc8/T11182.hs b/tests/examples/ghc8/T11182.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11182.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE Strict #-}
+-- | Strict should imply StrictData
+module Main where
+
+data Lazy a = Lazy ~a
+
+main :: IO ()
+main =
+ case Lazy undefined of
+ Lazy _ -> putStrLn "Lazy"
diff --git a/tests/examples/ghc8/T11187.hs b/tests/examples/ghc8/T11187.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11187.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module T11187 where
+import Data.Type.Coercion
+
+type family X
+
+coercionXX :: Coercion X X
+coercionXX = Coercion
+
+coercionXX1 :: Coercion X X
+coercionXX1 = c where
+ c :: x ~ X => Coercion x x
+ c = Coercion
+
+coercionXX2 :: Coercion X X
+coercionXX2 = c where c = Coercion
diff --git a/tests/examples/ghc8/T11192.hs b/tests/examples/ghc8/T11192.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11192.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module T11192 where
+
+fails :: a
+fails =
+ let go :: _
+ go 0 a = a
+ in go (0 :: Int) undefined
+
+succeeds :: a
+succeeds =
+ let go :: _
+ go _ a = a
+ in go (0 :: Int) undefined
diff --git a/tests/examples/ghc8/T11193.hs b/tests/examples/ghc8/T11193.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11193.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE Strict #-}
+
+module Main where
+
+main = do
+ ~a <- return (error "don't error here!")
+ b <- return (error "error here!") -- this binding should be strict
+ print "should never reach here"
diff --git a/tests/examples/ghc8/T11208.hs b/tests/examples/ghc8/T11208.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11208.hs
@@ -0,0 +1,8 @@
+module T11208 where
+
+import qualified Prelude as P
+
+f n = n P.+ 1
+
+g h (P.Just x) = P.Just (h x)
+g _ P.Nothing = P.Nothing
diff --git a/tests/examples/ghc8/T11216.hs b/tests/examples/ghc8/T11216.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11216.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE RebindableSyntax #-}
+
+module Bug where
+
+foo :: (a, b) -> ()
+foo x | (_,_) <- x = ()
diff --git a/tests/examples/ghc8/T11224.hs b/tests/examples/ghc8/T11224.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11224.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE PatternSynonyms , ViewPatterns #-}
+
+-- inlining a pattern synonym shouldn't change semantics
+
+import Text.Read
+
+-- pattern PRead :: () => Read a => a -> String
+pattern PRead a <- (readMaybe -> Just a)
+
+foo :: String -> Int
+foo (PRead x) = (x::Int)
+foo (PRead xs) = sum (xs::[Int])
+foo _ = 666
+
+bar :: String -> Int
+bar (readMaybe -> Just x) = (x::Int)
+bar (readMaybe -> Just xs) = sum (xs::[Int])
+bar _ = 666
+
+main :: IO ()
+main = do
+ print $ foo "1" -- 1
+ print $ foo "[1,2,3]" -- 666 -- ???
+ print $ foo "xxx" -- 666
+
+ print $ bar "1" -- 1
+ print $ bar "[1,2,3]" -- 6
+ print $ bar "xxx" -- 666
diff --git a/tests/examples/ghc8/T11232.hs b/tests/examples/ghc8/T11232.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11232.hs
@@ -0,0 +1,15 @@
+module T11232 where
+
+import Control.Monad
+import Data.Data
+
+mkMp :: ( MonadPlus m
+ , Typeable a
+ , Typeable b
+ )
+ => (b -> m b)
+ -> a
+ -> m a
+mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext)))
+
+newtype M m x = M { unM :: x -> m x }
diff --git a/tests/examples/ghc8/T11237.hs b/tests/examples/ghc8/T11237.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T11237.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
+module TypeInTypeBug where
+
+import qualified Data.Kind
+
+data Works :: Data.Kind.Type where
+ WorksConstr :: Works
+
+type Set = Data.Kind.Type
+
+data ShouldWork :: Set where
+ ShouldWorkConstr :: ShouldWork
diff --git a/tests/examples/ghc8/T1830_1.hs b/tests/examples/ghc8/T1830_1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T1830_1.hs
@@ -0,0 +1,5 @@
+module T1830_1 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Foo a = Foo a deriving Lift
diff --git a/tests/examples/ghc8/T1830_2.hs b/tests/examples/ghc8/T1830_2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T1830_2.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DeriveLift #-}
+module T1830_2 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Nothing deriving Lift
diff --git a/tests/examples/ghc8/T1830_3.hs b/tests/examples/ghc8/T1830_3.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T1830_3.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH.Syntax (lift)
+import T1830_3a
+
+main :: IO ()
+main = do
+ print ($(lift algDT1) == algDT1)
+ print ($(lift algDT2) == algDT2)
+ print ($(lift algDT3) == algDT3)
+ print ($(lift prim) == prim)
+ print ($(lift df1) == df1)
+ print ($(lift df2) == df2)
+ print ($(lift df3) == df3)
diff --git a/tests/examples/ghc8/T1830_3a.hs b/tests/examples/ghc8/T1830_3a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T1830_3a.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+module T1830_3a where
+
+import GHC.Exts
+import Language.Haskell.TH.Syntax (Lift(..))
+
+data AlgDT a b c = NormalCon a b
+ | RecCon { recCon1 :: a, recCon2 :: b}
+ | a :^: b
+ deriving (Eq, Lift)
+
+data Prim = Prim Char# Double# Int# Float# Word#
+ deriving (Eq, Lift)
+
+-- We can't test this for equality easily due to the unstable nature of
+-- primitive string literal equality. We include this anyway to ensure that
+-- deriving Lift for datatypes with Addr# in them does in fact work.
+data AddrHash = AddrHash Addr#
+ deriving Lift
+
+data Empty deriving Lift
+
+data family DataFam a b c
+
+data instance DataFam Int b c = DF1 Int | DF2 b
+ deriving (Eq, Lift)
+
+newtype instance DataFam Char b c = DF3 Char
+ deriving (Eq, Lift)
+
+algDT1, algDT2, algDT3 :: AlgDT Int String ()
+algDT1 = NormalCon 1 "foo"
+algDT2 = RecCon 2 "bar"
+algDT3 = 3 :^: "baz"
+
+prim :: Prim
+prim = Prim 'a'# 1.0## 1# 1.0# 1##
+
+df1, df2 :: DataFam Int Char ()
+df1 = DF1 1
+df2 = DF2 'a'
+
+df3 :: DataFam Char () ()
+df3 = DF3 'b'
diff --git a/tests/examples/ghc8/T2006.hs b/tests/examples/ghc8/T2006.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T2006.hs
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+{-# LANGUAGE GADTs #-}
+
+module T2006 where
+
+data Expr a vs where
+ EPrim :: String -> a -> Expr a vs
+ EVar :: Expr a (a,vs)
+
+interpret :: Expr a () -> a
+interpret (EPrim _ a) = a
+-- interpret EVar = error "unreachable"
+
diff --git a/tests/examples/ghc8/T2204.hs b/tests/examples/ghc8/T2204.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T2204.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T2204 where
+
+f :: String -> Int
+f "01" = 0
+
+g :: Int -> Int
+g 0 = 0
diff --git a/tests/examples/ghc8/T2632.hs b/tests/examples/ghc8/T2632.hs
--- a/tests/examples/ghc8/T2632.hs
+++ b/tests/examples/ghc8/T2632.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- Trac #2632
module MkData where
diff --git a/tests/examples/ghc8/T3078.hs b/tests/examples/ghc8/T3078.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T3078.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE PatternGuards #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T3078 where
+
+data T = A Int | B Int
+
+funny :: T -> Int
+funny t = n
+ where
+ n | A x <- t = x
+ | B x <- t = x
diff --git a/tests/examples/ghc8/T322.hs b/tests/examples/ghc8/T322.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T322.hs
@@ -0,0 +1,29 @@
+{-# OPTIONS -fwarn-incomplete-patterns -fwarn-overlapping-patterns -Werror #-}
+
+module T322 where
+
+instance (Num a) => Num (Maybe a) where
+ (Just a) + (Just b) = Just (a + b)
+ _ + _ = Nothing
+
+ (Just a) - (Just b) = Just (a - b)
+ _ - _ = Nothing
+
+ (Just a) * (Just b) = Just (a * b)
+ _ * _ = Nothing
+
+ negate (Just a) = Just (negate a)
+ negate _ = Nothing
+
+ abs (Just a) = Just (abs a)
+ abs _ = Nothing
+
+ signum (Just a) = Just (signum a)
+ signum _ = Nothing
+
+ fromInteger = Just . fromInteger
+
+f :: Maybe Int -> Int
+f 1 = 1
+f Nothing = 2
+f _ = 3
diff --git a/tests/examples/ghc8/T3572.hs b/tests/examples/ghc8/T3572.hs
--- a/tests/examples/ghc8/T3572.hs
+++ b/tests/examples/ghc8/T3572.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- Trac #3572
diff --git a/tests/examples/ghc8/T365.hs b/tests/examples/ghc8/T365.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T365.hs
@@ -0,0 +1,4 @@
+{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-}
+module Main where
+
+main = print "Hello World"
diff --git a/tests/examples/ghc8/T366.hs b/tests/examples/ghc8/T366.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T366.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T366 where
+
+data T a where
+ C1 :: T Char
+ C2 :: T Float
+
+exhaustive :: T Char -> Char
+exhaustive C1 = ' '
diff --git a/tests/examples/ghc8/T3927.hs b/tests/examples/ghc8/T3927.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T3927.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T3927 where
+
+data T a where
+ T1 :: T Int
+ T2 :: T Bool
+
+-- f1 is exhaustive
+f1 :: T a -> T a -> Bool
+f1 T1 T1 = True
+f1 T2 T2 = False
diff --git a/tests/examples/ghc8/T3927a.hs b/tests/examples/ghc8/T3927a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T3927a.hs
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+{-# LANGUAGE GADTs, TypeFamilies #-}
+
+module T3927a where
+
+type family F a
+type instance F a = ()
+
+data Foo a where
+ FooA :: Foo ()
+ FooB :: Foo Int
+
+f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted
+f _ FooA = ()
+
diff --git a/tests/examples/ghc8/T3927b.hs b/tests/examples/ghc8/T3927b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 -> * where
+ SRead :: SockOp sock 'Read
+ SWrite :: SockOp sock Write
+
+data Socket :: SocketType -> * where
+ Socket :: proxy sock
+ -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op)
+ -> Socket sock
+
+type family Operation (op :: SocketOperation) :: * 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/ghc8/T4056.hs b/tests/examples/ghc8/T4056.hs
--- a/tests/examples/ghc8/T4056.hs
+++ b/tests/examples/ghc8/T4056.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
module T4056 where
import Language.Haskell.TH
diff --git a/tests/examples/ghc8/T4139.hs b/tests/examples/ghc8/T4139.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T4139.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+
+module T4139 where
+
+data F a where
+ FInt :: F Int
+ FBool :: F Bool
+
+class Baz a where
+ baz :: F a -> G a
+instance Baz Int where
+ baz _ = GInt
+instance Baz Bool where
+ baz _ = GBool
+
+data G a where
+ GInt :: G Int
+ GBool :: G Bool
+
+bar :: Baz a => F a -> ()
+bar a@(FInt) =
+ case baz a of
+ GInt -> ()
+ -- GBool -> ()
+bar _ = ()
+
+
diff --git a/tests/examples/ghc8/T4169.hs b/tests/examples/ghc8/T4169.hs
--- a/tests/examples/ghc8/T4169.hs
+++ b/tests/examples/ghc8/T4169.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- Crashed GHC 6.12
module T4165 where
diff --git a/tests/examples/ghc8/T4170.hs b/tests/examples/ghc8/T4170.hs
--- a/tests/examples/ghc8/T4170.hs
+++ b/tests/examples/ghc8/T4170.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
module T4170 where
import Language.Haskell.TH
diff --git a/tests/examples/ghc8/T5908.hs b/tests/examples/ghc8/T5908.hs
--- a/tests/examples/ghc8/T5908.hs
+++ b/tests/examples/ghc8/T5908.hs
@@ -26,7 +26,7 @@
(>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b
return :: a -> m ex ex a
fail :: String -> m e x a
-
+
{-# INLINE (>>) #-}
m >> k = m >>= \ _ -> k
fail = error
diff --git a/tests/examples/ghc8/T6018.hs b/tests/examples/ghc8/T6018.hs
--- a/tests/examples/ghc8/T6018.hs
+++ b/tests/examples/ghc8/T6018.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
diff --git a/tests/examples/ghc8/T6018th.hs b/tests/examples/ghc8/T6018th.hs
--- a/tests/examples/ghc8/T6018th.hs
+++ b/tests/examples/ghc8/T6018th.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-}
module T6018th where
diff --git a/tests/examples/ghc8/T6062.hs b/tests/examples/ghc8/T6062.hs
--- a/tests/examples/ghc8/T6062.hs
+++ b/tests/examples/ghc8/T6062.hs
@@ -1,2 +1,3 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
module T6062 where
x = [| False True |]
diff --git a/tests/examples/ghc8/T6124.hs b/tests/examples/ghc8/T6124.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T6124.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+
+module T6124 where
+
+newtype A = MkA Int
+newtype B = MkB Char
+
+data T a where
+ A :: T A
+ B :: T B
+
+f :: T A -> A
+f A = undefined
diff --git a/tests/examples/ghc8/T7669a.hs b/tests/examples/ghc8/T7669a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T7669a.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+
+module T7669 where
+
+data Void
+
+foo :: Void -> ()
+foo x = case x of {}
diff --git a/tests/examples/ghc8/T8455.hs b/tests/examples/ghc8/T8455.hs
--- a/tests/examples/ghc8/T8455.hs
+++ b/tests/examples/ghc8/T8455.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE DataKinds #-}
module T8455 where
diff --git a/tests/examples/ghc8/T8759a.hs b/tests/examples/ghc8/T8759a.hs
--- a/tests/examples/ghc8/T8759a.hs
+++ b/tests/examples/ghc8/T8759a.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE PatternSynonyms #-}
module T8759a where
diff --git a/tests/examples/ghc8/T8970.hs b/tests/examples/ghc8/T8970.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T8970.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T8970 where
+
+data K = Foo
+ | Bar
+
+data D1 :: K -> * where
+ F1 :: D1 Foo
+ B1 :: D1 Bar
+
+class C (a :: K -> *) where
+ data D2 a :: K -> *
+ foo :: a k -> D2 a k -> Bool
+
+instance C D1 where
+ data D2 D1 k where
+ F2 :: D2 D1 Foo
+ B2 :: D2 D1 Bar
+ foo F1 F2 = True
+ foo B1 B2 = True
diff --git a/tests/examples/ghc8/T9015.hs b/tests/examples/ghc8/T9015.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9015.hs
@@ -0,0 +1,59 @@
+module Main where
+
+import GHC
+import DynFlags
+import System.Environment
+import GhcMonad
+
+testStrings = [
+ "import Data.Maybe"
+ , "import qualified Data.Maybe"
+ , "import Data.Maybe (isJust)"
+
+ , "add a b = a+b"
+ , "data Foo = Foo String"
+ , "deriving instance Show Foo"
+ , "{-# NOVECTORISE foo #-}"
+ , "{-# WARNING Foo \"Just a warning\" #-}"
+ , "{-# ANN foo (Just \"Hello\") #-}"
+ , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}"
+ , "class HasString a where\n\
+ \ update :: a -> (String -> String) -> a\n\
+ \ upcase :: a -> a\n\
+ \ upcase x = update x (fmap toUpper)\n\
+ \ content :: a -> String\n\
+ \ default content :: Show a => a -> String\n\
+ \ content = show"
+ , "instance HasString Foo where\n\
+ \ update (Foo s) f = Foo (f s)\n\
+ \ content (Foo s) = s"
+
+ , "add a b"
+ , "let foo = add a b"
+ , "x <- foo y"
+ , "5 + 8"
+
+ , "a <-"
+ , "2 +"
+ , "@#"
+ ]
+
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ do
+ liftIO (putStrLn "Is import:")
+ testWithParser isImport
+
+ liftIO (putStrLn "Is declaration:")
+ testWithParser isDecl
+
+ liftIO (putStrLn "Is statement:")
+ testWithParser isStmt
+
+ where
+ testWithParser parser = do
+ dflags <- getSessionDynFlags
+ liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings
+
+ testExpr parser expr = do
+ expr ++ ": " ++ show (parser expr)
diff --git a/tests/examples/ghc8/T9017.hs b/tests/examples/ghc8/T9017.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9017.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PolyKinds #-}
+
+module T9017 where
+
+import Control.Arrow
+
+foo :: a b (m b)
+foo = arr return
diff --git a/tests/examples/ghc8/T9225.hs b/tests/examples/ghc8/T9225.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T9225.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module T9225 where
--- Should be a parse error:
--- version numbers not allowed in package qualified imports
-import "some-package-0.1.2.3" Some.Module
diff --git a/tests/examples/ghc8/T9238.hs b/tests/examples/ghc8/T9238.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9238.hs
@@ -0,0 +1,16 @@
+compareDouble :: Double -> Double -> Ordering
+compareDouble x y =
+ case (isNaN x, isNaN y) of
+ (True, True) -> EQ
+ (True, False) -> LT
+ (False, True) -> GT
+ (False, False) ->
+ -- Make -0 less than 0
+ case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of
+ (True, True, True, False) -> LT
+ (True, True, False, True) -> GT
+ _ -> x `compare` y
+
+main = do
+ let l = [-0, 0]
+ print [ (x, y, compareDouble x y) | x <- l, y <- l ]
diff --git a/tests/examples/ghc8/T9632.hs b/tests/examples/ghc8/T9632.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9632.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeInType #-}
+
+module T9632 where
+
+import Data.Kind
+
+data B = T | F
+data P :: B -> *
+
+type B' = B
+data P' :: B' -> *
diff --git a/tests/examples/ghc8/T9723a.hs b/tests/examples/ghc8/T9723a.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T9723a.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-
-{-# OPTIONS -fwarn-tabs #-}
-
--- Check we get a warning for a single tab
-
-module ShouldCompile where
-
-tab1 = 'a'
-
diff --git a/tests/examples/ghc8/T9723b.hs b/tests/examples/ghc8/T9723b.hs
deleted file mode 100644
--- a/tests/examples/ghc8/T9723b.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-
-{-# OPTIONS -fwarn-tabs #-}
-
--- Check we get a warning for multiple tabs, with the correct number of tabs
--- mentioned
-
-module ShouldCompile where
-
--- tab in middle of line
-tab1 = 'a'
--- tab at end of line
-tab2 = 'b'
--- two tabs in middle of line
-tab3 = 'c'
-
-tab4 = if True
--- tab at start of line
- then 'd'
--- tab at start of line
- else 'e'
-
- -- tab before a comment starts
diff --git a/tests/examples/ghc8/T9824.hs b/tests/examples/ghc8/T9824.hs
--- a/tests/examples/ghc8/T9824.hs
+++ b/tests/examples/ghc8/T9824.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -fwarn-unused-matches #-}
module T9824 where
diff --git a/tests/examples/ghc8/T9951.hs b/tests/examples/ghc8/T9951.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9951.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T9951 where
+
+f :: [a] -> ()
+f x = case x of
+ [] -> ()
+ (_:_) -> ()
+
diff --git a/tests/examples/ghc8/T9951b.hs b/tests/examples/ghc8/T9951b.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9951b.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module T9951b where
+
+f :: String -> Bool
+f "ab" = True
diff --git a/tests/examples/ghc8/T9968.hs b/tests/examples/ghc8/T9968.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9968.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}
+
+module T9968 where
+
+class C a b
+data X = X deriving (C Int)
+
diff --git a/tests/examples/ghc8/T9968a.hs b/tests/examples/ghc8/T9968a.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/T9968a.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
+module T9968 where
+
+import Data.Bifunctor
+
+data Blah a b = A a | B b
+ deriving (Bifunctor)
diff --git a/tests/examples/ghc8/TH_abstractFamily.hs b/tests/examples/ghc8/TH_abstractFamily.hs
--- a/tests/examples/ghc8/TH_abstractFamily.hs
+++ b/tests/examples/ghc8/TH_abstractFamily.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
module TH_abstractFamily where
import Language.Haskell.TH
diff --git a/tests/examples/ghc8/TH_bracket1.hs b/tests/examples/ghc8/TH_bracket1.hs
--- a/tests/examples/ghc8/TH_bracket1.hs
+++ b/tests/examples/ghc8/TH_bracket1.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- Check that declarations in a bracket shadow the top-level
-- declarations, rather than clashing with them.
diff --git a/tests/examples/ghc8/TH_bracket2.hs b/tests/examples/ghc8/TH_bracket2.hs
--- a/tests/examples/ghc8/TH_bracket2.hs
+++ b/tests/examples/ghc8/TH_bracket2.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
module TH_bracket2 where
d_show = [d| data A = A
diff --git a/tests/examples/ghc8/TH_bracket3.hs b/tests/examples/ghc8/TH_bracket3.hs
--- a/tests/examples/ghc8/TH_bracket3.hs
+++ b/tests/examples/ghc8/TH_bracket3.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
module TH_bracket3 where
diff --git a/tests/examples/ghc8/TH_finalizer.hs b/tests/examples/ghc8/TH_finalizer.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TH_finalizer.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module ShouldCompile where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+$( do
+ addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool)))
+ return [] )
+$( putQ True >> return [] )
diff --git a/tests/examples/ghc8/TH_localname.hs b/tests/examples/ghc8/TH_localname.hs
--- a/tests/examples/ghc8/TH_localname.hs
+++ b/tests/examples/ghc8/TH_localname.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
module TH_localname where
x = \y -> [| y |]
diff --git a/tests/examples/ghc8/TH_nameSpace.hs b/tests/examples/ghc8/TH_nameSpace.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TH_nameSpace.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Data.Maybe (Maybe(..))
+import Data.Ord (Ord)
+import Language.Haskell.TH (mkName, nameSpace)
+
+main :: IO ()
+main = mapM_ (print . nameSpace)
+ [ 'Prelude.id
+ , mkName "id"
+ , 'Data.Maybe.Just
+ , ''Data.Maybe.Maybe
+ , ''Data.Ord.Ord
+ ]
diff --git a/tests/examples/ghc8/TH_ppr1.hs b/tests/examples/ghc8/TH_ppr1.hs
--- a/tests/examples/ghc8/TH_ppr1.hs
+++ b/tests/examples/ghc8/TH_ppr1.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Main (main) where
diff --git a/tests/examples/ghc8/TH_repE1.hs b/tests/examples/ghc8/TH_repE1.hs
--- a/tests/examples/ghc8/TH_repE1.hs
+++ b/tests/examples/ghc8/TH_repE1.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- test the representation of literals and also explicit type annotations
module TH_repE1
diff --git a/tests/examples/ghc8/TH_repE3.hs b/tests/examples/ghc8/TH_repE3.hs
--- a/tests/examples/ghc8/TH_repE3.hs
+++ b/tests/examples/ghc8/TH_repE3.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- test the representation of literals and also explicit type annotations
module TH_repE1
diff --git a/tests/examples/ghc8/TH_scope.hs b/tests/examples/ghc8/TH_scope.hs
--- a/tests/examples/ghc8/TH_scope.hs
+++ b/tests/examples/ghc8/TH_scope.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- Test for Trac #2188
module TH_scope where
diff --git a/tests/examples/ghc8/TH_spliceE5_prof_ext.hs b/tests/examples/ghc8/TH_spliceE5_prof_ext.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TH_spliceE5_prof_ext.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Main where
+
+import TH_spliceE5_prof_ext_Lib
+
+v1 = "foo"
+
+main = putStrLn $(expandVars ["v1","v2"])
+-- The splice expands to refer to both v1 and v2,
+-- and the test checks that we don't dependency-analyse
+-- the program so that one or the other isn't in scope
+-- to the type checker
+
+
+v2 = "bar"
diff --git a/tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+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/ghc8/Test10276.hs b/tests/examples/ghc8/Test10276.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Test10276.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Test10276 where
+
+f1 = [| bar |]
+f2 = [e| bar |]
+
+class QQExp a b where
+ qqExp x = [||fst $ runState $$(qqExpM x)
+ ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]
+
+class QQExp2 a b where
+ qqExp x = [e||fst $ runState $$(qqExpM x)
+ ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]
diff --git a/tests/examples/ghc8/Test11018.hs b/tests/examples/ghc8/Test11018.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Test11018.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module Test11018 where
+
+nonUnicode :: forall a . a -> IO Int
+nonUnicode _ = do
+ x <- readChar
+ return 4
+
+-- ^ An opaque ESD handle for recording data from the soundcard via ESD.
+data Recorder fr ch (r ∷ * -> *)
+ = Recorder {
+ reCloseH :: !(FinalizerHandle r)
+ }
+
+f :: Arrow a => a (Int,Int,Int) Int
+f = proc (x,y,z) -> returnA -< x+y
+
+f2 :: Arrow a => a (Int,Int,Int) Int
+f2 = proc (x,y,z) -> returnA >- x+y
+
+g :: ArrowApply a => Int -> a (a Int Int,Int) Int
+g y = proc (x,z) -> x -<< 2+y
+
+g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int
+g2 y = proc (x,z) -> x >>- 2+y
+
+-- -------------------------------------
+
+unicode ∷ ∀ a . a → IO Int
+unicode _ = do
+ x ← readChar
+ return 4
+
+-- ^ An opaque ESD handle for recording data from the soundcard via ESD.
+data RecorderU fr ch (r ∷ ★ → ★)
+ = RecorderU {
+ reCloseHU ∷ !(FinalizerHandle r)
+ }
+
+fU :: Arrow a ⇒ a (Int,Int,Int) Int
+fU = proc (x,y,z) -> returnA ⤙ x+y
+
+f2U :: Arrow a ⇒ a (Int,Int,Int) Int
+f2U = proc (x,y,z) -> returnA ⤚ x+y
+
+gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int
+gU y = proc (x,z) -> x ⤛ 2+y
+
+g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int
+g2U y = proc (x,z) -> x ⤜ 2+y
diff --git a/tests/examples/ghc8/TransBundle.hs b/tests/examples/ghc8/TransBundle.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TransBundle.hs
@@ -0,0 +1,9 @@
+module TransAssociated(A(..)) where
+
+import Bundle (A(..))
+
+foo = MkA 5
+baz = NoA
+
+qux (MkA x) = x
+qux NoA = 0
diff --git a/tests/examples/ghc8/TypeLevelVec.hs b/tests/examples/ghc8/TypeLevelVec.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TypeLevelVec.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TypeInType, UnicodeSyntax, GADTs, NoImplicitPrelude,
+ TypeOperators, TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
+module TypeLevelVec where
+
+import Data.Kind
+
+data ℕ ∷ Type where
+ O ∷ ℕ
+ S ∷ ℕ → ℕ
+
+type family x + y where
+ O + n = n
+ S m + n = S (m + n)
+infixl 5 +
+
+data Vec ∷ ℕ → Type → Type where
+ Nil ∷ Vec O a
+ (:>) ∷ a → Vec n a → Vec (S n) a
+infixr 8 :>
+
+type family (x ∷ Vec n a) ++ (y ∷ Vec m a) ∷ Vec (n + m) a where
+ Nil ++ y = y
+ (x :> xs) ++ y = x :> (xs ++ y)
+infixl 5 ++
diff --git a/tests/examples/ghc8/TypeSkolEscape.hs b/tests/examples/ghc8/TypeSkolEscape.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/TypeSkolEscape.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-}
+
+module TypeSkolEscape where
+
+import GHC.Types
+import GHC.Exts
+
+type Bad = forall (v :: Levity) (a :: TYPE v). a
diff --git a/tests/examples/ghc8/UnicodeRules.hs b/tests/examples/ghc8/UnicodeRules.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/UnicodeRules.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE
+ BangPatterns
+ , FlexibleContexts
+ , FlexibleInstances
+ , ScopedTypeVariables
+ , UnboxedTuples
+ , UndecidableInstances
+ , UnicodeSyntax
+ #-}
+
+strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool
+{-# RULES "head → strictHead" [1]
+ ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).
+ head v = strictHead v #-}
+{-# INLINE strictHead #-}
+strictHead (Bitstream _ v) = head (SV.head v)
diff --git a/tests/examples/ghc8/UnicodeSyntax.hs b/tests/examples/ghc8/UnicodeSyntax.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/UnicodeSyntax.hs
@@ -0,0 +1,236 @@
+{-# 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)
+ }
+
diff --git a/tests/examples/ghc8/Vta1.hs b/tests/examples/ghc8/Vta1.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Vta1.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds,
+ TypeFamilies, RankNTypes,
+ FlexibleContexts #-}
+-- tests about visible type application
+
+module Vta1 where
+
+quad :: a -> b -> c -> d -> (a, b, c, d)
+quad = (,,,)
+
+silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello"
+
+pairup_nosig x y = (x, y)
+
+pairup_sig :: a -> b -> (a,b)
+pairup_sig u w = (u, w)
+
+answer_sig = pairup_sig @Bool @Int False 7 --
+-- (False, 7) :: (Bool, Int)
+
+answer_read = show (read @Int "3") -- "3" :: String
+answer_show = show @Integer (read "5") -- "5" :: String
+answer_showread = show @Int (read @Int "7") -- "7" :: String
+
+intcons a = (:) @Int a
+
+intpair x y = pairup_sig @Int x y
+
+answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool)
+answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String)
+answer_intcons = intcons 7 [] -- [7] :: [Int]
+
+type family F a
+type instance F Char = Bool
+
+g :: F a -> a
+g _ = undefined
+
+f :: Char
+f = g True
+
+answer = g @Char False
+
+mapSame :: forall b. (forall a. a -> a) -> [b] -> [b]
+mapSame _ [] = []
+mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs)
+
+pair :: forall a. a-> (forall b. b -> (a, b))
+pair x y = (x, y)
+
+b = pair @Int 3 @Bool True
+c = mapSame id [1,2,3]
+d = pair 3 @Bool True
+
+pairnum :: forall a. Num a => forall b. b -> (a, b)
+pairnum = pair 3
+
+e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True
+h = pairnum @Int @Bool True
+
+data First (a :: * -> *) = F
+data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable)
+data Three (a :: * -> k -> *) = T
+
+foo :: Proxy a -> Int
+foo _ = 0
+
+first :: First a -> Int
+first _ = 0
+
+fTest = first F
+fMaybe = first @Maybe F
+
+test = foo P
+bar = foo @Bool P -- should work
+
+too :: Three a -> Int
+too _ = 3
+
+threeBase = too T
+threeOk = too @Either T
+
+blah = Nothing @Int
+
+newtype N = MkN { unMkN :: forall a. Show a => a -> String }
+
+n = MkN show
+
+boo = unMkN n @Bool
+
+boo2 :: forall (a :: * -> *) . Proxy a -> Bool
+boo2 _ = False
+
+base = boo2 P
+bar'= boo2 @Maybe P -- should work
diff --git a/tests/examples/ghc8/Vta2.hs b/tests/examples/ghc8/Vta2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/Vta2.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE RankNTypes, TypeApplications #-}
+
+
+module Vta2 where
+
+checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int)
+checkIf _ = if True
+ then \f -> (f True, f 5)
+ else \f -> (f False, f @Int 3)
+
+checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int)
+checkCase _ = case True of
+ True -> \f -> (f True, f 5)
+ False -> \f -> (f False, f @Int 3)
diff --git a/tests/examples/ghc8/WCompatWarningsNotOn.hs b/tests/examples/ghc8/WCompatWarningsNotOn.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/WCompatWarningsNotOn.hs
@@ -0,0 +1,26 @@
+-- Test purpose:
+-- Ensure that not using -Wcompat does not enable its warnings
+
+-- {-# OPTIONS_GHC -Wcompat #-}
+-- {-# OPTIONS_GHC -Wno-compat #-}
+
+module WCompatWarningsNotOn where
+
+import qualified Data.Semigroup as Semi
+
+monadFail :: Monad m => m a
+monadFail = do
+ Just _ <- undefined
+ undefined
+
+(<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+ (<>) = mappend
+
+instance Semi.Monoid S where
+ S a `mappend` S b = S (a+b)
+ mempty = S 0
diff --git a/tests/examples/ghc8/WCompatWarningsOff.hs b/tests/examples/ghc8/WCompatWarningsOff.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/WCompatWarningsOff.hs
@@ -0,0 +1,26 @@
+-- Test purpose:
+-- Ensure that using -Wno-compat does not switch on warnings
+
+-- {-# OPTIONS_GHC -Wcompat #-}
+{-# OPTIONS_GHC -Wno-compat #-}
+
+module WCompatWarningsOff where
+
+import qualified Data.Semigroup as Semi
+
+monadFail :: Monad m => m a
+monadFail = do
+ Just _ <- undefined
+ undefined
+
+(<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+ (<>) = mappend
+
+instance Semi.Monoid S where
+ S a `mappend` S b = S (a+b)
+ mempty = S 0
diff --git a/tests/examples/ghc8/WCompatWarningsOn.hs b/tests/examples/ghc8/WCompatWarningsOn.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/WCompatWarningsOn.hs
@@ -0,0 +1,26 @@
+-- Test purpose:
+-- Ensure that -Wcompat switches on the right warnings
+
+{-# OPTIONS_GHC -Wcompat #-}
+-- {-# OPTIONS_GHC -Wno-compat #-}
+
+module WCompatWarningsOn where
+
+import qualified Data.Semigroup as Semi
+
+monadFail :: Monad m => m a
+monadFail = do
+ Just _ <- undefined
+ undefined
+
+(<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+ (<>) = mappend
+
+instance Semi.Monoid S where
+ S a `mappend` S b = S (a+b)
+ mempty = S 0
diff --git a/tests/examples/ghc8/WCompatWarningsOnOff.hs b/tests/examples/ghc8/WCompatWarningsOnOff.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/WCompatWarningsOnOff.hs
@@ -0,0 +1,26 @@
+-- Test purpose:
+-- Ensure that -Wno-compat disables a previously set -Wcompat
+
+{-# OPTIONS_GHC -Wcompat #-}
+{-# OPTIONS_GHC -Wno-compat #-}
+
+module WCompatWarningsOnOff where
+
+import qualified Data.Semigroup as Semi
+
+monadFail :: Monad m => m a
+monadFail = do
+ Just _ <- undefined
+ undefined
+
+(<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+ (<>) = mappend
+
+instance Semi.Monoid S where
+ S a `mappend` S b = S (a+b)
+ mempty = S 0
diff --git a/tests/examples/ghc8/determ004.hs b/tests/examples/ghc8/determ004.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 -> *)
+ -> *)
+ (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 ]
+$s$wsFoldr1_szbtK =
+ \ (@ (m_azbFg :: a_afdP_azbON))
+ (@ (x_azbOM :: TyFun
+ a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *)
+ -> *))
+ (@ (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
+ @~ (_N
+ :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO))
+ sc_szbtN
+ sc_szbtM)
+ `cast` (sg_szbtL
+ ; TFCo:R:Sing[]z[0] _N _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] _N _N)
+ ; Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ _N <'[]>_N _N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _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=] ->
+ case ds_dzbyu
+ `cast` (TFCo:R:Sing[]z[0] _N _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] _N _N _N)
+ ; Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ _N <'[m_XzbGe]>_N _N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N))
+ ((_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]
+ _N _N _N
+ :: Sing (Apply x_azbOM m_XzbGe)
+ ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe))
+ of wild_X3X { SLambda ds_XzbBr [Dmd=] ->
+ (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
+ @~ (_N
+ :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR))
+ ipv_szbwL
+ ipv_szbwK)
+ `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym
+ (TFCo:R:Apply[][]:$$i[0]
+ _N
+ _N
+ _N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Applyk(->):$l[0]
+ _N
+ _N))
+ _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] _N _N)
+ _N)_N
+ ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ _N
+ ((Apply
+ (TFCo:R:Applyk(->):$l[0] _N _N)
+ _N)_N
+ ; TFCo:R:Apply[][]:$$i[0]
+ _N _N _N)
+ _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
+ _N
+ (Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ _N _N _N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0]
+ _N _N))
+ (Sym
+ (TFCo:R:Apply[][]:$$i[0]
+ _N _N _N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Applyk(->):$l[0] _N _N))
+ _N)_N))_N))_N
+ ; Sym
+ (TFCo:R:Foldr1[1]
+ _N
+ _N
+ _N
+ _N
+ _N)
+ ; Sym
+ (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
+ _N _N _N)
+ ; (Apply
+ (Sym
+ (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N))
+ ((_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 :: *) (b :: *)
+
+type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2
+
+data instance Sing (f :: TyFun k1 k2 -> *) =
+ 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 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 -> *)
+ -> *)
+ (t_afdZ :: [a_afdP]) =
+ Foldr1 t_afdY t_afdZ
+data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *)
+ -> *)
+ (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
+ -> *)
+ -> *) (TyFun [a_afdP] a_afdP -> *))
+type instance Apply Foldr1Sym0 l = Foldr1Sym1 l
+
+type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP
+ -> *)
+ -> *)
+ (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 -> *) -> *)
+ (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/ghc8/determinism001.hs b/tests/examples/ghc8/determinism001.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/determinism001.hs
@@ -0,0 +1,23 @@
+module Main where
+
+import Digraph
+
+main = mapM_ print
+ [ test001
+ , test002
+ , test003
+ , test004
+ ]
+
+-- These check that the result of SCCs doesn't depend on the order of the key
+-- type (Int here).
+
+test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])]
+
+test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])]
+
+test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])]
+
+test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])]
+
+testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices
diff --git a/tests/examples/ghc8/dynamic-paper.hs b/tests/examples/ghc8/dynamic-paper.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 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 -> *) ~ (* -> * -> *)|
+
+ 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 :: *) 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/ghc8/export-ps-rec-sel.hs b/tests/examples/ghc8/export-ps-rec-sel.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/export-ps-rec-sel.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo( R(P,x)) where
+
+data Q = Q Int
+
+data R = R
+
+pattern P{x} = Q x
diff --git a/tests/examples/ghc8/export-record-selector.hs b/tests/examples/ghc8/export-record-selector.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/export-record-selector.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo ( A(foo) ) where
+
+data A a = A a
+
+pattern P :: Int -> A Int
+pattern P{foo} = A foo
diff --git a/tests/examples/ghc8/export-super-class-fail.hs b/tests/examples/ghc8/export-super-class-fail.hs
--- a/tests/examples/ghc8/export-super-class-fail.hs
+++ b/tests/examples/ghc8/export-super-class-fail.hs
@@ -18,7 +18,7 @@
destruct (A n) = n
-pattern P :: () => C f a => a -> f a
+pattern P :: C f a => a -> f a
pattern P x <- (destruct -> x)
where
P x = build x
diff --git a/tests/examples/ghc8/export-super-class.hs b/tests/examples/ghc8/export-super-class.hs
--- a/tests/examples/ghc8/export-super-class.hs
+++ b/tests/examples/ghc8/export-super-class.hs
@@ -16,7 +16,7 @@
destruct (A n) = n
-pattern P :: () => C f a => a -> f a
+pattern P :: C f a => a -> f a
pattern P x <- (destruct -> x)
where
P x = build x
diff --git a/tests/examples/ghc8/export-syntax.hs b/tests/examples/ghc8/export-syntax.hs
--- a/tests/examples/ghc8/export-syntax.hs
+++ b/tests/examples/ghc8/export-syntax.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternSynonyms #-}
module Foo(A(.., B)) where
data A = A | B
diff --git a/tests/examples/ghc8/export-type-synonym.hs b/tests/examples/ghc8/export-type-synonym.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/export-type-synonym.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo ( A(P) ) where
+
+data A = A
+data B = B
+
+type C = B
+
+pattern P :: C
+pattern P = B
diff --git a/tests/examples/ghc8/export-type.hs b/tests/examples/ghc8/export-type.hs
--- a/tests/examples/ghc8/export-type.hs
+++ b/tests/examples/ghc8/export-type.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE PatternSynonyms #-}
-module Export (A(..,MyB), B(MyA)) where
+module Export (A(..,MyB), B(MyA), C(MyC)) where
data A = A
@@ -9,3 +9,7 @@
pattern MyB = B
pattern MyA = A
+
+data C a = C
+
+pattern MyC = B
diff --git a/tests/examples/ghc8/frontend01.hs b/tests/examples/ghc8/frontend01.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/frontend01.hs
@@ -0,0 +1,1 @@
+main = putStrLn "hello world"
diff --git a/tests/examples/ghc8/import-syntax.hs b/tests/examples/ghc8/import-syntax.hs
deleted file mode 100644
--- a/tests/examples/ghc8/import-syntax.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-{-# LANGUAGE PatternSynonyms #-}
-module Foo where
-
-import ImportSyntax (A(.., B))
diff --git a/tests/examples/ghc8/mixed-pat-syn-record-sels.hs b/tests/examples/ghc8/mixed-pat-syn-record-sels.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/mixed-pat-syn-record-sels.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo where
+
+
+pattern A { a } = Just a
+pattern B { b } = Just b
+
+foo :: Maybe a -> Maybe Bool
+foo x = x { a = True, b = False }
diff --git a/tests/examples/ghc8/mkGADTVars.hs b/tests/examples/ghc8/mkGADTVars.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/mkGADTVars.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE GADTs, TypeInType #-}
+
+module GADTVars where
+
+import Data.Kind
+import Data.Proxy
+
+data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where
+ MkT :: T x1 * (Proxy (y :: x1), z) z
diff --git a/tests/examples/ghc8/overloadedlabelsfail01.hs b/tests/examples/ghc8/overloadedlabelsfail01.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedlabelsfail01.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/tests/examples/ghc8/overloadedlabelsrun01.hs b/tests/examples/ghc8/overloadedlabelsrun01.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedlabelsrun01.hs
@@ -0,0 +1,29 @@
+-- Basic tests of overloaded labels
+
+{-# LANGUAGE OverloadedLabels
+ , DataKinds
+ , FlexibleContexts
+ , FlexibleInstances
+ , MultiParamTypeClasses
+ , NoMonomorphismRestriction
+ #-}
+
+import GHC.OverloadedLabels
+
+instance IsLabel "true" Bool where
+ fromLabel _ = True
+
+instance IsLabel "false" Bool where
+ fromLabel _ = False
+
+a :: IsLabel "true" t => t
+a = #true
+
+b = #false
+
+c :: Bool
+c = #true
+
+main = do print (a :: Bool)
+ print (b :: Bool)
+ print c
diff --git a/tests/examples/ghc8/overloadedlabelsrun02.hs b/tests/examples/ghc8/overloadedlabelsrun02.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedlabelsrun02.hs
@@ -0,0 +1,61 @@
+-- Using overloaded labels to provide nice syntactic sugar for a
+-- term representation using de Bruijn indices
+
+{-# LANGUAGE OverloadedLabels
+ , DataKinds
+ , FlexibleContexts
+ , FlexibleInstances
+ , GADTs
+ , KindSignatures
+ , MultiParamTypeClasses
+ , NoMonomorphismRestriction
+ , OverlappingInstances
+ , ScopedTypeVariables
+ , StandaloneDeriving
+ , TypeOperators
+ #-}
+
+import GHC.OverloadedLabels
+import Data.Proxy ( Proxy(..) )
+import GHC.TypeLits ( Symbol )
+
+instance x ~ y => IsLabel x (Proxy y) where
+ fromLabel _ = Proxy
+
+data Elem (x :: Symbol) g where
+ Top :: Elem x (x ': g)
+ Pop :: Elem x g -> Elem x (y ': g)
+deriving instance Show (Elem x g)
+
+
+class IsElem x g where
+ which :: Elem x g
+
+instance IsElem x (x ': g) where
+ which = Top
+
+instance IsElem x g => IsElem x (y ': g) where
+ which = Pop which
+
+
+data Tm g where
+ Var :: Elem x g -> Tm g
+ App :: Tm g -> Tm g -> Tm g
+ Lam :: Tm (x ': g) -> Tm g
+deriving instance Show (Tm g)
+
+instance IsElem x g => IsLabel x (Tm g) where
+ fromLabel _ = Var (which :: Elem x g)
+
+lam :: Proxy x -> Tm (x ': g) -> Tm g
+lam _ = Lam
+
+s = lam #x #x
+t = lam #x (lam #y (#x `App` #y))
+
+u :: IsElem "z" g => Tm g
+u = #z `App` #z
+
+main = do print s
+ print t
+ print (u :: Tm '["z"])
diff --git a/tests/examples/ghc8/overloadedlabelsrun03.hs b/tests/examples/ghc8/overloadedlabelsrun03.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedlabelsrun03.hs
@@ -0,0 +1,21 @@
+-- Using overloaded labels as strings, slightly pointlessly
+
+{-# LANGUAGE OverloadedLabels
+ , DataKinds
+ , FlexibleContexts
+ , FlexibleInstances
+ , MultiParamTypeClasses
+ , ScopedTypeVariables
+ , TypeFamilies
+ , TypeSynonymInstances
+ #-}
+
+import GHC.OverloadedLabels
+import Data.Proxy ( Proxy(..) )
+import GHC.TypeLits ( KnownSymbol, symbolVal )
+
+instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where
+ fromLabel _ = symbolVal (Proxy :: Proxy x)
+
+main = do putStrLn #x
+ print $ #x ++ #y
diff --git a/tests/examples/ghc8/overloadedrecflds_generics.hs b/tests/examples/ghc8/overloadedrecflds_generics.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/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 :: * -> *) :: 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 :: * -> *) 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/ghc8/overloadedrecfldsfail01.hs b/tests/examples/ghc8/overloadedrecfldsfail01.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail01.hs
@@ -0,0 +1,19 @@
+-- Test ambiguous updates are rejected with appropriate error messages
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data R = MkR { w :: Bool, x :: Int, y :: Bool }
+data S = MkS { w :: Bool, x :: Int, y :: Bool }
+data T = MkT { x :: Int, z :: Bool }
+data U = MkU { y :: Bool }
+
+-- Straightforward ambiguous update
+upd1 r = r { x = 3 }
+
+-- No type has all these fields
+upd2 r = r { x = 3, y = True, z = False }
+
+-- User-specified type does not have these fields
+upd3 r = r { w = True, x = 3, y = True } :: U
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail02.hs b/tests/examples/ghc8/overloadedrecfldsfail02.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail02.hs
@@ -0,0 +1,9 @@
+-- Test selectors cannot be used ambiguously
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data R = MkR { x :: Int, y :: Bool }
+data S = MkS { x :: Int }
+
+main = do print (x (MkS 42))
+ print (y (MkR 42 42))
diff --git a/tests/examples/ghc8/overloadedrecfldsfail03.hs b/tests/examples/ghc8/overloadedrecfldsfail03.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail03.hs
@@ -0,0 +1,10 @@
+-- Test that a top-level definition with the same name as a record
+-- field is rejected
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+foo = True
+
+data T = MkT { foo :: Int }
+
+main = print foo
diff --git a/tests/examples/ghc8/overloadedrecfldsfail04.hs b/tests/examples/ghc8/overloadedrecfldsfail04.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail04.hs
@@ -0,0 +1,14 @@
+-- Test that importing an overloaded field and using it as a selector
+-- leads to a suitable error
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+import OverloadedRecFldsFail04_A as I
+
+-- Qualified overloaded fields are not allowed here
+x' = I.x
+
+-- But this is okay
+f e = e { I.x = True, I.y = False }
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail05.hs b/tests/examples/ghc8/overloadedrecfldsfail05.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail05.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -fwarn-unused-binds -Werror #-}
+
+module Main (main, T(MkT)) where
+
+data S = MkS { foo :: Int }
+data T = MkT { foo :: Int }
+
+-- This should count as a use of S(foo) but not T(foo)
+main = print ((\ MkS{foo=foo} -> foo) (MkS 3))
diff --git a/tests/examples/ghc8/overloadedrecfldsfail06.hs b/tests/examples/ghc8/overloadedrecfldsfail06.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail06.hs
@@ -0,0 +1,18 @@
+-- Check that unused imports are reported correctly in the presence of
+-- DuplicateRecordFields
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-}
+
+import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY)
+import qualified OverloadedRecFldsFail06_A as M (U(x))
+import qualified OverloadedRecFldsFail06_A as N (V(x, y))
+import qualified OverloadedRecFldsFail06_A as P (U(x), V(x))
+
+v = MkV2 True
+
+-- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)...
+main = do print (u { x = True } :: U)
+ print ((\ MkV2{y=y} -> y) v)
+ print (N.x v)
+ print (getY (v { P.x = 3 }))
diff --git a/tests/examples/ghc8/overloadedrecfldsfail07.hs b/tests/examples/ghc8/overloadedrecfldsfail07.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail07.hs
@@ -0,0 +1,9 @@
+-- Test type errors contain field names, not selector names
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data T = MkT { x :: Int }
+
+y = x x
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail08.hs b/tests/examples/ghc8/overloadedrecfldsfail08.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail08.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}
+
+data family F a
+data instance F Int = MkFInt { x :: Int }
+data instance F Bool = MkFBool { y :: Bool }
+
+-- No data type has both these fields, but they belong to the same
+-- lexical parent (F). This used to confuse DuplicateRecordFields.
+foo e = e { x = 3, y = True }
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail09.hs b/tests/examples/ghc8/overloadedrecfldsfail09.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail09.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Int }
+
+-- This tests what happens when an ambiguous record update is used in
+-- a splice: since it can't be represented in TH, it should error
+-- cleanly, rather than panicking or silently using one field.
+foo = [e| (MkS 3) { x = 3 } |]
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail10.hs b/tests/examples/ghc8/overloadedrecfldsfail10.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail10.hs
@@ -0,0 +1,11 @@
+-- Modules A and B both declare F(foo)
+-- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well
+-- Thus we can't export F(..) even with DuplicateRecordFields enabled
+
+{-# LANGUAGE DuplicateRecordFields #-}
+module Main (main, F(..)) where
+
+import OverloadedRecFldsFail10_B
+import OverloadedRecFldsFail10_C
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail11.hs b/tests/examples/ghc8/overloadedrecfldsfail11.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail11.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Werror #-}
+import OverloadedRecFldsFail11_A
+
+main = print (foo (MkS True :: S))
diff --git a/tests/examples/ghc8/overloadedrecfldsfail12.hs b/tests/examples/ghc8/overloadedrecfldsfail12.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail12.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Werror #-}
+
+import OverloadedRecFldsFail12_A
+
+data S = MkS { foo :: Bool }
+
+-- Use of foo and bar should give deprecation warnings
+f :: T -> T
+f e = e { foo = 3, bar = 3 }
+
+s :: T -> Int
+s = foo
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail13.hs b/tests/examples/ghc8/overloadedrecfldsfail13.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail13.hs
@@ -0,0 +1,20 @@
+-- Test that giving a stupid type annotation to an ambiguous field
+-- yields a sensible error message
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Bool }
+data U = MkU
+
+a = x (MkU :: U)
+
+b = x (MkU :: a)
+
+c :: U -> Int
+c = x
+
+d :: a -> Int
+d = x
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsfail14.hs b/tests/examples/ghc8/overloadedrecfldsfail14.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsfail14.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+-- Test that we deal gracefully with non-fields in updates
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Int }
+
+y :: Bool
+y = True
+
+-- y isn't a field
+f r = r { x = 3, y = False }
+
+main = return ()
diff --git a/tests/examples/ghc8/overloadedrecfldsrun01.hs b/tests/examples/ghc8/overloadedrecfldsrun01.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsrun01.hs
@@ -0,0 +1,28 @@
+-- Test that unambiguous constructions remain valid when
+-- DuplicateRecordFields is enabled
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data S = MkS { x :: Int }
+ deriving Show
+
+data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool }
+
+data U a = MkU { x :: a, y :: a }
+
+-- Construction is unambiguous
+s = MkS { x = 42 }
+t = MkT { x = True, y = id, tField = False }
+
+-- Pattern matching is unambiguous
+get_x MkS{x=x} = x
+
+-- Resolving ambiguous monomorphic updates
+a = t { x = False, y = not, tField = True } -- only T has all these fields
+b = s { x = 3 } :: S -- type being pushed in
+c = (t :: T) { x = False } -- type signature on record expression
+
+-- Unambiguous selectors are in scope normally
+z = tField t
+
+main = print (get_x b)
diff --git a/tests/examples/ghc8/overloadedrecfldsrun02.hs b/tests/examples/ghc8/overloadedrecfldsrun02.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsrun02.hs
@@ -0,0 +1,6 @@
+-- This module does not enable -XDuplicateRecordFields, but it should
+-- still be able to refer to non-overloaded fields like `y`
+
+import OverloadedRecFldsRun02_A
+
+main = print (y u)
diff --git a/tests/examples/ghc8/overloadedrecfldsrun03.hs b/tests/examples/ghc8/overloadedrecfldsrun03.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsrun03.hs
@@ -0,0 +1,25 @@
+-- Test that DuplicateRecordFields can be used along with
+-- TypeFamilies (with selectors only if unambiguous)
+
+{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}
+
+data family F a
+
+data instance F Int = MkFInt { foo :: Int }
+data instance F Bool = MkFBool { bar :: Bool, baz :: Bool }
+
+
+data family G a
+
+data instance G Int = MkGInt { foo :: Int }
+data instance G Bool = MkGBool { bar :: Bool }
+
+x = MkFBool { bar = False, baz = True }
+
+y :: F Bool
+y = x { bar = True }
+
+get_bar MkFBool{bar=bar} = bar
+
+main = do print (baz y)
+ print (get_bar y)
diff --git a/tests/examples/ghc8/overloadedrecfldsrun04.hs b/tests/examples/ghc8/overloadedrecfldsrun04.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsrun04.hs
@@ -0,0 +1,30 @@
+-- Test that DuplicateRecordFields works with TemplateHaskell
+
+{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+-- Splice in a datatype with field...
+$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []])
+
+-- New TH story means reify only sees R if we do this:
+$(return [])
+
+-- ... and check that we can inspect it
+main = do putStrLn $(do { info <- reify ''R
+ ; case info of
+ TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) ->
+ do { info' <- reify n
+ ; lift (pprint info ++ "\n" ++ pprint info')
+ }
+ _ -> error "unexpected result of reify"
+ })
+ putStrLn $(do { info <- reify 'foo
+ ; case info of
+ VarI n _ _ ->
+ do { info' <- reify n
+ ; lift (pprint info ++ "\n" ++ pprint info')
+ }
+ })
+ print (foo (MkR { foo = 42 }))
diff --git a/tests/examples/ghc8/overloadedrecfldsrun05.hs b/tests/examples/ghc8/overloadedrecfldsrun05.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsrun05.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/tests/examples/ghc8/overloadedrecfldsrun06.hs b/tests/examples/ghc8/overloadedrecfldsrun06.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/overloadedrecfldsrun06.hs
@@ -0,0 +1,21 @@
+-- Test that ambiguous selectors can be disambiguated by providing
+-- type signatures in various places
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Bool }
+data U a = MkU { x :: a }
+
+x_for_s :: S -> Int
+x_for_s = x
+
+x_for_t = x :: T -> Bool
+
+x_for_u u = x (u :: U Int)
+
+k :: (T -> Bool) -> Bool
+k f = f (MkT True)
+
+main = do print (x_for_s (MkS 42))
+ print (k x)
diff --git a/tests/examples/ghc8/pmc001.hs b/tests/examples/ghc8/pmc001.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc001.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE TypeFamilies, GADTs #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module PMC001 where
+
+data family T a
+
+data instance T [a] where
+ MkT1 :: T [Int]
+ MkT2 :: Char -> T [Char]
+ MkT3 :: T [a]
+
+f :: T [a] -> T [a] -> Bool
+f MkT1 MkT1 = True
+f (MkT2 _) (MkT2 _) = True
+f MkT3 MkT3 = True
+
+g :: T [a] -> T [a] -> Bool
+g x y
+ | MkT1 <- x, MkT1 <- y = True
+ | (MkT2 _) <- x, (MkT2 _) <- y = True
+ | MkT3 <- x, MkT3 <- y = True
diff --git a/tests/examples/ghc8/pmc002.hs b/tests/examples/ghc8/pmc002.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc002.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module PMC002 where
+
+f :: [a] -> Bool
+f [] = True
+f x | (_:_) <- x = False -- exhaustive
diff --git a/tests/examples/ghc8/pmc003.hs b/tests/examples/ghc8/pmc003.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc003.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module PMC003 where
+
+f :: Bool -> Bool -> ()
+f _ False = ()
+f True False = ()
+f _ _ = ()
+
diff --git a/tests/examples/ghc8/pmc004.hs b/tests/examples/ghc8/pmc004.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc004.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+{-# LANGUAGE GADTs #-}
+
+module PMC004 where
+
+data F a where
+ F1 :: F Int
+ F2 :: F Bool
+
+data G a where
+ G1 :: G Int
+ G2 :: G Char
+
+h :: F a -> G a -> ()
+h F1 G1 = ()
+h _ G1 = ()
diff --git a/tests/examples/ghc8/pmc005.hs b/tests/examples/ghc8/pmc005.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc005.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+{-# LANGUAGE GADTs #-}
+
+module PMC005 where
+
+data T a where
+ TList :: T [a]
+ TBool :: T Bool
+
+foo :: T c -> T c -> ()
+foo TList _ = ()
+foo _ TList = ()
diff --git a/tests/examples/ghc8/pmc006.hs b/tests/examples/ghc8/pmc006.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc006.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+
+module PMC006 where
+
+len :: [a] -> Int
+len xs = case xs of
+ [] -> 0
+ (_:ys) -> case () of
+ () | (_:_) <- xs -> 1 + len ys
+
+-- -- we would like these to work too but they don't yet
+--
+-- len :: [a] -> Int
+-- len [] = 0
+-- len xs = case xs of
+-- (_:ys) -> 1 + len ys
+--
+-- len :: [a] -> Int
+-- len xs = case xs of
+-- [] -> 0
+-- ys -> case ys of
+-- (_:zs) -> 1 + len zs
diff --git a/tests/examples/ghc8/pmc007.hs b/tests/examples/ghc8/pmc007.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/pmc007.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module PMC007 where
+
+-- overloaded
+f "ab" = ()
+f "ac" = ()
+
+-- non-overloaded
+g :: String -> ()
+g "ab" = ()
+g "ac" = ()
+
+-- non-overloaded due to type inference
+h :: String -> ()
+h s = let s' = s
+ in case s' of
+ "ab" -> ()
+ "ac" -> ()
diff --git a/tests/examples/ghc8/poly-export.hs b/tests/examples/ghc8/poly-export.hs
--- a/tests/examples/ghc8/poly-export.hs
+++ b/tests/examples/ghc8/poly-export.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
-module Foo (Foo(P,Q)) where
+module Foo (Foo(P)) where
data Foo a = Foo a
@@ -11,7 +11,7 @@
build :: a -> f a
destruct :: f a -> a
-pattern P :: () => C f => a -> f a
+pattern P :: C f => a -> f a
pattern P x <- (destruct -> x)
where
P x = build x
diff --git a/tests/examples/ghc8/poly-export2.hs b/tests/examples/ghc8/poly-export2.hs
--- a/tests/examples/ghc8/poly-export2.hs
+++ b/tests/examples/ghc8/poly-export2.hs
@@ -4,8 +4,8 @@
data A a = A a
-pattern P :: () => Show a => a -> A a
+pattern P :: Show a => a -> A a
pattern P a = A a
-pattern Q :: () => (A ~ f) => a -> f a
+pattern Q :: (A ~ f) => a -> f a
pattern Q a = A a
diff --git a/tests/examples/ghc8/records-check-sels.hs b/tests/examples/ghc8/records-check-sels.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-check-sels.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Qux where
+
+-- Make sure selectors aren't generated for normal synonyms
+
+pattern Uni a = Just a
+
+pattern a :+: b = (a, b)
+
+qux = a (Just True)
diff --git a/tests/examples/ghc8/records-compile.hs b/tests/examples/ghc8/records-compile.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-compile.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern Single{x} = [x]
+
+-- Selector
+selector :: Int
+selector = x [5]
+
+update :: [String]
+update = ["String"] { x = "updated" }
diff --git a/tests/examples/ghc8/records-exquant.hs b/tests/examples/ghc8/records-exquant.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-exquant.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-}
+module ExQuant where
+
+data Showable = forall a . Show a => Showable a
+
+pattern Nasty{a} = Showable a
+
+qux = a (Showable True)
+
+foo = (Showable ()) { a = True }
diff --git a/tests/examples/ghc8/records-mixing-fields.hs b/tests/examples/ghc8/records-mixing-fields.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-mixing-fields.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+data MyRec = MyRec { foo :: Int, qux :: String }
+
+pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
+
+updater,updater1, updater2 :: MyRec -> MyRec
+updater a = a {f1 = 1 }
+
+updater1 a = a {f1 = 1, qux = "two" }
+
+updater2 a = a {f1 = 1, foo = 2 }
diff --git a/tests/examples/ghc8/records-no-uni-update.hs b/tests/examples/ghc8/records-no-uni-update.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-no-uni-update.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+module RecordPats where
+
+-- No updates
+pattern Uni{a,b} <- (a, b)
+
+foo = ("a","b") { a = "b" }
diff --git a/tests/examples/ghc8/records-no-uni-update2.hs b/tests/examples/ghc8/records-no-uni-update2.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-no-uni-update2.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+module RecordPats where
+
+-- No updates
+pattern Uni{a} <- Just a
+
+qux = a (Just True)
+
+qux2 (Uni b) = b
+
+foo = Uni { a = "b" }
diff --git a/tests/examples/ghc8/records-poly-update.hs b/tests/examples/ghc8/records-poly-update.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-poly-update.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Main where
+
+pattern ReqNoProv :: Show a => a -> Maybe a
+pattern ReqNoProv{j} = Just j
+
+data A = A deriving Show
+
+p1 = Just True
+
+p6 = p1 {j = A}
+
+main = print p6
diff --git a/tests/examples/ghc8/records-poly.hs b/tests/examples/ghc8/records-poly.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-poly.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE PatternSynonyms #-}
+module PolyPat where
+
+-- Testing whether type changing updates work correctly.
+
+pattern MyTuple :: a -> b -> (a, b)
+pattern MyTuple{mfst, msnd} = (mfst, msnd)
+
+
+expr1 :: (Int, String) -> (Int, Int)
+expr1 a = a { msnd = 2}
+
+expr3 a = a { msnd = 2}
+
+expr2 :: (a, b) -> a
+expr2 a = mfst a
diff --git a/tests/examples/ghc8/records-prov-req.hs b/tests/examples/ghc8/records-prov-req.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-prov-req.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes,
+ StandaloneDeriving, FlexibleInstances #-}
+module ShouldCompile where
+
+-- Testing that selectors work properly with prov and req thetas
+
+data T a b where
+ MkT :: (Show b) => a -> b -> T a b
+
+deriving instance Show (T Int A)
+
+data G a b = MkG { care :: a, y :: (Show b => b) }
+
+pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b
+pattern ExNumPat{x} = MkT 42 x
+
+data A = A | B deriving (Show, Eq)
+
+f3 :: T Int A
+f3 = (MkT 42 A) { x = B }
+
+f5 :: T Int A
+f5 = (ExNumPat A) { x = B }
+
+
+f4 = (MkG 42 True) { y = False }
diff --git a/tests/examples/ghc8/records-req-only.hs b/tests/examples/ghc8/records-req-only.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-req-only.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Main where
+
+import Prelude (Maybe(..), Show(..), String, Bool(..), print)
+
+pattern ReqNoProv :: Show a => a -> Maybe a
+pattern ReqNoProv{j} = Just j
+
+p1 = ReqNoProv True
+
+p7 (ReqNoProv _) = ReqNoProv False
+
+p6 = p1 {j = False}
+
+main = print p6
diff --git a/tests/examples/ghc8/records-req.hs b/tests/examples/ghc8/records-req.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-req.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-}
+
+-- Pattern synonyms
+
+module ShouldCompile where
+
+data T a where
+ MkT :: (Eq b) => a -> b -> T a
+
+f :: (Show a) => a -> Bool
+f = undefined
+
+pattern P{x} <- MkT (f -> True) x
diff --git a/tests/examples/ghc8/records-run.hs b/tests/examples/ghc8/records-run.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/records-run.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Main where
+
+pattern Bi{a, b} = (a, b)
+
+foo = ("a","b")
+
+main = do
+ print foo
+ print (a foo)
+ print (b foo)
+ print (foo {a = "c"})
+ print (foo {a = "fst", b = "snd"})
diff --git a/tests/examples/ghc8/spec-inline-determ.hs b/tests/examples/ghc8/spec-inline-determ.hs
new file mode 100644
--- /dev/null
+++ b/tests/examples/ghc8/spec-inline-determ.hs
@@ -0,0 +1,40 @@
+module Roman where
+
+-- This is a simplified version of simplCore/should_compile/spec-inline.hs
+--
+-- It reproduces a problem where workers get specialized in different ways
+-- depending on the values of uniques.
+--
+-- Compare:
+--
+-- $s$wgo_s1CN :: Int# -> Int -> Int#
+-- [LclId, Arity=2, Str=DmdType ]
+-- $s$wgo_s1CN =
+-- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) ->
+-- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] {
+-- False ->
+-- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ);
+-- True -> 0#
+-- }
+--
+-- vs
+--
+-- $s$wgo_s18mTj :: Int -> Int# -> Int#
+-- [LclId, Arity=2, Str=DmdType ]
+-- $s$wgo_s18mTj =
+-- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) ->
+-- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] {
+-- False ->
+-- $wgo_s18mUc
+-- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn);
+-- True -> 0#
+-- }
+
+foo :: Int -> Int
+foo n =
+ go (Just n) (Just (6::Int))
+ where
+ go Nothing (Just x) = go (Just 10) (Just x)
+ go (Just n) (Just x)
+ | n <= 0 = 0
+ | otherwise = go (Just (n-1)) (Just x)