packages feed

ghc-exactprint 0.5.0.1 → 0.5.1.0

raw patch · 320 files changed

+8738/−433 lines, 320 filesdep +bytestringdep +ghc-bootdep +textdep ~basedep ~containersdep ~directorynew-component:exe:prepare-hackagePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, ghc-boot, text, time, turtle

Dependency ranges changed: base, containers, directory, filepath, ghc

API changes (from Hackage documentation)

+ Language.Haskell.GHC.ExactPrint.Parsers: parseModuleFromString :: FilePath -> String -> IO (Either (SrcSpan, String) (Anns, ParsedSource))
+ Language.Haskell.GHC.ExactPrint.Preprocess: readFileGhc :: FilePath -> IO String
+ Language.Haskell.GHC.ExactPrint.Transform: graftT :: (Data a) => Anns -> a -> Transform a
- Language.Haskell.GHC.ExactPrint.Transform: cloneT :: (Data a, Typeable a) => a -> Transform (a, [(SrcSpan, SrcSpan)])
+ Language.Haskell.GHC.ExactPrint.Transform: cloneT :: (Data a) => a -> Transform (a, [(SrcSpan, SrcSpan)])
- Language.Haskell.GHC.ExactPrint.Transform: hasDeclsSybTransform :: (Data t2, Typeable t2, Monad m) => (forall t. HasDecls t => t -> m t) -> (LHsBind RdrName -> m (LHsBind RdrName)) -> t2 -> m t2
+ Language.Haskell.GHC.ExactPrint.Transform: hasDeclsSybTransform :: (Data t2, Monad m) => (forall t. HasDecls t => t -> m t) -> (LHsBind RdrName -> m (LHsBind RdrName)) -> t2 -> m t2
- Language.Haskell.GHC.ExactPrint.Transform: hsDeclsGeneric :: (Data t, Typeable t) => t -> Transform [LHsDecl RdrName]
+ Language.Haskell.GHC.ExactPrint.Transform: hsDeclsGeneric :: (Data t) => t -> Transform [LHsDecl RdrName]
- Language.Haskell.GHC.ExactPrint.Transform: insertAfter :: (Data ast, HasDecls (Located ast)) => Located old -> Located ast -> LHsDecl RdrName -> Transform (Located ast)
+ Language.Haskell.GHC.ExactPrint.Transform: insertAfter :: (HasDecls (Located ast)) => Located old -> Located ast -> LHsDecl RdrName -> Transform (Located ast)
- Language.Haskell.GHC.ExactPrint.Transform: insertAtEnd :: (Data ast, HasDecls (Located ast)) => Located ast -> LHsDecl RdrName -> Transform (Located ast)
+ Language.Haskell.GHC.ExactPrint.Transform: insertAtEnd :: (HasDecls (Located ast)) => Located ast -> LHsDecl RdrName -> Transform (Located ast)
- Language.Haskell.GHC.ExactPrint.Transform: insertAtStart :: (Data ast, HasDecls (Located ast)) => Located ast -> LHsDecl RdrName -> Transform (Located ast)
+ Language.Haskell.GHC.ExactPrint.Transform: insertAtStart :: (HasDecls (Located ast)) => Located ast -> LHsDecl RdrName -> Transform (Located ast)
- Language.Haskell.GHC.ExactPrint.Transform: insertBefore :: (Data ast, HasDecls (Located ast)) => Located old -> Located ast -> LHsDecl RdrName -> Transform (Located ast)
+ Language.Haskell.GHC.ExactPrint.Transform: insertBefore :: (HasDecls (Located ast)) => Located old -> Located ast -> LHsDecl RdrName -> Transform (Located ast)
- Language.Haskell.GHC.ExactPrint.Transform: runTransformFromT :: (Monad m) => Int -> Anns -> TransformT m a -> m (a, (Anns, Int), [String])
+ Language.Haskell.GHC.ExactPrint.Transform: runTransformFromT :: Int -> Anns -> TransformT m a -> m (a, (Anns, Int), [String])

Files

ChangeLog view
@@ -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.
ghc-exactprint.cabal view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Annotate.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Delta.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Lookup.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Parsers.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Preprocess.hs view
@@ -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--
src/Language/Haskell/GHC/ExactPrint/Print.hs view
@@ -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 ()
src/Language/Haskell/GHC/ExactPrint/Transform.hs view
@@ -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      -- ---------------------------------
src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -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  -- ---------------------------------------------------------------------
src/Language/Haskell/GHC/ExactPrint/Utils.hs view
@@ -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
+ tests/PrepareHackage.hs view
@@ -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
tests/Roundtrip.hs view
@@ -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)
tests/Static.hs view
@@ -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 "</br>"   [mkLink prev "prev"-  , mkLink "failures.html" "home"+  , mkLink failuresHtmlFile "home"   , mkLink next "next"   , ""+  , "<pre>" ++ filename ++ "</pre>"+  , ""   , "<pre>" ++ diff ++ "</pre>"   , "<h2>original</h2>"   , "<pre>" ++ original ++ "</pre>"@@ -81,6 +93,7 @@  data Failure = Failure String FilePath +getfname :: Failure -> FilePath getfname (Failure _ fp) = fp  parseFail :: FilePath -> IO Failure
tests/Test.hs view
@@ -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
tests/Test/Common.hs view
@@ -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))+
tests/Test/Transform.hs view
@@ -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
+ tests/examples/failing/OverloadedLabelsRun04_A.hs view
@@ -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" |]
+ tests/examples/failing/overloadedlabelsrun04.hs view
@@ -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
+ tests/examples/failing/overloadedlabelsrun04.hs.bad view
@@ -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
+ tests/examples/ghc710/CoreIr.hs view
@@ -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)+
tests/examples/ghc710/DataDecl.hs view
@@ -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
tests/examples/ghc710/HashQQ.hs view
@@ -33,7 +33,7 @@ application/andrew-inset      ez |]  -testComplex    = assertBool "" ([$istr|+testComplex    = assertBool "" ([istr|         ok #{Foo 4 "Great!" : [Foo 3 "Scott!"]}         then
+ tests/examples/ghc710/MachineTypes.hs view
@@ -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+                -<< ()+
+ tests/examples/ghc710/Process.hs view
@@ -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 (<afterEnd) $ iterate succNoteId start+++newtype NoteOffList =+   NoteOffList {+      unwrapNoteOffList :: Events (NoteBoundary NoteId)+   }+++instance CutG.Read NoteOffList where+   null (NoteOffList evs) =+      EventListTT.isPause evs && EventListTT.duration evs == 0+   length = fromIntegral . EventListTT.duration . unwrapNoteOffList++instance CutG.NormalForm NoteOffList where+   evaluateHead =+      EventListMT.switchTimeL (\t _ -> 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
+ tests/examples/ghc710/Process1.hs view
@@ -0,0 +1,7 @@+module Synthesizer.MIDI.CausalIO.Process1 where++gateFromNoteOffs=+   let dur = 1+   in (d, 3+          {-+            AllNotesOff -> VoiceMsg.normalVelocity -} )
tests/examples/ghc710/QuasiQuote.hs view
@@ -20,7 +20,7 @@  {-# LANGUAGE QuasiQuotes #-} -testComplex    = assertBool "" ([$istr|+testComplex    = assertBool "" ([istr|         ok #{Foo 4 "Great!" : [Foo 3 "Scott!"]}         then
− tests/examples/ghc710/TypeFamilies.hs 
@@ -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
tests/examples/ghc8/A.hs view
@@ -1,3 +1,4 @@ module A where -data A = A+class A a where+  has :: a
tests/examples/ghc8/B.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}- module B where -import A--b :: Maybe a-b = Nothing+class B a where+  has :: a
+ tests/examples/ghc8/BadTelescope.hs view
@@ -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)
+ tests/examples/ghc8/BadTelescope2.hs view
@@ -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
+ tests/examples/ghc8/BadTelescope3.hs view
@@ -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
+ tests/examples/ghc8/BadTelescope4.hs view
@@ -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.
+ tests/examples/ghc8/Base.hs view
@@ -0,0 +1,6 @@+module Base (AClass(..), BClass()) where++import Extends (BClass ())++class AClass a where+  has :: a
+ tests/examples/ghc8/Bundle.hs view
@@ -0,0 +1,9 @@+module Bundle(A(..)) where++import BundleInternal (A(..))++foo = MkA 5+baz = NoA++qux (MkA x) = x+qux NoA = 0
+ tests/examples/ghc8/Bundle1.hs view
@@ -0,0 +1,9 @@+module Associated1(A(..)) where++import BundleInternal1 (A(..))++foo = MkA 5+baz = NoA++qux (MkA x) = x+qux NoA = 0
+ tests/examples/ghc8/BundleExport.hs view
@@ -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
+ tests/examples/ghc8/BundleInternal.hs view
@@ -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
+ tests/examples/ghc8/BundleInternal1.hs view
@@ -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
+ tests/examples/ghc8/CustomTypeErrors01.hs view
@@ -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++
+ tests/examples/ghc8/CustomTypeErrors02.hs view
@@ -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++
+ tests/examples/ghc8/CustomTypeErrors03.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE DataKinds #-}+module T3 where++import GHC.TypeLits++f :: TypeError (Text "This is a type error")+f = undefined
+ tests/examples/ghc8/Dep1.hs view
@@ -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
+ tests/examples/ghc8/Dep2.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PolyKinds, GADTs #-}++module Dep2 where++data G (a :: k) where+  G1 :: G Int+  G2 :: G Maybe
+ tests/examples/ghc8/Dep3.hs view
@@ -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
+ tests/examples/ghc8/DepFail1.hs view
@@ -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
+ tests/examples/ghc8/Deprecation.hs view
@@ -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." #-}
+ tests/examples/ghc8/DsStrict.hs view
@@ -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
+ tests/examples/ghc8/DsStrictFail.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE Strict #-}+module Main where++main = let False = True+       in return ()
+ tests/examples/ghc8/DsStrictLet.hs view
@@ -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 ()
+ tests/examples/ghc8/DsStrictWarn.hs view
@@ -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"
+ tests/examples/ghc8/Eq.hs view
@@ -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)
+ tests/examples/ghc8/ExprSigLocal.hs view
@@ -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
+ tests/examples/ghc8/Extends.hs view
@@ -0,0 +1,4 @@+module Extends where++class BClass b where+  has :: b
+ tests/examples/ghc8/FrontendPlugin.hs view
@@ -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 ()
+ tests/examples/ghc8/Generate.hs view
@@ -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 ""
+ tests/examples/ghc8/KindEqualities.hs view
@@ -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
+ tests/examples/ghc8/KindEqualities2.hs view
@@ -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)
+ tests/examples/ghc8/KindLevels.hs view
@@ -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 -> *
+ tests/examples/ghc8/LiteralsTest2.hs view
@@ -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
tests/examples/ghc8/Main.hs view
@@ -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|<!anything~|] -> print fixed_var+  putStrLn ( $(pr "Hello From Template Haskell!") )+  talkToCxx
+ tests/examples/ghc8/MonadFailErrors.hs view
@@ -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
+ tests/examples/ghc8/MonadFailWarnings.hs view
@@ -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
+ tests/examples/ghc8/MonadFailWarningsDisabled.hs view
@@ -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
+ tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs view
@@ -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
+ tests/examples/ghc8/MultiLineWarningPragma.hs view
@@ -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!"+  #-}
+ tests/examples/ghc8/MultiWayIf.hs view
@@ -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 | () <- () -> ()
+ tests/examples/ghc8/OverloadedRecFldsFail04_A.hs view
@@ -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
+ tests/examples/ghc8/OverloadedRecFldsFail06_A.hs view
@@ -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
+ tests/examples/ghc8/OverloadedRecFldsFail10_A.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+module OverloadedRecFldsFail10_A where++data family F a+data instance F Int = MkFInt { foo :: Int }
+ tests/examples/ghc8/OverloadedRecFldsFail10_B.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+module OverloadedRecFldsFail10_B (F(..)) where++import OverloadedRecFldsFail10_A hiding (foo)++data instance F Bool = MkFBool { foo :: Int }
+ tests/examples/ghc8/OverloadedRecFldsFail10_C.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}+module OverloadedRecFldsFail10_C (F(..)) where++import OverloadedRecFldsFail10_A++data instance F Char = MkFChar { foo :: Char }
+ tests/examples/ghc8/OverloadedRecFldsFail11_A.hs view
@@ -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 }
+ tests/examples/ghc8/OverloadedRecFldsFail12_A.hs view
@@ -0,0 +1,5 @@+module OverloadedRecFldsFail12_A where++{-# WARNING foo "Deprecated foo" #-}+{-# WARNING bar "Deprecated bar" #-}+data T = MkT { foo :: Int, bar :: Int }
+ tests/examples/ghc8/OverloadedRecFldsRun02_A.hs view
@@ -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
+ tests/examples/ghc8/ParenFunBind.hs view
@@ -0,0 +1,5 @@+module ParenFunBind where++(foo x)   y  = x + y+((bar x)) y  = x + y+((baz x)) (y) = x + y
+ tests/examples/ghc8/ParenTypeSynonym.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE ConstraintKinds #-}+module ParenTypeSynonym where++type Is = (~)
+ tests/examples/ghc8/PluralS.hs view
@@ -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
+ tests/examples/ghc8/PolyInstances.hs view
@@ -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))
+ tests/examples/ghc8/PopCnt.hs view
@@ -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#))+
+ tests/examples/ghc8/Primop.hs view
@@ -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# #)
+ tests/examples/ghc8/Printf.hs view
@@ -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)
+ tests/examples/ghc8/PromotedClass.hs view
@@ -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
+ tests/examples/ghc8/RAE_T32a.hs view
@@ -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.
+ tests/examples/ghc8/RAE_T32b.hs view
@@ -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)
+ tests/examples/ghc8/Rae31.hs view
@@ -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) *)
+ tests/examples/ghc8/RaeBlogPost.hs view
@@ -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 = (* :: (* :: (* :: *)))
+ tests/examples/ghc8/RenamingStar.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeInType #-}++module RenamingStar where++data Foo :: *
+ tests/examples/ghc8/SelfDep.hs view
@@ -0,0 +1,3 @@+module SelfDep where++data T :: T -> *
+ tests/examples/ghc8/SemigroupWarnings.hs view
@@ -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
+ tests/examples/ghc8/SigTvKinds.hs view
@@ -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
+ tests/examples/ghc8/SigTvKinds2.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PolyKinds #-}++module SigTvKinds2 where++data SameKind :: k -> k -> *++data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
tests/examples/ghc8/T10041.hs view
+ tests/examples/ghc8/T10045.hs view
@@ -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
− tests/examples/ghc8/T10196Fail1.hs 
@@ -1,4 +0,0 @@-module T10196Fail1 where---- Constructors are not allowed to start with a modifier letter.-data Foo = ᵦfoo
− tests/examples/ghc8/T10196Fail2.hs 
@@ -1,4 +0,0 @@-module T10196Fail2 where---- Variables are not allowed to start with a modifier letter.-ᵦ = 1
− tests/examples/ghc8/T10196Fail3.hs 
@@ -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
+ tests/examples/ghc8/T10215.hs view
@@ -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)
+ tests/examples/ghc8/T10267.hs view
@@ -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
+ tests/examples/ghc8/T10267a.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}++module T10267a where++import Language.Haskell.TH++varX :: Q Exp+varX = [| x |]
tests/examples/ghc8/T10279.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} module T10279 where import Language.Haskell.TH import Language.Haskell.TH.Syntax
+ tests/examples/ghc8/T10318.hs view
@@ -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))+
+ tests/examples/ghc8/T10361a.hs view
@@ -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'
+ tests/examples/ghc8/T10361b.hs view
@@ -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)
+ tests/examples/ghc8/T10370.hs view
@@ -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"
+ tests/examples/ghc8/T10487.hs view
@@ -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
+ tests/examples/ghc8/T10487_M.hs view
@@ -0,0 +1,3 @@+module T10487_M where++data Name = Name
tests/examples/ghc8/T10524.hs view
@@ -6,3 +6,4 @@  newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) +-- WrappedFunctor :: forall k. (k -> *) -> k -> *
+ tests/examples/ghc8/T10549a.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -O #-}+module Main(main) where+import GHC.Exts+main = print 1+go (Ptr a) = a
− tests/examples/ghc8/T10582.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE Arrows #-}--module T10582 where--(|:) :: Int -> Int -> Int-(|:) = (+)
tests/examples/ghc8/T10615.hs view
@@ -6,5 +6,3 @@  f2 :: _ -> _f f2 = const--
tests/examples/ghc8/T10638.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-}  import Language.Haskell.TH
+ tests/examples/ghc8/T10662.hs view
@@ -0,0 +1,4 @@+main :: IO ()+main = do+  return $ let a = "hello" in a+  return ()
+ tests/examples/ghc8/T10667.hs view
@@ -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
+ tests/examples/ghc8/T10678.hs view
@@ -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.+-}
+ tests/examples/ghc8/T10734.hs view
@@ -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
+ tests/examples/ghc8/T10747.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}++module T10747 where++pattern head `Cons` tail = head : tail
+ tests/examples/ghc8/T10767.hs view
@@ -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)
+ tests/examples/ghc8/T10796a.hs view
@@ -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))
+ tests/examples/ghc8/T10796b.hs view
@@ -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
+ tests/examples/ghc8/T10819.hs view
@@ -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
+ tests/examples/ghc8/T10819_Lib.hs view
@@ -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
+ tests/examples/ghc8/T10820.hs view
@@ -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)
+ tests/examples/ghc8/T10845.hs view
@@ -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
+ tests/examples/ghc8/T10846.hs view
@@ -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
+ tests/examples/ghc8/T10870.hs view
@@ -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 ]
+ tests/examples/ghc8/T10890.hs view
@@ -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 ()
+ tests/examples/ghc8/T10890_1.hs view
@@ -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 ()
+ tests/examples/ghc8/T10890_2.hs view
@@ -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
+ tests/examples/ghc8/T10890_2A.hs view
@@ -0,0 +1,4 @@+module T10890_2A where++class A a where+  has :: a
+ tests/examples/ghc8/T10890_2B.hs view
@@ -0,0 +1,4 @@+module T10890_2B where++class B a where+  has :: a
+ tests/examples/ghc8/T10891.hs view
@@ -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''+      [| () |])
+ tests/examples/ghc8/T10897a.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE PatternSynonyms #-}+module T10897a where+pattern Single :: a -> a+pattern Single x = x
+ tests/examples/ghc8/T10897b.hs view
@@ -0,0 +1,4 @@+module B where+import T10897a++Single y = True
+ tests/examples/ghc8/T10904.hs view
@@ -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
+ tests/examples/ghc8/T10908.hs view
@@ -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
+ tests/examples/ghc8/T10929.hs view
@@ -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]
+ tests/examples/ghc8/T10931.hs view
@@ -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
+ tests/examples/ghc8/T10934.hs view
@@ -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
+ tests/examples/ghc8/T10935.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-}++module T10935 where++f x = let y = x+1 in (y,y)
+ tests/examples/ghc8/T10942.hs view
@@ -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))
+ tests/examples/ghc8/T10942_A.hs view
@@ -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 ()
+ tests/examples/ghc8/T10945.hs view
@@ -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"))) []]+ ])
+ tests/examples/ghc8/T10946.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}++module T10946 where++import Language.Haskell.TH++m :: a -> a+m x = $$([||_||])
+ tests/examples/ghc8/T10955dyn.hs view
@@ -0,0 +1,7 @@+module Main where++import Foreign+import Foreign.C.Types+foreign import ccall "bar" dle :: IO CInt++main = dle >>= print
+ tests/examples/ghc8/T10962.hs view
@@ -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)
+ tests/examples/ghc8/T10970a.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}+main = do+#ifndef VERSION_containers+    putStrLn "OK"+#endif+#ifndef MIN_VERSION_base+    putStrLn "OK"+#endif
+ tests/examples/ghc8/T10971a.hs view
@@ -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)
+ tests/examples/ghc8/T10971b.hs view
@@ -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)
+ tests/examples/ghc8/T10971c.hs view
@@ -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)
+ tests/examples/ghc8/T10971d.hs view
@@ -0,0 +1,6 @@+import T10971c++main = do+  print $ f (Just 1)+  print $ g (+1) (Just 5)+  print $ h (const 5) Nothing
+ tests/examples/ghc8/T10997.hs view
@@ -0,0 +1,6 @@+module T10997 where++import T10997a++foo :: Exp a -> String+foo Tru = "True"
+ tests/examples/ghc8/T10997_1.hs view
@@ -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
+ tests/examples/ghc8/T10997_1a.hs view
@@ -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+
+ tests/examples/ghc8/T10997a.hs view
@@ -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++
+ tests/examples/ghc8/T10999.hs view
@@ -0,0 +1,8 @@+module T10999 where++import qualified Data.Set as Set++f :: _ => () -> _+f _ = Set.fromList undefined++g = map fst $ Set.toList $ f ()
+ tests/examples/ghc8/T11010.hs view
@@ -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
+ tests/examples/ghc8/T11016.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-}++module T11016 where++f1 :: (?x :: Int, _) => Int+f1 = ?x++f2 :: (?x :: Int) => _+f2 = ?x
+ tests/examples/ghc8/T11039.hs view
@@ -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
+ tests/examples/ghc8/T11053.hs view
@@ -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
+ tests/examples/ghc8/T11067.hs view
@@ -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
+ tests/examples/ghc8/T11071.hs view
@@ -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
+ tests/examples/ghc8/T11071a.hs view
@@ -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
+ tests/examples/ghc8/T11076.hs view
@@ -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
+ tests/examples/ghc8/T11076A.hs view
@@ -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#
+ tests/examples/ghc8/T11077.hs view
@@ -0,0 +1,3 @@+module T11077 (module X, foo) where+import Data.List as X+foo = undefined
+ tests/examples/ghc8/T11103.hs view
@@ -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")
+ tests/examples/ghc8/T11112.hs view
@@ -0,0 +1,4 @@+module T11112 where++sort :: Ord s -> [s] -> [s]+sort xs = xs
+ tests/examples/ghc8/T11128.hs view
@@ -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+    (>>)   = (*>)
+ tests/examples/ghc8/T11136.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}++module T11136 where++class C a where+  type D a+  type instance D a x = x
+ tests/examples/ghc8/T11142.hs view
@@ -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
+ tests/examples/ghc8/T11148.hs view
@@ -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
+ tests/examples/ghc8/T11155.hs view
@@ -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]+
+ tests/examples/ghc8/T11164.hs view
@@ -0,0 +1,3 @@+module T11164 where++import T11164b (T)
+ tests/examples/ghc8/T11164a.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TypeFamilies #-}+module T11164a where++data family T a
+ tests/examples/ghc8/T11164b.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+module T11164b where++import T11164a++data instance T Int = MkT
+ tests/examples/ghc8/T11167.hs view
@@ -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 ())
+ tests/examples/ghc8/T11167_ambig.hs view
@@ -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 ())
+ tests/examples/ghc8/T11167_ambiguous_fixity.hs view
@@ -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
+ tests/examples/ghc8/T11167_ambiguous_fixity_A.hs view
@@ -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`
+ tests/examples/ghc8/T11167_ambiguous_fixity_B.hs view
@@ -0,0 +1,3 @@+module T11167_ambiguous_fixity_B where+data B = MkB { foo :: Int -> Int }+infixl 5 `foo`
+ tests/examples/ghc8/T11173.hs view
@@ -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
+ tests/examples/ghc8/T11173a.hs view
@@ -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
+ tests/examples/ghc8/T11182.hs view
@@ -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"
+ tests/examples/ghc8/T11187.hs view
@@ -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
+ tests/examples/ghc8/T11192.hs view
@@ -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
+ tests/examples/ghc8/T11193.hs view
@@ -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"
+ tests/examples/ghc8/T11208.hs view
@@ -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
+ tests/examples/ghc8/T11216.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE RebindableSyntax #-}++module Bug where++foo :: (a, b) -> ()+foo x | (_,_) <- x = ()
+ tests/examples/ghc8/T11224.hs view
@@ -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
+ tests/examples/ghc8/T11232.hs view
@@ -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 }
+ tests/examples/ghc8/T11237.hs view
@@ -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
+ tests/examples/ghc8/T1830_1.hs view
@@ -0,0 +1,5 @@+module T1830_1 where++import Language.Haskell.TH.Syntax (Lift)++data Foo a = Foo a deriving Lift
+ tests/examples/ghc8/T1830_2.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE DeriveLift #-}+module T1830_2 where++import Language.Haskell.TH.Syntax (Lift)++data Nothing deriving Lift
+ tests/examples/ghc8/T1830_3.hs view
@@ -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)
+ tests/examples/ghc8/T1830_3a.hs view
@@ -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'
+ tests/examples/ghc8/T2006.hs view
@@ -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"+
+ tests/examples/ghc8/T2204.hs view
@@ -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
tests/examples/ghc8/T2632.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} -- Trac #2632  module MkData where
+ tests/examples/ghc8/T3078.hs view
@@ -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
+ tests/examples/ghc8/T322.hs view
@@ -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
tests/examples/ghc8/T3572.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  -- Trac #3572 
+ tests/examples/ghc8/T365.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-}+module Main where++main = print "Hello World"
+ tests/examples/ghc8/T366.hs view
@@ -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 = ' '
+ tests/examples/ghc8/T3927.hs view
@@ -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
+ tests/examples/ghc8/T3927a.hs view
@@ -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 = ()+
+ tests/examples/ghc8/T3927b.hs view
@@ -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
tests/examples/ghc8/T4056.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  module T4056 where import Language.Haskell.TH
+ tests/examples/ghc8/T4139.hs view
@@ -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 _ = ()++
tests/examples/ghc8/T4169.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} -- Crashed GHC 6.12  module T4165 where
tests/examples/ghc8/T4170.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} module T4170 where  import Language.Haskell.TH
tests/examples/ghc8/T5908.hs view
@@ -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
tests/examples/ghc8/T6018.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE PolyKinds                 #-}-{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE NoMonomorphismRestriction #-}
tests/examples/ghc8/T6018th.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-}  module T6018th where
tests/examples/ghc8/T6062.hs view
@@ -1,2 +1,3 @@+{-# LANGUAGE TemplateHaskellQuotes #-} module T6062 where x = [| False True |]
+ tests/examples/ghc8/T6124.hs view
@@ -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
+ tests/examples/ghc8/T7669a.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}++module T7669 where++data Void++foo :: Void -> ()+foo x = case x of {}
tests/examples/ghc8/T8455.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE DataKinds #-}  module T8455 where
tests/examples/ghc8/T8759a.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE PatternSynonyms #-}  module T8759a where
+ tests/examples/ghc8/T8970.hs view
@@ -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
+ tests/examples/ghc8/T9015.hs view
@@ -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)
+ tests/examples/ghc8/T9017.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PolyKinds #-}++module T9017 where++import Control.Arrow++foo :: a b (m b)+foo = arr return
− tests/examples/ghc8/T9225.hs 
@@ -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
+ tests/examples/ghc8/T9238.hs view
@@ -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 ]
+ tests/examples/ghc8/T9632.hs view
@@ -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' -> *
− tests/examples/ghc8/T9723a.hs 
@@ -1,9 +0,0 @@--{-# OPTIONS -fwarn-tabs #-}---- Check we get a warning for a single tab--module ShouldCompile where--tab1	= 'a'-
− tests/examples/ghc8/T9723b.hs 
@@ -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
tests/examples/ghc8/T9824.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_GHC -fwarn-unused-matches #-}  module T9824 where
+ tests/examples/ghc8/T9951.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}++module T9951 where++f :: [a] -> ()+f x = case x of+  [] -> ()+  (_:_) -> ()+
+ tests/examples/ghc8/T9951b.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}++module T9951b where++f :: String -> Bool+f "ab" = True
+ tests/examples/ghc8/T9968.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}++module T9968 where++class C a b+data X = X deriving (C Int)+
+ tests/examples/ghc8/T9968a.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DeriveAnyClass #-}++module T9968 where++import Data.Bifunctor++data Blah a b = A a | B b+  deriving (Bifunctor)
tests/examples/ghc8/TH_abstractFamily.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} module TH_abstractFamily where  import Language.Haskell.TH
tests/examples/ghc8/TH_bracket1.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} -- Check that declarations in a bracket shadow the top-level -- declarations, rather than clashing with them. 
tests/examples/ghc8/TH_bracket2.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} module TH_bracket2 where  d_show = [d| data A = A
tests/examples/ghc8/TH_bracket3.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  module TH_bracket3 where 
+ tests/examples/ghc8/TH_finalizer.hs view
@@ -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 [] )
tests/examples/ghc8/TH_localname.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} module TH_localname where  x = \y -> [| y |]
+ tests/examples/ghc8/TH_nameSpace.hs view
@@ -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+             ]
tests/examples/ghc8/TH_ppr1.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Main (main) where
tests/examples/ghc8/TH_repE1.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} -- test the representation of literals and also explicit type annotations  module TH_repE1
tests/examples/ghc8/TH_repE3.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} -- test the representation of literals and also explicit type annotations  module TH_repE1
tests/examples/ghc8/TH_scope.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskellQuotes #-} -- Test for Trac #2188  module TH_scope where
+ tests/examples/ghc8/TH_spliceE5_prof_ext.hs view
@@ -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"
+ tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs view
@@ -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)
+ tests/examples/ghc8/Test10276.hs view
@@ -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]))||]
+ tests/examples/ghc8/Test11018.hs view
@@ -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
+ tests/examples/ghc8/TransBundle.hs view
@@ -0,0 +1,9 @@+module TransAssociated(A(..)) where++import Bundle (A(..))++foo = MkA 5+baz = NoA++qux (MkA x) = x+qux NoA = 0
+ tests/examples/ghc8/TypeLevelVec.hs view
@@ -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 ++
+ tests/examples/ghc8/TypeSkolEscape.hs view
@@ -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
+ tests/examples/ghc8/UnicodeRules.hs view
@@ -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)
+ tests/examples/ghc8/UnicodeSyntax.hs view
@@ -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)+      }+
+ tests/examples/ghc8/Vta1.hs view
@@ -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
+ tests/examples/ghc8/Vta2.hs view
@@ -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)
+ tests/examples/ghc8/WCompatWarningsNotOn.hs view
@@ -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
+ tests/examples/ghc8/WCompatWarningsOff.hs view
@@ -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
+ tests/examples/ghc8/WCompatWarningsOn.hs view
@@ -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
+ tests/examples/ghc8/WCompatWarningsOnOff.hs view
@@ -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
+ tests/examples/ghc8/determ004.hs view
@@ -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 <L,U><L,U><L,U><C(S(C(S))),C(U(1*C1(U)))>]+$s$wsFoldr1_szbtK =+  \ (@ (m_azbFg :: a_afdP_azbON))+    (@ (x_azbOM :: TyFun+                     a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *)+                   -> *))+    (@ (a_afdP_azbON :: BOX))+    (@ (ipv_szbwN :: a_afdP_azbON))+    (@ (ipv_szbwO :: [a_afdP_azbON]))+    (sg_szbtL+       :: R:Sing[]z (ipv_szbwN : ipv_szbwO)+          ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO))+    (sc_szbtM :: Sing ipv_szbwO)+    (sc_szbtN :: Sing ipv_szbwN)+    (sc_szbtP+       :: forall (t_azbNM :: a_afdP_azbON).+          Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) ->+    case (SCons+            @ a_afdP_azbON+            @ (ipv_szbwN : ipv_szbwO)+            @ ipv_szbwO+            @ ipv_szbwN+            @~ (<ipv_szbwN : ipv_szbwO>_N+                :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO))+            sc_szbtN+            sc_szbtM)+         `cast` (sg_szbtL+                 ; TFCo:R:Sing[]z[0] <a_afdP_azbON>_N <Let1627448493XsSym4+                                                         x_azbOM m_azbFg ipv_szbwN ipv_szbwO>_N+                 :: R:Sing[]z (ipv_szbwN : ipv_szbwO)+                    ~R# R:Sing[]z+                          (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))+    of wild_XD {+      SNil dt_dzbxX ->+        (lvl_szbwi @ a_afdP_azbON)+        `cast` ((Sing+                   (Sym (TFCo:R:Foldr1[2] <a_afdP_azbON>_N <x_azbOM>_N)+                    ; Sym+                        (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]+                           <a_afdP_azbON>_N <'[]>_N <x_azbOM>_N)+                    ; (Apply+                         (Sym+                            (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))+                         (Sym dt_dzbxX))_N))_R+                :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list")+                   ~R# Sing+                         (Apply+                            (Apply Foldr1Sym0 x_azbOM)+                            (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)));+      SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH+            ds_dzbyu [Dmd=<S,1*U>] ->+        case ds_dzbyu+             `cast` (TFCo:R:Sing[]z[0] <a_afdP_azbON>_N <n_azbFh>_N+                     :: Sing n_azbFh ~R# R:Sing[]z n_azbFh)+        of wild_Xo {+          SNil dt_dzbxk ->+            (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe)+            `cast` ((Sing+                       (Sym (TFCo:R:Foldr1[0] <a_afdP_azbON>_N <m_XzbGe>_N <x_azbOM>_N)+                        ; Sym+                            (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]+                               <a_afdP_azbON>_N <'[m_XzbGe]>_N <x_azbOM>_N)+                        ; (Apply+                             (Sym+                                (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))+                             ((<m_XzbGe>_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R+                    :: Sing m_XzbGe+                       ~R# Sing+                             (Apply+                                (Apply Foldr1Sym0 x_azbOM)+                                (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)));+          SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK ->+            case (sc_szbtP @ m_XzbGe _sX_azbOH)+                 `cast` (TFCo:R:Sing(->)f[0]+                           <a_afdP_azbON>_N <a_afdP_azbON>_N <Apply x_azbOM m_XzbGe>_N+                         :: Sing (Apply x_azbOM m_XzbGe)+                            ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe))+            of wild_X3X { SLambda ds_XzbBr [Dmd=<C(S),1*C1(U)>] ->+            (ds_XzbBr+               @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR))+               (($wsFoldr1_szbuc+                   @ a_afdP_azbON+                   @ x_azbOM+                   @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)+                   sc_szbtP+                   ((SCons+                       @ a_afdP_azbON+                       @ (ipv_XzbyV : ipv_XzbxR)+                       @ ipv_XzbxR+                       @ ipv_XzbyV+                       @~ (<ipv_XzbyV : ipv_XzbxR>_N+                           :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR))+                       ipv_szbwL+                       ipv_szbwK)+                    `cast` (Sym (TFCo:R:Sing[]z[0] <a_afdP_azbON>_N) (Sym+                                                                        (TFCo:R:Apply[][]:$$i[0]+                                                                           <a_afdP_azbON>_N+                                                                           <ipv_XzbxR>_N+                                                                           <ipv_XzbyV>_N)+                                                                      ; (Apply+                                                                           (Sym+                                                                              (TFCo:R:Applyk(->):$l[0]+                                                                                 <a_afdP_azbON>_N+                                                                                 <ipv_XzbyV>_N))+                                                                           <ipv_XzbxR>_N)_N)+                            :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR)+                               ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR))))+                `cast` ((Sing+                           ((Apply+                               (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N)+                               <Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR>_N)_N+                            ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]+                                <a_afdP_azbON>_N+                                ((Apply+                                    (TFCo:R:Applyk(->):$l[0] <a_afdP_azbON>_N <ipv_XzbyV>_N)+                                    <ipv_XzbxR>_N)_N+                                 ; TFCo:R:Apply[][]:$$i[0]+                                     <a_afdP_azbON>_N <ipv_XzbxR>_N <ipv_XzbyV>_N)+                                <x_azbOM>_N))_R+                        :: Sing+                             (Apply+                                (Apply Foldr1Sym0 x_azbOM)+                                (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR))+                           ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR)))))+            `cast` ((Sing+                       ((Apply+                           <Apply x_azbOM m_XzbGe>_N+                           (Sym+                              (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]+                                 <a_afdP_azbON>_N <ipv_XzbyV : ipv_XzbxR>_N <x_azbOM>_N)+                            ; (Apply+                                 (Sym+                                    (TFCo:R:Apply(->)(->)Foldr1Sym0l[0]+                                       <a_afdP_azbON>_N <x_azbOM>_N))+                                 (Sym+                                    (TFCo:R:Apply[][]:$$i[0]+                                       <a_afdP_azbON>_N <ipv_XzbxR>_N <ipv_XzbyV>_N)+                                  ; (Apply+                                       (Sym+                                          (TFCo:R:Applyk(->):$l[0] <a_afdP_azbON>_N <ipv_XzbyV>_N))+                                       <ipv_XzbxR>_N)_N))_N))_N+                        ; Sym+                            (TFCo:R:Foldr1[1]+                               <a_afdP_azbON>_N+                               <ipv_XzbxR>_N+                               <ipv_XzbyV>_N+                               <m_XzbGe>_N+                               <x_azbOM>_N)+                        ; Sym+                            (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]+                               <a_afdP_azbON>_N <m_XzbGe : ipv_XzbyV : ipv_XzbxR>_N <x_azbOM>_N)+                        ; (Apply+                             (Sym+                                (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))+                             ((<m_XzbGe>_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R+                    :: Sing+                         (Apply+                            (Apply x_azbOM m_XzbGe)+                            (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR)))+                       ~R# Sing+                             (Apply+                                (Apply Foldr1Sym0 x_azbOM)+                                (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)))+            }+        }+    }+...+-}++module List (sFoldr1) where++data Proxy t++data family Sing (a :: k)++data TyFun (a :: *) (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
+ tests/examples/ghc8/determinism001.hs view
@@ -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
+ tests/examples/ghc8/dynamic-paper.hs view
@@ -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
+ tests/examples/ghc8/export-ps-rec-sel.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}+module Foo( R(P,x)) where++data Q = Q Int++data R = R++pattern P{x} = Q x
+ tests/examples/ghc8/export-record-selector.hs view
@@ -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
tests/examples/ghc8/export-super-class-fail.hs view
@@ -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
tests/examples/ghc8/export-super-class.hs view
@@ -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
tests/examples/ghc8/export-syntax.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} module Foo(A(.., B)) where  data A = A | B
+ tests/examples/ghc8/export-type-synonym.hs view
@@ -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
tests/examples/ghc8/export-type.hs view
@@ -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
+ tests/examples/ghc8/frontend01.hs view
@@ -0,0 +1,1 @@+main = putStrLn "hello world"
− tests/examples/ghc8/import-syntax.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module Foo where--import ImportSyntax (A(.., B))
+ tests/examples/ghc8/mixed-pat-syn-record-sels.hs view
@@ -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 }
+ tests/examples/ghc8/mkGADTVars.hs view
@@ -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
+ tests/examples/ghc8/overloadedlabelsfail01.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedlabelsrun01.hs view
@@ -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
+ tests/examples/ghc8/overloadedlabelsrun02.hs view
@@ -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"])
+ tests/examples/ghc8/overloadedlabelsrun03.hs view
@@ -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
+ tests/examples/ghc8/overloadedrecflds_generics.hs view
@@ -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))
+ tests/examples/ghc8/overloadedrecfldsfail01.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail02.hs view
@@ -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))
+ tests/examples/ghc8/overloadedrecfldsfail03.hs view
@@ -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
+ tests/examples/ghc8/overloadedrecfldsfail04.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail05.hs view
@@ -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))
+ tests/examples/ghc8/overloadedrecfldsfail06.hs view
@@ -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 }))
+ tests/examples/ghc8/overloadedrecfldsfail07.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail08.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail09.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail10.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail11.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# OPTIONS_GHC -Werror #-}+import OverloadedRecFldsFail11_A++main = print (foo (MkS True :: S))
+ tests/examples/ghc8/overloadedrecfldsfail12.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail13.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsfail14.hs view
@@ -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 ()
+ tests/examples/ghc8/overloadedrecfldsrun01.hs view
@@ -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)
+ tests/examples/ghc8/overloadedrecfldsrun02.hs view
@@ -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)
+ tests/examples/ghc8/overloadedrecfldsrun03.hs view
@@ -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)
+ tests/examples/ghc8/overloadedrecfldsrun04.hs view
@@ -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 }))
+ tests/examples/ghc8/overloadedrecfldsrun05.hs view
@@ -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
+ tests/examples/ghc8/overloadedrecfldsrun06.hs view
@@ -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)
+ tests/examples/ghc8/pmc001.hs view
@@ -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
+ tests/examples/ghc8/pmc002.hs view
@@ -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
+ tests/examples/ghc8/pmc003.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}++module PMC003 where++f :: Bool -> Bool -> ()+f _    False = ()+f True False = ()+f _    _     = ()+
+ tests/examples/ghc8/pmc004.hs view
@@ -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 = ()
+ tests/examples/ghc8/pmc005.hs view
@@ -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 = ()
+ tests/examples/ghc8/pmc006.hs view
@@ -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
+ tests/examples/ghc8/pmc007.hs view
@@ -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" -> ()
tests/examples/ghc8/poly-export.hs view
@@ -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
tests/examples/ghc8/poly-export2.hs view
@@ -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
+ tests/examples/ghc8/records-check-sels.hs view
@@ -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)
+ tests/examples/ghc8/records-compile.hs view
@@ -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" }
+ tests/examples/ghc8/records-exquant.hs view
@@ -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 }
+ tests/examples/ghc8/records-mixing-fields.hs view
@@ -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 }
+ tests/examples/ghc8/records-no-uni-update.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+module RecordPats where++-- No updates+pattern Uni{a,b} <- (a, b)++foo = ("a","b") { a = "b" }
+ tests/examples/ghc8/records-no-uni-update2.hs view
@@ -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" }
+ tests/examples/ghc8/records-poly-update.hs view
@@ -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
+ tests/examples/ghc8/records-poly.hs view
@@ -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
+ tests/examples/ghc8/records-prov-req.hs view
@@ -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 }
+ tests/examples/ghc8/records-req-only.hs view
@@ -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
+ tests/examples/ghc8/records-req.hs view
@@ -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
+ tests/examples/ghc8/records-run.hs view
@@ -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"})
+ tests/examples/ghc8/spec-inline-determ.hs view
@@ -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 <L,U><L,U>]+--   $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 <L,U><L,U>]+--   $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)