ghc-exactprint 0.5.6.1 → 0.5.7.0

raw patch · 186 files changed

+10181/−1980 lines, 186 filesdep ~basedep ~ghc-exactprintPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, ghc-exactprint

API changes (from Hackage documentation)

Files

• ChangeLog +2/−0
• ghc-exactprint.cabal +28/−19
• src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs +1/−0
• src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs +2800/−0
• src/Language/Haskell/GHC/ExactPrint/Lookup.hs +5/−0
• src/Language/Haskell/GHC/ExactPrint/Pretty.hs +13/−0
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +215/−37
• src/Language/Haskell/GHC/ExactPrint/Types.hs +20/−1
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +2/−0
• tests/Test.hs +23/−36
• tests/Test/Transform.hs +76/−16
• tests/examples/ghc710/DiophantineVect.hs +0/−40
• tests/examples/ghc710/GADTContext.hs +0/−13
• tests/examples/ghc710/LiftedConstructors.hs +0/−25
• tests/examples/ghc710/OveridingPrimitives.hs +1/−0
• tests/examples/ghc710/SlidingTypeSyn.hs +0/−14
• tests/examples/ghc710/Vect.hs +0/−70
• tests/examples/ghc80/BadTelescope.hs +0/−9
• tests/examples/ghc80/BadTelescope2.hs +0/−14
• tests/examples/ghc80/BadTelescope3.hs +0/−9
• tests/examples/ghc80/BadTelescope4.hs +0/−13
• tests/examples/ghc80/Dep3.hs +0/−26
• tests/examples/ghc80/GADTContext.hs +37/−0
• tests/examples/ghc80/KindEqualities2.hs +0/−43
• tests/examples/ghc80/RAE_T32a.hs +0/−35
• tests/examples/ghc80/RAE_T32b.hs +0/−23
• tests/examples/ghc80/Rae31.hs +0/−24
• tests/examples/ghc80/RaeBlogPost.hs +0/−63
• tests/examples/ghc80/RenamingStar.hs +0/−5
• tests/examples/ghc80/T10134a.hs +0/−11
• tests/examples/ghc80/T10321.hs +0/−14
• tests/examples/ghc80/T10689a.hs +0/−114
• tests/examples/ghc80/T10934.hs +0/−38
• tests/examples/ghc80/T11142.hs +0/−10
• tests/examples/ghc80/T3927b.hs +0/−76
• tests/examples/ghc80/T9632.hs +0/−11
• tests/examples/ghc80/UnicodeSyntax.hs +0/−243
• tests/examples/ghc80/Webhook.hs +0/−176
• tests/examples/ghc80/determ004.hs +0/−311
• tests/examples/ghc80/dynamic-paper.hs +0/−341
• tests/examples/ghc80/mkGADTVars.hs +0/−9
• tests/examples/ghc80/overloadedrecflds_generics.hs +0/−50
• tests/examples/ghc82/TensorTests.hs +0/−41
• tests/examples/ghc86/Arith.hs +145/−0
• tests/examples/ghc86/BadTelescope.hs +9/−0
• tests/examples/ghc86/BadTelescope2.hs +14/−0
• tests/examples/ghc86/BadTelescope3.hs +9/−0
• tests/examples/ghc86/BadTelescope4.hs +13/−0
• tests/examples/ghc86/Boot1.hs +7/−0
• tests/examples/ghc86/Dep3.hs +26/−0
• tests/examples/ghc86/GADT.hs +22/−0
• tests/examples/ghc86/HashTab.hs +341/−0
• tests/examples/ghc86/KindEqualities2.hs +43/−0
• tests/examples/ghc86/LiftedConstructors.hs +25/−0
• tests/examples/ghc86/Parser.hs +166/−0
• tests/examples/ghc86/RAE_T32a.hs +35/−0
• tests/examples/ghc86/RAE_T32b.hs +23/−0
• tests/examples/ghc86/Rae31.hs +24/−0
• tests/examples/ghc86/RaeBlogPost.hs +63/−0
• tests/examples/ghc86/RenamingStar.hs +5/−0
• tests/examples/ghc86/ST.hs +62/−0
• tests/examples/ghc86/SlidingTypeSyn.hs +14/−0
• tests/examples/ghc86/T10134a.hs +11/−0
• tests/examples/ghc86/T10279.hs +12/−0
• tests/examples/ghc86/T10321.hs +14/−0
• tests/examples/ghc86/T10638.hs +33/−0
• tests/examples/ghc86/T10689a.hs +115/−0
• tests/examples/ghc86/T10819.hs +28/−0
• tests/examples/ghc86/T10891.hs +41/−0
• tests/examples/ghc86/T10934.hs +38/−0
• tests/examples/ghc86/T11142.hs +10/−0
• tests/examples/ghc86/T11484.hs +11/−0
• tests/examples/ghc86/T12478_5.hs +18/−0
• tests/examples/ghc86/T14164.hs +11/−0
• tests/examples/ghc86/T14650.hs +77/−0
• tests/examples/ghc86/T2632.hs +15/−0
• tests/examples/ghc86/T3263-2.hs +39/−0
• tests/examples/ghc86/T3391.hs +15/−0
• tests/examples/ghc86/T3572.hs +12/−0
• tests/examples/ghc86/T3927b.hs +76/−0
• tests/examples/ghc86/T4056.hs +17/−0
• tests/examples/ghc86/T4169.hs +15/−0
• tests/examples/ghc86/T4170.hs +14/−0
• tests/examples/ghc86/T5217.hs +11/−0
• tests/examples/ghc86/T6018th.hs +121/−0
• tests/examples/ghc86/T6062.hs +4/−0
• tests/examples/ghc86/T8455.hs +7/−0
• tests/examples/ghc86/T8759a.hs +7/−0
• tests/examples/ghc86/T8807.hs +11/−0
• tests/examples/ghc86/T9367.hs +5/−0
• tests/examples/ghc86/T9632.hs +11/−0
• tests/examples/ghc86/T9662.hs +54/−0
• tests/examples/ghc86/T9824.hs +7/−0
• tests/examples/ghc86/TH_abstractFamily.hs +13/−0
• tests/examples/ghc86/TH_bracket1.hs +9/−0
• tests/examples/ghc86/TH_bracket2.hs +10/−0
• tests/examples/ghc86/TH_bracket3.hs +12/−0
• tests/examples/ghc86/TH_class1.hs +9/−0
• tests/examples/ghc86/TH_dataD1.hs +12/−0
• tests/examples/ghc86/TH_localname.hs +5/−0
• tests/examples/ghc86/TH_lookupName.hs +37/−0
• tests/examples/ghc86/TH_ppr1.hs +38/−0
• tests/examples/ghc86/TH_raiseErr1.hs +6/−0
• tests/examples/ghc86/TH_recover.hs +13/−0
• tests/examples/ghc86/TH_reifyDecl1.hs +88/−0
• tests/examples/ghc86/TH_reifyDecl2.hs +12/−0
• tests/examples/ghc86/TH_reifyInstances.hs +51/−0
• tests/examples/ghc86/TH_reifyMkName.hs +16/−0
• tests/examples/ghc86/TH_repE1.hs +32/−0
• tests/examples/ghc86/TH_repE2.hs +37/−0
• tests/examples/ghc86/TH_repE3.hs +20/−0
• tests/examples/ghc86/TH_repGuard.hs +35/−0
• tests/examples/ghc86/TH_repGuardOutput.hs +30/−0
• tests/examples/ghc86/TH_repPatSig.hs +19/−0
• tests/examples/ghc86/TH_repPatSigTVar.hs +13/−0
• tests/examples/ghc86/TH_repPrim.hs +34/−0
• tests/examples/ghc86/TH_repPrim2.hs +34/−0
• tests/examples/ghc86/TH_repPrimOutput.hs +23/−0
• tests/examples/ghc86/TH_repPrimOutput2.hs +23/−0
• tests/examples/ghc86/TH_scope.hs +10/−0
• tests/examples/ghc86/TH_sections.hs +11/−0
• tests/examples/ghc86/TH_spliceD2.hs +7/−0
• tests/examples/ghc86/TH_spliceDecl1.hs +12/−0
• tests/examples/ghc86/TH_spliceDecl2.hs +13/−0
• tests/examples/ghc86/TH_spliceDecl3.hs +13/−0
• tests/examples/ghc86/TH_spliceE1.hs +8/−0
• tests/examples/ghc86/TH_spliceE3.hs +26/−0
• tests/examples/ghc86/TH_spliceE4.hs +13/−0
• tests/examples/ghc86/TH_spliceE5_Lib.hs +10/−0
• tests/examples/ghc86/TH_spliceE5_prof_Lib.hs +10/−0
• tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs +10/−0
• tests/examples/ghc86/TH_spliceExpr1.hs +11/−0
• tests/examples/ghc86/TH_tf1.hs +23/−0
• tests/examples/ghc86/TH_tf3.hs +13/−0
• tests/examples/ghc86/TH_unresolvedInfix.hs +142/−0
• tests/examples/ghc86/TH_unresolvedInfix2.hs +18/−0
• tests/examples/ghc86/TensorTests.hs +41/−0
• tests/examples/ghc86/Test.hs +410/−0
• tests/examples/ghc86/Test12417.hs +20/−0
• tests/examples/ghc86/TupleN.hs +11/−0
• tests/examples/ghc86/UnicodeSyntax.hs +243/−0
• tests/examples/ghc86/Webhook.hs +176/−0
• tests/examples/ghc86/deriving-via-compile.hs +460/−0
• tests/examples/ghc86/determ004.hs +311/−0
• tests/examples/ghc86/dynamic-paper.hs +341/−0
• tests/examples/ghc86/dynbrk005.hs +6/−0
• tests/examples/ghc86/ffi1.hs +12/−0
• tests/examples/ghc86/ghci006.hs +9/−0
• tests/examples/ghc86/haddockA026.hs +10/−0
• tests/examples/ghc86/haddockA027.hs +11/−0
• tests/examples/ghc86/haddockA031.hs +8/−0
• tests/examples/ghc86/haddockC026.hs +10/−0
• tests/examples/ghc86/haddockC027.hs +25/−0
• tests/examples/ghc86/haddockC031.hs +8/−0
• tests/examples/ghc86/mdo.hs +40/−0
• tests/examples/ghc86/mkGADTVars.hs +9/−0
• tests/examples/ghc86/overloadedrecflds_generics.hs +50/−0
• tests/examples/pre-ghc86/BadTelescope.hs +9/−0
• tests/examples/pre-ghc86/BadTelescope2.hs +14/−0
• tests/examples/pre-ghc86/BadTelescope3.hs +9/−0
• tests/examples/pre-ghc86/BadTelescope4.hs +13/−0
• tests/examples/pre-ghc86/Dep3.hs +26/−0
• tests/examples/pre-ghc86/KindEqualities2.hs +43/−0
• tests/examples/pre-ghc86/LiftedConstructors.hs +25/−0
• tests/examples/pre-ghc86/RAE_T32a.hs +35/−0
• tests/examples/pre-ghc86/RAE_T32b.hs +23/−0
• tests/examples/pre-ghc86/Rae31.hs +24/−0
• tests/examples/pre-ghc86/RaeBlogPost.hs +63/−0
• tests/examples/pre-ghc86/RenamingStar.hs +5/−0
• tests/examples/pre-ghc86/SlidingTypeSyn.hs +14/−0
• tests/examples/pre-ghc86/T10134a.hs +11/−0
• tests/examples/pre-ghc86/T10321.hs +14/−0
• tests/examples/pre-ghc86/T10689a.hs +114/−0
• tests/examples/pre-ghc86/T10934.hs +38/−0
• tests/examples/pre-ghc86/T11142.hs +10/−0
• tests/examples/pre-ghc86/T3927b.hs +76/−0
• tests/examples/pre-ghc86/T9632.hs +11/−0
• tests/examples/pre-ghc86/TensorTests.hs +43/−0
• tests/examples/pre-ghc86/UnicodeSyntax.hs +243/−0
• tests/examples/pre-ghc86/Vect.hs +70/−0
• tests/examples/pre-ghc86/Webhook.hs +176/−0
• tests/examples/pre-ghc86/determ004.hs +311/−0
• tests/examples/pre-ghc86/dynamic-paper.hs +341/−0
• tests/examples/pre-ghc86/mkGADTVars.hs +9/−0
• tests/examples/pre-ghc86/overloadedrecflds_generics.hs +50/−0
• tests/examples/vect/DiophantineVect.hs +40/−0

@@ -1,3 +1,5 @@+2018-07-11 v0.5.7.0+	* Include support for GHC 8.6.1 alpha 1 2018-03-11 v0.5.6.1 	* Relax base constraints so tests can configure with GHC 8.4.1 2018-01-27 v0.5.6.0

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             0.5.6.1+version:             0.5.7.0 synopsis:            ExactPrint for GHC description:         Using the API Annotations available from GHC 7.10.2, this                      library provides a means to round trip any code that can@@ -29,7 +29,7 @@ maintainer:          alan.zimm@gmail.com category:            Development build-type:          Simple-tested-with:    GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2+tested-with:    GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.4.3 extra-source-files:  ChangeLog                      src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs                      tests/examples/failing/*.hs@@ -38,6 +38,9 @@                      tests/examples/ghc80/*.hs                      tests/examples/ghc82/*.hs                      tests/examples/ghc84/*.hs+                     tests/examples/ghc86/*.hs+                     tests/examples/pre-ghc86/*.hs+                     tests/examples/vect/*.hs                      tests/examples/transform/*.hs                      tests/examples/failing/*.hs.bad                      tests/examples/transform/*.hs.expected@@ -80,7 +83,7 @@   -- other-modules:   -- other-extensions:   GHC-Options:         -Wall-  build-depends:       base >=4.7 && <4.12+  build-depends:       base >=4.7 && <4.13                      , bytestring >= 0.10.6                      , containers >= 0.5                      , directory >= 1.2@@ -94,16 +97,19 @@       build-depends: ghc-boot   hs-source-dirs:      src -  if impl (ghc > 8.2.2)-      hs-source-dirs: src-ghc84+  if impl (ghc > 8.4.3)+      hs-source-dirs: src-ghc86   else-    if impl (ghc > 8.0.3)-        hs-source-dirs: src-ghc82+    if impl (ghc > 8.2.2)+        hs-source-dirs: src-ghc84     else-      if impl (ghc > 7.10.3)-          hs-source-dirs: src-ghc80+      if impl (ghc > 8.0.3)+          hs-source-dirs: src-ghc82       else-          hs-source-dirs: src-ghc710+        if impl (ghc > 7.10.3)+            hs-source-dirs: src-ghc80+        else+            hs-source-dirs: src-ghc710    default-language:    Haskell2010   if impl (ghc < 7.10.2)@@ -117,16 +123,19 @@   else     hs-source-dirs:      tests -  if impl (ghc > 8.2.2)-      hs-source-dirs: src-ghc84+  if impl (ghc > 8.4.3)+      hs-source-dirs: src-ghc86   else-    if impl (ghc > 8.0.3)-        hs-source-dirs: src-ghc82+    if impl (ghc > 8.2.2)+        hs-source-dirs: src-ghc84     else-      if impl (ghc > 7.10.3)-          hs-source-dirs: src-ghc80+      if impl (ghc > 8.0.3)+          hs-source-dirs: src-ghc82       else-          hs-source-dirs: src-ghc710+        if impl (ghc > 7.10.3)+            hs-source-dirs: src-ghc80+        else+            hs-source-dirs: src-ghc710    main-is:             Test.hs   other-modules:       Test.Common@@ -138,7 +147,7 @@   if impl (ghc < 7.10.2)       buildable: False   Build-depends:       HUnit >= 1.2-                     , base < 4.12+                     , base < 4.13                      , bytestring                      , containers >= 0.5                      , Diff@@ -154,7 +163,7 @@   if flag (dev)       build-depends: free   else-      build-depends: ghc-exactprint >= 0.5.4+      build-depends: ghc-exactprint    if impl (ghc >= 7.11)       build-depends: ghc-boot

@@ -2503,6 +2503,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)   => Annotate (ResTyGADTHook name) where   markAST _ (ResTyGADTHook bndrs) = do+    markManyOptional GHC.AnnOpenP     unless (null bndrs) $ do       mark GHC.AnnForall       mapM_ markLocated bndrs

@@ -0,0 +1,2800 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | 'annotate' is a function which given a GHC AST fragment, constructs+-- a syntax tree which indicates which annotations belong to each specific+-- part of the fragment.+--+-- "Delta" and "Print" provide two interpreters for this structure. You+-- should probably use those unless you know what you're doing!+--+-- The functor 'AnnotationF' has a number of constructors which correspond+-- to different sitations which annotations can arise. It is hoped that in+-- future versions of GHC these can be simplified by making suitable+-- modifications to the AST.++module Language.Haskell.GHC.ExactPrint.Annotater+       (+         annotate+       , AnnotationF(..)+       , Annotated+       , Annotate(..)+       , withSortKeyContextsHelper+       ) where+++import Language.Haskell.GHC.ExactPrint.AnnotateTypes+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils++import qualified Bag            as GHC+import qualified BasicTypes     as GHC+import qualified BooleanFormula as GHC+import qualified Class          as GHC+import qualified CoAxiom        as GHC+import qualified FastString     as GHC+import qualified ForeignCall    as GHC+import qualified GHC            as GHC+--  import qualified HsDoc          as GHC+import qualified Name           as GHC+import qualified RdrName        as GHC+import qualified Outputable     as GHC++import Control.Monad.Identity+import Data.Data+import Data.Maybe++import qualified Data.Set as Set++import Debug.Trace+++{-# ANN module "HLint: ignore Eta reduce" #-}+{-# ANN module "HLint: ignore Redundant do" #-}+{-# ANN module "HLint: ignore Reduce duplication" #-}+-- ---------------------------------------------------------------------++class Data ast => Annotate ast where+  markAST :: GHC.SrcSpan -> ast -> Annotated ()++-- ---------------------------------------------------------------------++-- | Construct a syntax tree which represent which KeywordIds must appear+-- where.+annotate :: (Annotate ast) => GHC.Located ast -> Annotated ()+annotate = markLocated++-- ---------------------------------------------------------------------++-- | Constructs a syntax tree which contains information about which+-- annotations are required by each element.+markLocated :: (Annotate ast) => GHC.Located ast -> Annotated ()+markLocated ast =+  case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of+    Just d  -> markLHsDecl d+    Nothing -> withLocated ast markAST++-- ---------------------------------------------------------------------++-- |When adding missing annotations, do not put a preceding space in front of a list+markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated ()+markListNoPrecedingSpace intercal ls =+    case ls of+      [] -> return ()+      (l:ls') -> do+        if intercal+        then do+          if null ls'+            then setContext (Set.fromList [NoPrecedingSpace            ]) $ markLocated l+            else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l+          markListIntercalate ls'+        else do+          setContext (Set.singleton NoPrecedingSpace) $ markLocated l+          mapM_ markLocated ls'++-- ---------------------------------------------------------------------+++-- |Mark a list, with the given keyword as a list item separator+markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated ()+markListIntercalate ls = markListIntercalateWithFun markLocated ls++-- ---------------------------------------------------------------------++markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated ()+markListWithContexts ctxInitial ctxRest ls =+  case ls of+    [] -> return ()+    [x] -> setContextLevel ctxInitial 2 $ markLocated x+    (x:xs) -> do+      setContextLevel ctxInitial 2 $ markLocated x+      setContextLevel ctxRest    2 $ mapM_ markLocated xs++-- ---------------------------------------------------------------------++-- Context for only if just one, else first item, middle ones, and last one+markListWithContexts' :: Annotate ast+                      => ListContexts+                      -> [GHC.Located ast] -> Annotated ()+markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls =+  case ls of+    [] -> return ()+    [x] -> setContextLevel ctxOnly level $ markLocated x+    (x:xs) -> do+      setContextLevel ctxInitial level $ markLocated x+      go xs+  where+    level = 2+    go []  = return ()+    go [x] = setContextLevel ctxLast level $ markLocated x+    go (x:xs) = do+      setContextLevel ctxMiddle level $ markLocated x+      go xs+++-- ---------------------------------------------------------------------++markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated ()+markListWithLayout ls =+  setLayoutFlag $ markList ls++-- ---------------------------------------------------------------------++markList :: Annotate ast => [GHC.Located ast] -> Annotated ()+markList ls =+  setContext (Set.singleton NoPrecedingSpace)+   $ markListWithContexts' listContexts' ls++markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()+markLocalBindsWithLayout binds = markHsLocalBinds binds++-- ---------------------------------------------------------------------++-- |This function is used to get around shortcomings in the GHC AST for 7.10.1+markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated ()+markLocatedFromKw kw (GHC.L l a) = do+  -- Note: l is needed so that the pretty printer can make something up+  ss <- getSrcSpanForKw l kw+  AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a))+  markLocated (GHC.L ss' a)++-- ---------------------------------------------------------------------++markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()+markMaybe Nothing    = return ()+markMaybe (Just ast) = markLocated ast++-- ---------------------------------------------------------------------+-- Managing lists which have been separated, e.g. Sigs and Binds++prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())]+prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsModule GHC.GhcPs) where+  markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do++    case mmn of+      Nothing -> return ()+      Just (GHC.L ln mn) -> do+        mark GHC.AnnModule+        markExternal ln GHC.AnnVal (GHC.moduleNameString mn)++        forM_ mdepr markLocated+        forM_ mexp markLocated++        mark GHC.AnnWhere++    markOptional GHC.AnnOpenC -- Possible '{'+    markManyOptional GHC.AnnSemi -- possible leading semis+    setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps++    setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs++    markOptional GHC.AnnCloseC -- Possible '}'++    markEOF++-- ---------------------------------------------------------------------++instance Annotate GHC.WarningTxt where+  markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do+    markAnnOpen txt "{-# WARNING"+    mark GHC.AnnOpenS+    markListIntercalate lss+    mark GHC.AnnCloseS+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do+    markAnnOpen txt "{-# DEPRECATED"+    mark GHC.AnnOpenS+    markListIntercalate lss+    mark GHC.AnnCloseS+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance Annotate GHC.StringLiteral where+  markAST l (GHC.StringLiteral src fs) = do+    markExternalSourceText l src (show (GHC.unpackFS fs))+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate (GHC.SourceText,GHC.FastString) where+  markAST l (src,fs) = do+    markExternalSourceText l src (show (GHC.unpackFS fs))++-- ---------------------------------------------------------------------++instance Annotate [GHC.LIE GHC.GhcPs] where+   markAST _ ls = do+     inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl+     mark GHC.AnnOpenP -- '('+     -- Can't use markListIntercalate, there can be trailing commas, but only in imports.+     markListIntercalateWithFunLevel markLocated 2 ls++     mark GHC.AnnCloseP -- ')'++instance Annotate (GHC.IE GHC.GhcPs) where+  markAST _ ie = do++    case ie of+        GHC.IEVar _ ln -> markLocated ln++        GHC.IEThingAbs _ ln -> do+          setContext (Set.singleton PrefixOp) $ markLocated ln++        GHC.IEThingWith _ ln wc ns _lfs -> do+          setContext (Set.singleton PrefixOp) $ markLocated ln+          mark GHC.AnnOpenP+          case wc of+            GHC.NoIEWildcard ->+              unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])+                $ markListIntercalate ns+            GHC.IEWildcard n -> do+              setContext (Set.fromList [PrefixOp,Intercalate])+                $ mapM_ markLocated (take n ns)+              mark GHC.AnnDotdot+              case drop n ns of+                [] -> return ()+                ns' -> do+                  mark GHC.AnnComma+                  unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])+                    $ markListIntercalate ns'+          mark GHC.AnnCloseP++        (GHC.IEThingAll _ ln) -> do+          setContext (Set.fromList [PrefixOp]) $ markLocated ln+          mark GHC.AnnOpenP+          mark GHC.AnnDotdot+          mark GHC.AnnCloseP++        (GHC.IEModuleContents _ (GHC.L lm mn)) -> do+          mark GHC.AnnModule+          markExternal lm GHC.AnnVal (GHC.moduleNameString mn)++        -- Only used in Haddock mode so we can ignore them.+        (GHC.IEGroup {})    -> return ()++        (GHC.IEDoc {})      -> return ()++        (GHC.IEDocNamed {}) -> return ()+        GHC.XIE x -> error $ "got XIE for :" ++ showGhc x+    ifInContext (Set.fromList [Intercalate])+      (mark         GHC.AnnComma)+      (markOptional GHC.AnnComma)++-- ---------------------------------------------------------------------++instance Annotate (GHC.IEWrappedName GHC.RdrName) where+  markAST _ (GHC.IEName ln) = do+    unsetContext Intercalate $ setContext (Set.fromList [PrefixOp])+      $ markLocated ln+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+  markAST _ (GHC.IEPattern ln) = do+    mark GHC.AnnPattern+    setContext (Set.singleton PrefixOp) $ markLocated ln+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+  markAST _ (GHC.IEType ln) = do+    mark GHC.AnnType+    setContext (Set.singleton PrefixOp) $ markLocated ln+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++isSymRdr :: GHC.RdrName -> Bool+isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "."++instance Annotate GHC.RdrName where+  markAST l n = do+    let+      str = rdrName2String n+      isSym = isSymRdr n+      canParen = isSym+      doNormalRdrName = do+        let str' = case str of+              -- TODO: unicode support?+                        "forall" -> if spanLength l == 1 then "∀" else str+                        _ -> str++        let+          markParen :: GHC.AnnKeywordId -> Annotated ()+          markParen pa = do+            if canParen+              then ifInContext (Set.singleton PrefixOp)+                                       (mark         pa) -- '('+                                       (markOptional pa)+              else if isSym+                then ifInContext (Set.singleton PrefixOpDollar)+                       (mark pa)+                       (markOptional pa)+                else markOptional pa++        markOptional GHC.AnnSimpleQuote+        markParen GHC.AnnOpenP+        unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0+        cnt  <- countAnns GHC.AnnVal+        case cnt of+          0 -> markExternal l GHC.AnnVal str'+          1 -> markWithString GHC.AnnVal str'+          _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)+        unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1+        markParen GHC.AnnCloseP++    case n of+      GHC.Unqual _ -> doNormalRdrName+      GHC.Qual _ _ -> doNormalRdrName+      GHC.Orig _ _ -> if str == "~"+                        then doNormalRdrName+                        -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen)+                        else markExternal l GHC.AnnVal str+      -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str+      -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]"+      GHC.Exact n'  -> do+       case str of+         -- Special handling for Exact RdrNames, which are built-in Names+         "[]" -> do+           mark GHC.AnnOpenS  -- '['+           mark GHC.AnnCloseS -- ']'+         "()" -> do+           mark GHC.AnnOpenP  -- '('+           mark GHC.AnnCloseP -- ')'+         ('(':'#':_) -> do+           markWithString GHC.AnnOpen  "(#" -- '(#'+           let cnt = length $ filter (==',') str+           replicateM_ cnt (mark GHC.AnnCommaTuple)+           markWithString GHC.AnnClose  "#)"-- '#)'+         "[::]" -> do+           markWithString GHC.AnnOpen  "[:" -- '[:'+           markWithString GHC.AnnClose ":]" -- ':]'+         "->" -> do+           mark GHC.AnnOpenP -- '('+           mark GHC.AnnRarrow+           mark GHC.AnnCloseP -- ')'+         -- "~#"  -> do+         --   mark GHC.AnnOpenP -- '('+         --   mark GHC.AnnTildehsh+         --   mark GHC.AnnCloseP+         "*"  -> do+           markExternal l GHC.AnnVal str+         "★"  -> do -- Note: unicode star+           markExternal l GHC.AnnVal str+         ":"  -> do+           -- Note: The OccName for ":" has the following attributes (via occAttributes)+           -- (d, Data DataSym Sym Val )+           -- consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon+           doNormalRdrName+           -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName+         ('(':',':_) -> do+           mark GHC.AnnOpenP+           let cnt = length $ filter (==',') str+           replicateM_ cnt (mark GHC.AnnCommaTuple)+           mark GHC.AnnCloseP -- ')'+         _ -> do+            let isSym' = isSymRdr  (GHC.nameRdrName n')+            when isSym' $ mark GHC.AnnOpenP -- '('+            markWithString GHC.AnnVal str+            when isSym $ mark GHC.AnnCloseP -- ')'+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")++-- ---------------------------------------------------------------------++instance Annotate (GHC.ImportDecl GHC.GhcPs) where+ markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do++   -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec+   mark GHC.AnnImport++   -- "{-# SOURCE" and "#-}"+   case msrc of+     GHC.SourceText _txt -> do+       markAnnOpen msrc "{-# SOURCE"+       markWithString GHC.AnnClose "#-}"+     GHC.NoSourceText -> return ()+   when safeflag (mark GHC.AnnSafe)+   when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)+   case mpkg of+    Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) ->+      markWithString GHC.AnnPackageName srcPkg+    _ -> return ()++   markLocated modname++   case GHC.ideclAs imp of+      Nothing -> return ()+      Just mn -> do+          mark GHC.AnnAs+          markLocated mn++   case hiding of+     Nothing -> return ()+     Just (isHiding,lie) -> do+       if isHiding+         then setContext (Set.singleton HasHiding) $+                markLocated lie+         else markLocated lie+   markTrailingSemi++ markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate GHC.ModuleName where+   markAST l mname =+    markExternal l GHC.AnnVal (GHC.moduleNameString mname)++-- ---------------------------------------------------------------------++markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated ()+markLHsDecl (GHC.L l decl) =+    case decl of+      GHC.TyClD _ d       -> markLocated (GHC.L l d)+      GHC.InstD _ d       -> markLocated (GHC.L l d)+      GHC.DerivD _ d      -> markLocated (GHC.L l d)+      GHC.ValD _ d        -> markLocated (GHC.L l d)+      GHC.SigD _ d        -> markLocated (GHC.L l d)+      GHC.DefD _ d        -> markLocated (GHC.L l d)+      GHC.ForD _ d        -> markLocated (GHC.L l d)+      GHC.WarningD _ d    -> markLocated (GHC.L l d)+      GHC.AnnD _ d        -> markLocated (GHC.L l d)+      GHC.RuleD _ d       -> markLocated (GHC.L l d)+      GHC.SpliceD _ d     -> markLocated (GHC.L l d)+      GHC.DocD _ d        -> markLocated (GHC.L l d)+      GHC.RoleAnnotD _ d  -> markLocated (GHC.L l d)+      GHC.XHsDecl x  -> error $ "got XHsDecl for:" ++ showGhc x++instance Annotate (GHC.HsDecl GHC.GhcPs) where+  markAST l d = markLHsDecl (GHC.L l d)++-- ---------------------------------------------------------------------++instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where+  markAST _ (GHC.RoleAnnotDecl _ ln mr) = do+    mark GHC.AnnType+    mark GHC.AnnRole+    markLocated ln+    mapM_ markLocated mr+  markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x++instance Annotate (Maybe GHC.Role) where+  markAST l Nothing  = markExternal l GHC.AnnVal "_"+  markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r)++-- ---------------------------------------------------------------------++instance Annotate (GHC.SpliceDecl GHC.GhcPs) where+  markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do+    markLocated e+    markTrailingSemi+  markAST _ (GHC.SpliceDecl _ e _flag) = do+    markLocated e+    markTrailingSemi++  markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.RuleDecls GHC.GhcPs) where+  markAST _ (GHC.HsRules _ src rules) = do+    markAnnOpen src "{-# RULES"+    setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules+    markWithString GHC.AnnClose "#-}"+    markTrailingSemi+  markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.RuleDecl GHC.GhcPs) where+  markAST l (GHC.HsRule _ ln act bndrs lhs rhs) = do+    markLocated ln+    setContext (Set.singleton ExplicitNeverActive) $ markActivation l act++    unless (null bndrs) $ do+      mark GHC.AnnForall+      mapM_ markLocated bndrs+      mark GHC.AnnDot++    markLocated lhs+    mark GHC.AnnEqual+    markLocated rhs+    inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi+    markTrailingSemi++  markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x++-- ---------------------------------------------------------------------++markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated ()+markActivation _ act = do+  case act of+    GHC.ActiveBefore src phase -> do+      mark GHC.AnnOpenS --  '['+      mark GHC.AnnTilde -- ~+      markSourceText src (show phase)+      mark GHC.AnnCloseS -- ']'+    GHC.ActiveAfter src phase -> do+      mark GHC.AnnOpenS --  '['+      markSourceText src (show phase)+      mark GHC.AnnCloseS -- ']'+    GHC.NeverActive -> do+      inContext (Set.singleton ExplicitNeverActive) $ do+        mark GHC.AnnOpenS --  '['+        mark GHC.AnnTilde -- ~+        mark GHC.AnnCloseS -- ']'+    _ -> return ()++-- ---------------------------------------------------------------------++instance Annotate (GHC.RuleBndr GHC.GhcPs) where+  markAST _ (GHC.RuleBndr _ ln) = markLocated ln+  markAST _ (GHC.RuleBndrSig _ ln st) = do+    mark GHC.AnnOpenP -- "("+    markLocated ln+    mark GHC.AnnDcolon+    markLHsSigWcType st+    mark GHC.AnnCloseP -- ")"+  markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x++-- ---------------------------------------------------------------------++markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated ()+markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do+  markLocated ty+markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit"+markLHsSigWcType (GHC.XHsWildCardBndrs _)              = error "markLHsSigWcType extension hit"++-- ---------------------------------------------------------------------++instance Annotate (GHC.AnnDecl GHC.GhcPs) where+   markAST _ (GHC.HsAnnotation _ src prov e) = do+     markAnnOpen src "{-# ANN"+     case prov of+       (GHC.ValueAnnProvenance n) -> markLocated n+       (GHC.TypeAnnProvenance n) -> do+         mark GHC.AnnType+         markLocated n+       GHC.ModuleAnnProvenance -> mark GHC.AnnModule++     markLocated e+     markWithString GHC.AnnClose "#-}"+     markTrailingSemi++   markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.WarnDecls GHC.GhcPs) where+   markAST _ (GHC.Warnings _ src warns) = do+     markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED+     mapM_ markLocated warns+     markWithString GHC.AnnClose "#-}"++   markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.WarnDecl GHC.GhcPs) where+   markAST _ (GHC.Warning _ lns txt) = do+     markListIntercalate lns+     mark GHC.AnnOpenS -- "["+     case txt of+       GHC.WarningTxt    _src ls -> markListIntercalate ls+       GHC.DeprecatedTxt _src ls -> markListIntercalate ls+     mark GHC.AnnCloseS -- "]"++   markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x++instance Annotate GHC.FastString where+  -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.+  markAST l fs = do+    markExternal l GHC.AnnVal (show (GHC.unpackFS fs))+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate (GHC.ForeignDecl GHC.GhcPs) where+  markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ)+               (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do+    mark GHC.AnnForeign+    mark GHC.AnnImport+    markLocated cconv+    unless (ll == GHC.noSrcSpan) $ markLocated safety+    markExternalSourceText ls src ""+    markLocated ln+    mark GHC.AnnDcolon+    markLocated typ+    markTrailingSemi++  markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do+    mark GHC.AnnForeign+    mark GHC.AnnExport+    markLocated spec+    markExternal ls GHC.AnnVal (sourceTextToString src "")+    setContext (Set.singleton PrefixOp) $ markLocated ln+    mark GHC.AnnDcolon+    markLocated typ+++  markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion"+  markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion"+  markAST _ (GHC.XForeignDecl _)                               = error "markAST ForeignDecl hit extenstion"++-- ---------------------------------------------------------------------++instance (Annotate GHC.CExportSpec) where+  markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv++-- ---------------------------------------------------------------------++instance (Annotate GHC.CCallConv) where+  markAST l GHC.StdCallConv        =  markExternal l GHC.AnnVal "stdcall"+  markAST l GHC.CCallConv          =  markExternal l GHC.AnnVal "ccall"+  markAST l GHC.CApiConv           =  markExternal l GHC.AnnVal "capi"+  markAST l GHC.PrimCallConv       =  markExternal l GHC.AnnVal "prim"+  markAST l GHC.JavaScriptCallConv =  markExternal l GHC.AnnVal "javascript"++-- ---------------------------------------------------------------------++instance (Annotate GHC.Safety) where+  markAST l GHC.PlayRisky         = markExternal l GHC.AnnVal "unsafe"+  markAST l GHC.PlaySafe          = markExternal l GHC.AnnVal "safe"+  markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible"++-- ---------------------------------------------------------------------++instance Annotate (GHC.DerivDecl GHC.GhcPs) where++  markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do+    mark GHC.AnnDeriving+    markMaybe ms+    mark GHC.AnnInstance+    markMaybe mov+    markLocated typ+    markTrailingSemi++{-+data DerivDecl pass = DerivDecl+        { deriv_ext          :: XCDerivDecl pass+        , deriv_type         :: LHsSigWcType pass+          -- ^ The instance type to derive.+          --+          -- It uses an 'LHsSigWcType' because the context is allowed to be a+          -- single wildcard:+          --+          -- > deriving instance _ => Eq (Foo a)+          --+          -- Which signifies that the context should be inferred.++          -- See Note [Inferring the instance context] in TcDerivInfer.++        , deriv_strategy     :: Maybe (LDerivStrategy pass)+        , deriv_overlap_mode :: Maybe (Located OverlapMode)++type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both++data HsWildCardBndrs pass thing+    -- See Note [HsType binders]+    -- See Note [The wildcard story for types]+  = HsWC { hswc_ext :: XHsWC pass thing+                -- after the renamer+                -- Wild cards, both named and anonymous++         , hswc_body :: thing+                -- Main payload (type or list of types)+                -- If there is an extra-constraints wildcard,+                -- it's still there in the hsc_body.+    }+++-}+++  markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension"+  markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _)              = error "markAST DerivDecl hit extension"+  markAST _ (GHC.XDerivDecl _)                                          = error "markAST DerivDecl hit extension"++-- ---------------------------------------------------------------------++instance Annotate (GHC.DerivStrategy GHC.GhcPs) where++  markAST _ GHC.StockStrategy    = mark GHC.AnnStock+  markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass+  markAST _ GHC.NewtypeStrategy  = mark GHC.AnnNewtype+  markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do+    mark GHC.AnnVia+    markLocated ty+  markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _))+    = error $ "got XHsImplicitBndrs in AnnDerivStrategy"++-- ---------------------------------------------------------------------++instance Annotate (GHC.DefaultDecl GHC.GhcPs) where++  markAST _ (GHC.DefaultDecl _ typs) = do+    mark GHC.AnnDefault+    mark GHC.AnnOpenP -- '('+    markListIntercalate typs+    mark GHC.AnnCloseP -- ')'+    markTrailingSemi++  markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.InstDecl GHC.GhcPs) where++  markAST l (GHC.ClsInstD     _  cid) = markAST l  cid+  markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid+  markAST l (GHC.TyFamInstD   _ tfid) = markAST l tfid+  markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate GHC.OverlapMode where++  -- NOTE: NoOverlap is only used in the typechecker+  markAST _ (GHC.NoOverlap src) = do+    markAnnOpen src "{-# NO_OVERLAP"+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Overlappable src) = do+    markAnnOpen src "{-# OVERLAPPABLE"+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Overlapping src) = do+    markAnnOpen src "{-# OVERLAPPING"+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Overlaps src) = do+    markAnnOpen src "{-# OVERLAPS"+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Incoherent src) = do+    markAnnOpen src "{-# INCOHERENT"+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where++  markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do+    mark GHC.AnnInstance+    markMaybe mov+    markLocated poly+    mark GHC.AnnWhere+    markOptional GHC.AnnOpenC -- '{'+    markInside GHC.AnnSemi++    applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds)+                             ++ prepareListAnnotation sigs+                             ++ prepareListAnnotation tyfams+                             ++ prepareListAnnotation datafams+                               )++    markOptional GHC.AnnCloseC -- '}'+    markTrailingSemi++  markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl"+  markAST _ (GHC.XClsInstDecl _)                                   = error "extension hit for ClsInstDecl"++-- ---------------------------------------------------------------------++instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where++  markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do+    mark GHC.AnnType+    mark GHC.AnnInstance -- Note: this keyword is optional+    markFamEqn eqn+    markTrailingSemi++  markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl"++-- ---------------------------------------------------------------------++markFamEqn :: (GHC.HasOccName (GHC.IdP pass),+               Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2)+           => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2)+                    -> Annotated ()+markFamEqn (GHC.FamEqn _ ln pats fixity rhs) = do+  markTyClass fixity ln pats+  mark GHC.AnnEqual+  markLocated rhs+markFamEqn (GHC.XFamEqn _) = error "got XFamEqn"++-- ---------------------------------------------------------------------++instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where++  markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln pats fixity+             defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do+    case GHC.dd_ND defn of+      GHC.NewType  -> mark GHC.AnnNewtype+      GHC.DataType -> mark GHC.AnnData+    mark GHC.AnnInstance++    markLocated ctx++    markTyClass fixity ln pats++    case (GHC.dd_kindSig defn) of+      Just s -> do+        mark GHC.AnnDcolon+        markLocated s+      Nothing -> return ()+    if isGadt $ GHC.dd_cons defn+      then mark GHC.AnnWhere+      else mark GHC.AnnEqual+    markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs)+    markTrailingSemi++{-+newtype DataFamInstDecl pass+  = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }++type FamInstEqn pass rhs+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)++data FamEqn pass pats rhs+  = FamEqn+       { feqn_ext    :: XCFamEqn pass pats rhs+       , feqn_tycon  :: Located (IdP pass)+       , feqn_pats   :: pats+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration+       , feqn_rhs    :: rhs+       }+-}++  markAST _+            (GHC.DataFamInstDecl+             (GHC.HsIB _ (GHC.FamEqn _ _ _ _ (GHC.XHsDataDefn _))))+    = error "extension hit for DataFamInstDecl"+  markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _)))+    = error "extension hit for DataFamInstDecl"+  markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _))+    = error "extension hit for DataFamInstDecl"++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsBind GHC.GhcPs) where+  markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do+    -- Note: from a layout perspective a FunBind should not exist, so the+    -- current context is passed through unchanged to the matches.+    -- TODO: perhaps bring the edp from the first match up to the annotation for+    -- the FunBind.+    let+      tlFun =+        ifInContext (Set.fromList [CtxOnly,CtxFirst])+          (markListWithContexts' listContexts matches)+          (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches)+    ifInContext (Set.singleton TopLevel)+      (setContextLevel (Set.singleton TopLevel) 2 tlFun)+      tlFun++  -- -----------------------------------++  markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do+    markLocated lhs+    case grhs of+      (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards+      _ -> return ()+    markListIntercalateWithFunLevel markLocated 2 grhs++    -- TODO: extract this common code+    case lb of+      GHC.EmptyLocalBinds{} -> return ()+      _ -> do+        mark GHC.AnnWhere+        markOptional GHC.AnnOpenC -- '{'+        markInside GHC.AnnSemi+        markLocalBindsWithLayout lb+        markOptional GHC.AnnCloseC -- '}'+    markTrailingSemi++  -- -----------------------------------++  markAST _ (GHC.VarBind _ _n rhse _) =+    -- Note: this bind is introduced by the typechecker+    markLocated rhse++  -- -----------------------------------++  -- Introduced after renaming.+  markAST _ (GHC.AbsBinds {}) =+    traceM "warning: AbsBinds introduced after renaming"++  -- -----------------------------------++  markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do+    mark GHC.AnnPattern+    case args of+      GHC.InfixCon la lb -> do+        markLocated la+        setContext (Set.singleton InfixOp) $ markLocated ln+        markLocated lb+      GHC.PrefixCon ns -> do+        markLocated ln+        mapM_ markLocated ns+      GHC.RecCon fs -> do+        markLocated ln+        mark GHC.AnnOpenC  -- '{'+        markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs+        mark GHC.AnnCloseC -- '}'+    case dir of+      GHC.ImplicitBidirectional -> mark GHC.AnnEqual+      _                         -> mark GHC.AnnLarrow++    markLocated def+    case dir of+      GHC.Unidirectional           -> return ()+      GHC.ImplicitBidirectional    -> return ()+      GHC.ExplicitBidirectional mg -> do+        mark GHC.AnnWhere+        mark GHC.AnnOpenC  -- '{'+        markMatchGroup l mg+        mark GHC.AnnCloseC -- '}'++    markTrailingSemi++  -- -----------------------------------++  markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _)+    = error "extension hit for HsBind"+  markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _)+    = error "extension hit for HsBind"+  markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _))+    = error "extension hit for HsBind"+  markAST _ (GHC.XHsBindsLR _)+    = error "extension hit for HsBind"++-- ---------------------------------------------------------------------++instance Annotate (GHC.IPBind GHC.GhcPs) where+  markAST _ (GHC.IPBind _ en e) = do+    case en of+      Left n   -> markLocated n+      Right _i -> return ()+    mark GHC.AnnEqual+    markLocated e+    markTrailingSemi++  -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x+  markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate GHC.HsIPName where+  markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)++-- ---------------------------------------------------------------------++instance (Annotate body)+  => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where++  markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do+    let+      get_infix (GHC.FunRhs _ f _) = f+      get_infix _                  = GHC.Prefix++      isFunBind GHC.FunRhs{} = True+      isFunBind _            = False+    case (get_infix mln,pats) of+      (GHC.Infix, a:b:xs) -> do+        if null xs+          then markOptional GHC.AnnOpenP+          else mark         GHC.AnnOpenP+        markLocated a+        case mln of+          GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n+          _              -> return ()+        markLocated b+        if null xs+         then markOptional GHC.AnnCloseP+         else mark         GHC.AnnCloseP+        mapM_ markLocated xs+      _ -> do+        annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]+        inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam+        case mln of+          GHC.FunRhs n _ s -> do+            setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do+              when (s == GHC.SrcStrict) $ mark GHC.AnnBang+              markLocated n+            mapM_ markLocated pats+          _  -> markListNoPrecedingSpace False pats++    -- TODO: The AnnEqual annotation actually belongs in the first GRHS value+    case grhs of+      (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards+      _ -> return ()+    inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam+    mapM_ markLocated grhs++    case lb of+      GHC.EmptyLocalBinds{} -> return ()+      _ -> do+        mark GHC.AnnWhere+        markOptional GHC.AnnOpenC -- '{'+        markInside GHC.AnnSemi+        markLocalBindsWithLayout lb+        markOptional GHC.AnnCloseC -- '}'+    markTrailingSemi++  -- -----------------------------------++  markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _))+    = error "hit extension for Match"+  markAST _ (GHC.XMatch _)+    = error "hit extension for Match"++-- ---------------------------------------------------------------------++instance (Annotate body)+  => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where+  markAST _ (GHC.GRHS _ guards expr) = do+    case guards of+      [] -> return ()+      (_:_) -> do+        mark GHC.AnnVbar+        unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp])+          $ markListIntercalate guards+        ifInContext (Set.fromList [CaseAlt])+          (return ())+          (mark GHC.AnnEqual)++    markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test++    inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam+    setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr++  markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.Sig GHC.GhcPs) where++  markAST _ (GHC.TypeSig _ lns st)  = do+    setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns+    mark GHC.AnnDcolon+    markLHsSigWcType st+    markTrailingSemi+    tellContext (Set.singleton FollowingLine)++  markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do+    mark GHC.AnnPattern+    markListIntercalate lns+    mark GHC.AnnDcolon+    markLocated typ+    markTrailingSemi++  markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do+    when isDefault $ mark GHC.AnnDefault+    setContext (Set.singleton PrefixOp) $ markListIntercalate ns+    mark GHC.AnnDcolon+    markLocated typ+    markTrailingSemi++  markAST _ (GHC.IdSig {}) =+    traceM "warning: Introduced after renaming"++  markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do+    let fixstr = case fdir of+         GHC.InfixL -> "infixl"+         GHC.InfixR -> "infixr"+         GHC.InfixN -> "infix"+    markWithString GHC.AnnInfix fixstr+    markSourceText src (show v)+    setContext (Set.singleton InfixOp) $ markListIntercalate lns+    markTrailingSemi++  markAST l (GHC.InlineSig _ ln inl) = do+    markAnnOpen (GHC.inl_src inl) "{-# INLINE"+    markActivation l (GHC.inl_act inl)+    setContext (Set.singleton PrefixOp) $ markLocated ln+    markWithString GHC.AnnClose "#-}" -- '#-}'+    markTrailingSemi++  markAST l (GHC.SpecSig _ ln typs inl) = do+    markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE+    markActivation l (GHC.inl_act inl)+    markLocated ln+    mark GHC.AnnDcolon -- '::'+    markListIntercalateWithFunLevel markLHsSigType 2 typs+    markWithString GHC.AnnClose "#-}" -- '#-}'+    markTrailingSemi+++  markAST _ (GHC.SpecInstSig _ src typ) = do+    markAnnOpen src "{-# SPECIALISE"+    mark GHC.AnnInstance+    markLHsSigType typ+    markWithString GHC.AnnClose "#-}" -- '#-}'+    markTrailingSemi+++  markAST _ (GHC.MinimalSig _ src formula) = do+    markAnnOpen src "{-# MINIMAL"+    markLocated formula+    markWithString GHC.AnnClose "#-}"+    markTrailingSemi++  markAST _ (GHC.SCCFunSig _ src ln ml) = do+    markAnnOpen src "{-# SCC"+    markLocated ln+    markMaybe ml+    markWithString GHC.AnnClose "#-}"+    markTrailingSemi++  markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do+    markAnnOpen src "{-# COMPLETE"+    markListIntercalate ns+    case mlns of+      Nothing -> return ()+      Just _ -> do+        mark GHC.AnnDcolon+        markMaybe mlns+    markWithString GHC.AnnClose "#-}" -- '#-}'+    markTrailingSemi++  -- -----------------------------------+  markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _))+    = error "hit extension for Sig"+  markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _))+    = error "hit extension for Sig"+  markAST _ (GHC.FixSig _ (GHC.XFixitySig _))+    = error "hit extension for Sig"+  markAST _ (GHC.XSig _)+    = error "hit extension for Sig"++-- --------------------------------------------------------------------++markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated ()+markLHsSigType (GHC.HsIB _ typ) = markLocated typ+markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x++instance Annotate [GHC.LHsSigType GHC.GhcPs] where+  markAST _ ls = do+    -- mark GHC.AnnDeriving+    -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it+    -- is a HsTyVar. So for round trip pretty printing we need to take this into+    -- account.+    let marker = case ls of+          []  -> markManyOptional+          [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t)+                           then markMany+                           else markManyOptional+          _   -> markMany -- Need parens if more than one entry+    marker GHC.AnnOpenP+    markListIntercalateWithFun markLHsSigType ls+    marker GHC.AnnCloseP++-- --------------------------------------------------------------------++instance  (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where+  markAST _ (GHC.Var x)  = do+    setContext (Set.singleton PrefixOp) $ markLocated x+    inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+  markAST _ (GHC.Or ls)  = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls+  markAST _ (GHC.And ls) = do+    markListIntercalateWithFunLevel markLocated 2 ls+    inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+  markAST _ (GHC.Parens x)  = do+    mark GHC.AnnOpenP -- '('+    markLocated x+    mark GHC.AnnCloseP -- ')'+    inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where+  markAST _l (GHC.UserTyVar _ n) = do+    markLocated n++  markAST _ (GHC.KindedTyVar _ n ty) = do+    mark GHC.AnnOpenP  -- '('+    markLocated n+    mark GHC.AnnDcolon -- '::'+    markLocated ty+    mark GHC.AnnCloseP -- '('++  markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsType GHC.GhcPs) where+  markAST loc ty = do+    markType loc ty+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+    (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)+   where++    -- markType :: GHC.SrcSpan -> ast -> Annotated ()+    markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated ()+    markType _ (GHC.HsForAllTy _ tvs typ) = do+      mark GHC.AnnForall+      mapM_ markLocated tvs+      mark GHC.AnnDot+      markLocated typ++    markType _ (GHC.HsQualTy _ cxt typ) = do+      markLocated cxt+      markLocated typ++    markType _ (GHC.HsTyVar _ promoted name) = do+      when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote+      unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name++    markType _ (GHC.HsAppTy _ t1 t2) = do+      setContext (Set.singleton PrefixOp) $ markLocated t1+      markLocated t2++    markType _ (GHC.HsFunTy _ t1 t2) = do+      markLocated t1+      mark GHC.AnnRarrow+      markLocated t2+      -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT++    markType _ (GHC.HsListTy _ t) = do+      mark GHC.AnnOpenS -- '['+      markLocated t+      mark GHC.AnnCloseS -- ']'++    markType _ (GHC.HsTupleTy _ tt ts) = do+      case tt  of+        GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP  -- '('+        _                            -> markWithString GHC.AnnOpen "(#" -- '(#'+      markListIntercalateWithFunLevel markLocated 2 ts+      case tt  of+        GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP  -- ')'+        _                            -> markWithString GHC.AnnClose "#)" -- '#)'++    markType _ (GHC.HsSumTy _ tys) = do+      markWithString GHC.AnnOpen "(#"+      markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys+      markWithString GHC.AnnClose "#)"++    markType _ (GHC.HsOpTy _ t1 lo t2) = do+      markLocated t1+      if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo)+        then do+          markOptional GHC.AnnSimpleQuote+        else do+          mark GHC.AnnSimpleQuote+      unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo+      markLocated t2++    markType _ (GHC.HsParTy _ t) = do+      mark GHC.AnnOpenP  -- '('+      markLocated t+      mark GHC.AnnCloseP -- ')'++    markType _ (GHC.HsIParamTy _ n t) = do+      markLocated n+      mark GHC.AnnDcolon+      markLocated t++    markType l (GHC.HsStarTy _ isUnicode) = do+      if isUnicode+        then markExternal l GHC.AnnVal "\x2605" -- Unicode star+        else markExternal l GHC.AnnVal "*"++    markType _ (GHC.HsKindSig _ t k) = do+      mark GHC.AnnOpenP  -- '('+      markLocated t+      mark GHC.AnnDcolon -- '::'+      markLocated k+      mark GHC.AnnCloseP -- ')'++    markType l (GHC.HsSpliceTy _ s) = do+      markAST l s++    markType _ (GHC.HsDocTy _ t ds) = do+      markLocated t+      markLocated ds++    markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do+      case mt of+        GHC.NoSourceText -> return ()+        GHC.SourceText src -> do+          markWithString GHC.AnnOpen src+          markWithString GHC.AnnClose "#-}"+      case str of+        GHC.SrcLazy     -> mark GHC.AnnTilde+        GHC.SrcStrict   -> mark GHC.AnnBang+        GHC.NoSrcStrict -> return ()++      markLocated t++    markType _ (GHC.HsRecTy _ cons) = do+      mark GHC.AnnOpenC  -- '{'+      markListIntercalate cons+      mark GHC.AnnCloseC -- '}'++    markType _ (GHC.HsExplicitListTy _ promoted ts) = do+      when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote+      mark GHC.AnnOpenS  -- "["+      markListIntercalate ts+      mark GHC.AnnCloseS -- ']'++    markType _ (GHC.HsExplicitTupleTy _ ts) = do+      mark GHC.AnnSimpleQuote+      mark GHC.AnnOpenP+      markListIntercalate ts+      mark GHC.AnnCloseP++    markType l (GHC.HsTyLit _ lit) = do+      case lit of+        (GHC.HsNumTy s v) ->+          markExternalSourceText l s (show v)+        (GHC.HsStrTy s v) ->+          markExternalSourceText l s (show v)++    markType l (GHC.HsWildCardTy _) = do+      markExternal l GHC.AnnVal "_"++    markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x+++-- ---------------------------------------------------------------------++-- instance Annotate (GHC.HsAppType GHC.GhcPs) where+--   markAST _ (GHC.HsAppInfix _ n)  = do+--     when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote+--     setContext (Set.singleton InfixOp) $ markLocated n+--   markAST _ (GHC.HsAppPrefix _ t) = do+--     markOptional GHC.AnnTilde+--     setContext (Set.singleton PrefixOp) $ markLocated t++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsSplice GHC.GhcPs) where+  markAST l c =+    case c of+      GHC.HsQuasiQuote _ _ n _pos fs -> do+        markExternal l GHC.AnnVal+              -- Note: Lexer.x does not provide unicode alternative. 2017-02-26+              ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")++      GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n)))  -> do+        when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE+        if (hasParens == GHC.HasDollar)+          then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))+          else markLocated b+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP++      GHC.HsTypedSplice _ hasParens _n b -> do+        when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE+        markLocated b+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP++      -- -------------------------------++      GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n)))  -> do+        when (hasParens == GHC.HasParens) $  mark GHC.AnnOpenPE+        if (hasParens == GHC.HasDollar)+          then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))+          else markLocated b+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP++      GHC.HsUntypedSplice _ hasParens _n b  -> do+        case hasParens of+          GHC.HasParens -> mark GHC.AnnOpenPE+          GHC.HasDollar -> mark GHC.AnnThIdSplice+          GHC.NoParens  -> return ()+        markLocated b+        when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP++      GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC"++      -- -------------------------------++      (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.ConDeclField GHC.GhcPs) where+  markAST _ (GHC.ConDeclField _ ns ty mdoc) = do+    unsetContext Intercalate $ do+      markListIntercalate ns+      mark GHC.AnnDcolon+      markLocated ty+      markMaybe mdoc+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++  markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.FieldOcc GHC.GhcPs) where+  markAST _ (GHC.FieldOcc _ rn) = do+    markLocated rn+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++  markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate GHC.HsDocString where+  markAST l s = do+    markExternal l GHC.AnnVal (GHC.unpackHDS s)++-- ---------------------------------------------------------------------++instance Annotate (GHC.Pat GHC.GhcPs) where+  markAST loc typ = do+    markPat loc typ+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat")+    where+      markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"+      markPat l (GHC.VarPat _ n) = do+        -- The parser inserts a placeholder value for a record pun rhs. This must be+        -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is+        -- resolved, particularly for pretty printing where annotations are added.+        let pun_RDR = "pun-right-hand-side"+        when (showGhc n /= pun_RDR) $+          unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n)+      markPat _ (GHC.LazyPat _ p) = do+        mark GHC.AnnTilde+        markLocated p++      markPat _ (GHC.AsPat _ ln p) = do+        markLocated ln+        mark GHC.AnnAt+        markLocated p++      markPat _ (GHC.ParPat _ p) = do+        mark GHC.AnnOpenP+        markLocated p+        mark GHC.AnnCloseP++      markPat _ (GHC.BangPat _ p) = do+        mark GHC.AnnBang+        markLocated p++      markPat _ (GHC.ListPat _ ps) = do+        mark GHC.AnnOpenS+        markListIntercalateWithFunLevel markLocated 2 ps+        mark GHC.AnnCloseS++      markPat _ (GHC.TuplePat _ pats b) = do+        if b == GHC.Boxed then mark GHC.AnnOpenP+                          else markWithString GHC.AnnOpen "(#"+        markListIntercalateWithFunLevel markLocated 2 pats+        if b == GHC.Boxed then mark GHC.AnnCloseP+                          else markWithString GHC.AnnClose "#)"++      markPat _ (GHC.SumPat _ pat alt arity) = do+        markWithString GHC.AnnOpen "(#"+        replicateM_ (alt - 1) $ mark GHC.AnnVbar+        markLocated pat+        replicateM_ (arity - alt) $ mark GHC.AnnVbar+        markWithString GHC.AnnClose "#)"++      markPat _ (GHC.ConPatIn n dets) = do+        markHsConPatDetails n dets++      markPat _ GHC.ConPatOut {} =+        traceM "warning: ConPatOut Introduced after renaming"++      markPat _ (GHC.ViewPat _ e pat) = do+        markLocated e+        mark GHC.AnnRarrow+        markLocated pat++      markPat l (GHC.SplicePat _ s) = do+        markAST l s++      markPat l (GHC.LitPat _ lp) = markAST l lp++      markPat _ (GHC.NPat _ ol mn _) = do+        when (isJust mn) $ mark GHC.AnnMinus+        markLocated ol++      markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do+        markLocated ln+        markWithString GHC.AnnVal "+"  -- "+"+        markLocated ol+++      markPat _ (GHC.SigPat ty pat) = do+        markLocated pat+        mark GHC.AnnDcolon+        markLHsSigWcType ty++      markPat _ GHC.CoPat {} =+        traceM "warning: CoPat introduced after renaming"++      markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x++-- ---------------------------------------------------------------------++hsLit2String :: GHC.HsLit GHC.GhcPs -> String+hsLit2String lit =+  case lit of+    GHC.HsChar       src v   -> toSourceTextWithSuffix src v ""+    -- It should be included here+    -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471+    GHC.HsCharPrim   src p   -> toSourceTextWithSuffix src p "#"+    GHC.HsString     src v   -> toSourceTextWithSuffix src v ""+    GHC.HsStringPrim src v   -> toSourceTextWithSuffix src v ""+    GHC.HsInt        _ (GHC.IL src _ v)   -> toSourceTextWithSuffix src v ""+    GHC.HsIntPrim    src v   -> toSourceTextWithSuffix src v ""+    GHC.HsWordPrim   src v   -> toSourceTextWithSuffix src v ""+    GHC.HsInt64Prim  src v   -> toSourceTextWithSuffix src v ""+    GHC.HsWord64Prim src v   -> toSourceTextWithSuffix src v ""+    GHC.HsInteger    src v _ -> toSourceTextWithSuffix src v ""+    GHC.HsRat        _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v ""+    GHC.HsFloatPrim  _ (GHC.FL src _ v)   -> toSourceTextWithSuffix src v "#"+    GHC.HsDoublePrim _ (GHC.FL src _ v)   -> toSourceTextWithSuffix src v "##"+    (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x++toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String+toSourceTextWithSuffix (GHC.NoSourceText)    alt suffix = show alt ++ suffix+toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix++-- --------------------------------------------------------------------++markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated ()+markHsConPatDetails ln dets = do+  case dets of+    GHC.PrefixCon args -> do+      setContext (Set.singleton PrefixOp) $ markLocated ln+      mapM_ markLocated args+    GHC.RecCon (GHC.HsRecFields fs dd) -> do+      markLocated ln+      mark GHC.AnnOpenC -- '{'+      case dd of+        Nothing ->  markListIntercalateWithFunLevel markLocated 2 fs+        Just _ -> do+          setContext (Set.singleton Intercalate) $ mapM_ markLocated fs+          mark GHC.AnnDotdot+      mark GHC.AnnCloseC -- '}'+    GHC.InfixCon a1 a2 -> do+      markLocated a1+      unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln+      markLocated a2++markHsConDeclDetails ::+  Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated ()++markHsConDeclDetails isDeprecated inGadt lns dets = do+  case dets of+    GHC.PrefixCon args ->+      setContext (Set.singleton PrefixOp) $ mapM_ markLocated args+    -- GHC.RecCon fs -> markLocated fs+    GHC.RecCon fs -> do+      mark GHC.AnnOpenC+      if inGadt+        then do+          if isDeprecated+            then setContext (Set.fromList [InGadt]) $ markLocated fs+            else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs+        else do+          if isDeprecated+            then markLocated fs+            else setContext (Set.fromList [InRecCon]) $ markLocated fs+    GHC.InfixCon a1 a2 -> do+      markLocated a1+      setContext (Set.singleton InfixOp) $ mapM_ markLocated lns+      markLocated a2++-- ---------------------------------------------------------------------++instance Annotate [GHC.LConDeclField GHC.GhcPs] where+  markAST _ fs = do+       markOptional GHC.AnnOpenC -- '{'+       markListIntercalate fs+       markOptional GHC.AnnDotdot+       inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}'+       inContext (Set.singleton InGadt) $ do+         mark GHC.AnnRarrow++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsOverLit GHC.GhcPs) where+  markAST l ol =+    let str = case GHC.ol_val ol of+                GHC.HsIntegral   (GHC.IL src _ _) -> src+                GHC.HsFractional (GHC.FL src _ _) -> src+                GHC.HsIsString src _ -> src+    in+    markExternalSourceText l str ""++-- ---------------------------------------------------------------------++instance (Annotate arg)+    => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where+  markAST _ (GHC.HsIB _ thing) = do+    markLocated thing+  markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where++  markAST _ (GHC.LastStmt _ body _ _)+    = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body++  markAST _ (GHC.BindStmt _ pat body _ _) = do+    unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat+    mark GHC.AnnLarrow+    unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body++    ifInContext (Set.singleton Intercalate)+      (mark GHC.AnnComma)+      (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)+    markTrailingSemi++  markAST _ GHC.ApplicativeStmt{}+    = error "ApplicativeStmt should not appear in ParsedSource"++  markAST _ (GHC.BodyStmt _ body _ _) = do+    unsetContext Intercalate $ markLocated body+    inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar+    inContext (Set.singleton Intercalate) $ mark GHC.AnnComma+    markTrailingSemi++  markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do+    mark GHC.AnnLet+    markOptional GHC.AnnOpenC -- '{'+    markInside GHC.AnnSemi+    markLocalBindsWithLayout lb+    markOptional GHC.AnnCloseC -- '}'+    ifInContext (Set.singleton Intercalate)+      (mark GHC.AnnComma)+      (inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar)+    markTrailingSemi++  markAST l (GHC.ParStmt _ pbs _ _) = do+    -- Within a given parallel list comprehension,one of the sections to be done+    -- in parallel. It is a normal list comprehension, so has a list of+    -- ParStmtBlock, one for each part of the sub- list comprehension+++    ifInContext (Set.singleton Intercalate)+      (++      unsetContext Intercalate $+        markListWithContextsFunction+          (LC (Set.singleton Intercalate)  -- only+              Set.empty -- first+              Set.empty -- middle+              (Set.singleton Intercalate) -- last+          ) (markAST l) pbs+         )+      (+      unsetContext Intercalate $+        markListWithContextsFunction+          (LC Set.empty -- only+              (Set.fromList [AddVbar]) -- first+              (Set.fromList [AddVbar]) -- middle+              Set.empty                -- last+          ) (markAST l) pbs+       )+    markTrailingSemi++  markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do+    setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts+    case form of+      GHC.ThenForm -> do+        mark GHC.AnnThen+        unsetContext Intercalate $ markLocated using+        case by of+          Just b -> do+            mark GHC.AnnBy+            unsetContext Intercalate $ markLocated b+          Nothing -> return ()+      GHC.GroupForm -> do+        mark GHC.AnnThen+        mark GHC.AnnGroup+        case by of+          Just b -> mark GHC.AnnBy >> markLocated b+          Nothing -> return ()+        mark GHC.AnnUsing+        markLocated using+    inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar+    inContext (Set.singleton Intercalate) $ mark GHC.AnnComma+    markTrailingSemi++  markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do+    mark GHC.AnnRec+    markOptional GHC.AnnOpenC+    markInside GHC.AnnSemi+    mapM_ markLocated stmts+    markOptional GHC.AnnCloseC+    inContext (Set.singleton AddVbar)     $ mark GHC.AnnVbar+    inContext (Set.singleton Intercalate) $ mark GHC.AnnComma+    markTrailingSemi++  markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x++-- ---------------------------------------------------------------------++-- Note: We never have a located ParStmtBlock, so have nothing to hang the+-- annotation on. This means there is no pushing of context from the parent ParStmt.+instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where+  markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do+    markListIntercalate stmts+  markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where+  markAST _ lb = markHsLocalBinds lb++-- ---------------------------------------------------------------------++markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()+markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) =+    applyListAnnotationsLayout+       (prepareListAnnotation (GHC.bagToList binds)+     ++ prepareListAnnotation sigs+       )+markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds+markHsLocalBinds GHC.EmptyLocalBinds{}                   = return ()++markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension"+markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _))   = error "markHsLocalBinds:got extension"+markHsLocalBinds (GHC.XHsLocalBindsLR _)                = error "markHsLocalBinds:got extension"++-- ---------------------------------------------------------------------++markMatchGroup :: (Annotate body)+                   => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body)+                   -> Annotated ()+markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _)+  = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches+markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance (Annotate body)+  => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsExpr GHC.GhcPs) where+  markAST loc expr = do+    markExpr loc expr+    inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar+    -- TODO: If the AnnComma is not needed, revert to markAST+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+   where+      markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do+        ifInContext (Set.singleton PrefixOp)+          (setContext (Set.singleton PrefixOp) $ markLocated n)+          (ifInContext (Set.singleton InfixOp)+            (setContext (Set.singleton InfixOp) $ markLocated n)+            (markLocated n)+            )++      markExpr l (GHC.HsRecFld _ f) = markAST l f++      markExpr l (GHC.HsOverLabel _ _ fs)+        = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)+++      markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v))         =+        markAST l n+      markExpr l (GHC.HsOverLit _ ov)     = markAST l ov+      markExpr l (GHC.HsLit _ lit)        = markAST l lit++      markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do+        setContext (Set.singleton LambdaExpr) $ do+        -- TODO: Change this, HsLam binds do not need obey layout rules.+        --       And will only ever have a single match+          markLocated match+      markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match"++      markExpr l (GHC.HsLamCase _ match) = do+        mark GHC.AnnLam+        mark GHC.AnnCase+        markOptional GHC.AnnOpenC+        setContext (Set.singleton CaseAlt) $ do+          markMatchGroup l match+        markOptional GHC.AnnCloseC++      markExpr _ (GHC.HsApp _ e1 e2) = do+        setContext (Set.singleton PrefixOp) $ markLocated e1+        setContext (Set.singleton PrefixOp) $ markLocated e2++      markExpr _ (GHC.OpApp _ e1 e2 e3) = do+        let+          isInfix = case e2 of+            -- TODO: generalise this. Is it a fixity thing?+            GHC.L _ (GHC.HsVar{}) -> True+            _                     -> False++          normal =+            -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context+            ifInContext (Set.singleton LeftMost)+              (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1)+              (markLocated e1)++        if isInfix+            then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1+            else normal++        unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2++        if isInfix+          then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3+          else markLocated e3++      markExpr _ (GHC.NegApp _ e _) = do+        mark GHC.AnnMinus+        markLocated e++      markExpr _ (GHC.HsPar _ e) = do+        mark GHC.AnnOpenP -- '('+        markLocated e+        mark GHC.AnnCloseP -- ')'++      markExpr _ (GHC.SectionL _ e1 e2) = do+        markLocated e1+        setContext (Set.singleton InfixOp) $ markLocated e2++      markExpr _ (GHC.SectionR _ e1 e2) = do+        setContext (Set.singleton InfixOp) $ markLocated e1+        markLocated e2++      markExpr _ (GHC.ExplicitTuple _ args b) = do+        if b == GHC.Boxed then mark GHC.AnnOpenP+                          else markWithString GHC.AnnOpen "(#"++        setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args++        if b == GHC.Boxed then mark GHC.AnnCloseP+                          else markWithString GHC.AnnClose "#)"++      markExpr _ (GHC.ExplicitSum _ alt arity e) = do+        markWithString GHC.AnnOpen "(#"+        replicateM_ (alt - 1) $ mark GHC.AnnVbar+        markLocated e+        replicateM_ (arity - alt) $ mark GHC.AnnVbar+        markWithString GHC.AnnClose "#)"++      markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do+        mark GHC.AnnCase+        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1+        mark GHC.AnnOf+        markOptional GHC.AnnOpenC+        markInside GHC.AnnSemi+        setContext (Set.singleton CaseAlt) $ markMatchGroup l matches+        markOptional GHC.AnnCloseC++      -- We set the layout for HsIf even though it need not obey layout rules as+      -- when moving these expressions it's useful that they maintain "internal+      -- integrity", that is to say the subparts remain indented relative to each+      -- other.+      markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do+      -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do+        mark GHC.AnnIf+        markLocated e1+        markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen+        mark GHC.AnnThen+        setContextLevel (Set.singleton ListStart) 2 $ markLocated e2+        markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse+        mark GHC.AnnElse+        setContextLevel (Set.singleton ListStart) 2 $ markLocated e3++      markExpr _ (GHC.HsMultiIf _ rhs) = do+        mark GHC.AnnIf+        markOptional GHC.AnnOpenC+        setContext (Set.singleton CaseAlt) $ do+          -- mapM_ markLocated rhs+          markListWithLayout rhs+        markOptional GHC.AnnCloseC++      markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do+        setLayoutFlag (do -- Make sure the 'in' gets indented too+          mark GHC.AnnLet+          markOptional GHC.AnnOpenC+          markInside GHC.AnnSemi+          markLocalBindsWithLayout binds+          markOptional GHC.AnnCloseC+          mark GHC.AnnIn+          markLocated e)++      -- -------------------------------++      markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do+        case cts of+          GHC.DoExpr  -> mark GHC.AnnDo+          GHC.MDoExpr -> mark GHC.AnnMdo+          _           -> return ()+        let (ostr,cstr) =+              if isListComp cts+                then ("[", "]")+                else ("{", "}")++        when (isListComp cts) $ markWithString GHC.AnnOpen ostr+        markOptional GHC.AnnOpenS+        markOptional GHC.AnnOpenC+        markInside GHC.AnnSemi+        if isListComp cts+          then do+            markLocated (last es)+            mark GHC.AnnVbar+            setLayoutFlag (markListIntercalate (init es))+          else do+           markListWithLayout es+        markOptional GHC.AnnCloseS+        markOptional GHC.AnnCloseC+        when (isListComp cts) $ markWithString GHC.AnnClose cstr++      -- -------------------------------++      markExpr _ (GHC.ExplicitList _ _ es) = do+        mark GHC.AnnOpenS+        setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es+        mark GHC.AnnCloseS++      markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do+        markLocated n+        mark GHC.AnnOpenC+        case dd of+          Nothing -> markListIntercalate fs+          Just _ -> do+            setContext (Set.singleton Intercalate) $ mapM_ markLocated fs+            mark GHC.AnnDotdot+        mark GHC.AnnCloseC++      markExpr _ (GHC.RecordUpd _ e fs) = do+        markLocated e+        mark GHC.AnnOpenC+        markListIntercalate fs+        mark GHC.AnnCloseC++      markExpr _ (GHC.ExprWithTySig typ e) = do+        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e+        mark GHC.AnnDcolon+        markLHsSigWcType typ++      markExpr _ (GHC.ArithSeq _ _ seqInfo) = do+        mark GHC.AnnOpenS -- '['+        case seqInfo of+            GHC.From e -> do+              markLocated e+              mark GHC.AnnDotdot+            GHC.FromTo e1 e2 -> do+              markLocated e1+              mark GHC.AnnDotdot+              markLocated e2+            GHC.FromThen e1 e2 -> do+              markLocated e1+              mark GHC.AnnComma+              markLocated e2+              mark GHC.AnnDotdot+            GHC.FromThenTo e1 e2 e3 -> do+              markLocated e1+              mark GHC.AnnComma+              markLocated e2+              mark GHC.AnnDotdot+              markLocated e3+        mark GHC.AnnCloseS -- ']'++      markExpr _ (GHC.HsSCC _ src csFStr e) = do+        markAnnOpen src "{-# SCC"+        let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)+        markWithStringOptional GHC.AnnVal    txt+        markWithString         GHC.AnnValStr txt+        markWithString GHC.AnnClose "#-}"+        markLocated e++      markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do+        -- markWithString GHC.AnnOpen src -- "{-# CORE"+        markAnnOpen src "{-# CORE"+        -- markWithString GHC.AnnVal (GHC.sl_st csFStr)+        markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr)+        markWithString GHC.AnnClose "#-}"+        markLocated e+      -- TODO: make monomorphic+      markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do+        mark GHC.AnnSimpleQuote+        setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v)+      markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do+        mark GHC.AnnThTyQuote+        markLocatedFromKw GHC.AnnName (GHC.L l v)+      markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do+        markWithString GHC.AnnOpen "[d|"+        markOptional GHC.AnnOpenC+        setContext (Set.singleton NoAdvanceLine)+             $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds+        markOptional GHC.AnnCloseC+        mark GHC.AnnCloseQ -- "|]"+      -- Introduced after the renamer+      markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) =+        traceM "warning: DecBrG introduced after renamer"+      markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do+        mark GHC.AnnOpenEQ -- "[|"+        markOptional GHC.AnnOpenE  -- "[e|"+        markLocated e+        mark GHC.AnnCloseQ -- "|]"+      markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do+        markWithString GHC.AnnOpen  "[||"+        markWithStringOptional GHC.AnnOpenE "[e||"+        markLocated e+        markWithString GHC.AnnClose "||]"+      markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do+        markWithString GHC.AnnOpen "[t|"+        markLocated e+        mark GHC.AnnCloseQ -- "|]"+      markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do+        markWithString GHC.AnnOpen  "[p|"+        markLocated e+        mark GHC.AnnCloseQ -- "|]"++      markExpr _ (GHC.HsRnBracketOut {}) =+        traceM "warning: HsRnBracketOut introduced after renamer"+      markExpr _ (GHC.HsTcBracketOut {}) =+        traceM "warning: HsTcBracketOut introduced after renamer"++      markExpr l (GHC.HsSpliceE _ e) = markAST l e++      markExpr _ (GHC.HsProc _ p c) = do+        mark GHC.AnnProc+        markLocated p+        mark GHC.AnnRarrow+        markLocated c++      markExpr _ (GHC.HsStatic _ e) = do+        mark GHC.AnnStatic+        markLocated e++      markExpr _ (GHC.HsArrApp _ e1 e2  o isRightToLeft) = do+            -- isRightToLeft True  => right-to-left (f -< arg)+            --               False => left-to-right (arg >- f)+        if isRightToLeft+          then do+            markLocated e1+            case o of+              GHC.HsFirstOrderApp  -> mark GHC.Annlarrowtail+              GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail+          else do+            markLocated e2+            case o of+              GHC.HsFirstOrderApp  -> mark GHC.Annrarrowtail+              GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail++        if isRightToLeft+          then markLocated e2+          else markLocated e1++      markExpr _ (GHC.HsArrForm _ e _ cs) = do+        markWithString GHC.AnnOpenB "(|"+        markLocated e+        mapM_ markLocated cs+        markWithString GHC.AnnCloseB "|)"++      markExpr _ (GHC.HsTick {}) = return ()+      markExpr _ (GHC.HsBinTick {}) = return ()++      markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do+        -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'+        markAnnOpen src  "{-# GENERATED"+        markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING++        let+          markOne n  v GHC.NoSourceText   = markOffsetWithString GHC.AnnVal n (show v)+          markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s++        markOne  1 v1 s1 -- INTEGER+        markOffset GHC.AnnColon 0 -- ':'+        markOne  2 v2 s2 -- INTEGER+        mark   GHC.AnnMinus   -- '-'+        markOne  3 v3 s3 -- INTEGER+        markOffset GHC.AnnColon 1 -- ':'+        markOne  4 v4 s4 -- INTEGER+        markWithString   GHC.AnnClose  "#-}"+        markLocated e++      markExpr l (GHC.EWildPat _) = do+        ifInContext (Set.fromList [InfixOp])+          (do  mark GHC.AnnBackquote+               markWithString GHC.AnnVal "_"+               mark GHC.AnnBackquote)+          (markExternal l GHC.AnnVal "_")++      markExpr _ (GHC.EAsPat _ ln e) = do+        markLocated ln+        mark GHC.AnnAt+        markLocated e++      markExpr _ (GHC.EViewPat _ e1 e2) = do+        markLocated e1+        mark GHC.AnnRarrow+        markLocated e2++      markExpr _ (GHC.ELazyPat _ e) = do+        mark GHC.AnnTilde+        markLocated e++      markExpr _ (GHC.HsAppType ty e) = do+        markLocated e+        markInstead GHC.AnnAt AnnTypeApp+        markLHsWcType ty++      markExpr _ (GHC.HsWrap {}) =+        traceM "warning: HsWrap introduced after renaming"+      markExpr _ (GHC.HsUnboundVar {}) =+        traceM "warning: HsUnboundVar introduced after renaming"++      markExpr _ (GHC.HsConLikeOut{}) =+        traceM "warning: HsConLikeOut introduced after type checking"++      markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension"+      markExpr _ (GHC.XExpr _)                      = error "markExpr got extension"++-- ---------------------------------------------------------------------++markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated ()+markLHsWcType (GHC.HsWC _ ty) = do+  markLocated ty+markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsLit GHC.GhcPs) where+  markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where+  markAST _ (GHC.HsRecField lbl expr punFlag) = do+    unsetContext Intercalate $ markLocated lbl+    when (punFlag == False) $ do+      mark GHC.AnnEqual+      unsetContext Intercalate $ markLocated expr+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where+  markAST _ (GHC.Unambiguous _ n) = markLocated n+  markAST _ (GHC.Ambiguous   _ n) = markLocated n+  markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x++-- ---------------------------------------------------------------------++-- |Used for declarations that need to be aligned together, e.g. in a+-- do or let .. in statement/expr+instance Annotate [GHC.ExprLStmt GHC.GhcPs] where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsTupArg GHC.GhcPs) where+  markAST _ (GHC.Present _ (GHC.L l e)) = do+    markLocated (GHC.L l e)+    inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma)++  markAST _ (GHC.Missing _) = do+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++  markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsCmdTop GHC.GhcPs) where+  markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd+  markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x++instance Annotate (GHC.HsCmd GHC.GhcPs) where+  markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do+        -- isRightToLeft True  => right-to-left (f -< arg)+        --               False => left-to-right (arg >- f)+    if isRightToLeft+      then do+        markLocated e1+        case o of+          GHC.HsFirstOrderApp  -> mark GHC.Annlarrowtail+          GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail+      else do+        markLocated e2+        case o of+          GHC.HsFirstOrderApp  -> mark GHC.Annrarrowtail+          GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail++    if isRightToLeft+      then markLocated e2+      else markLocated e1++  markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do+    -- The AnnOpen should be marked for a prefix usage, not for a postfix one,+    -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm++    let isPrefixOp = case fixity of+          GHC.Infix  -> False+          GHC.Prefix -> True+    when isPrefixOp $ mark GHC.AnnOpenB -- "(|"++    -- This may be an infix operation+    applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp)+                                     (Set.singleton InfixOp) (Set.singleton InfixOp))+                       (prepareListAnnotation [e]+                         ++ prepareListAnnotation cs)+    when isPrefixOp $ mark GHC.AnnCloseB -- "|)"++  markAST _ (GHC.HsCmdApp _ e1 e2) = do+    markLocated e1+    markLocated e2++  markAST l (GHC.HsCmdLam _ match) = do+    setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match++  markAST _ (GHC.HsCmdPar _ e) = do+    mark GHC.AnnOpenP+    markLocated e+    mark GHC.AnnCloseP -- ')'++  markAST l (GHC.HsCmdCase _ e1 matches) = do+    mark GHC.AnnCase+    markLocated e1+    mark GHC.AnnOf+    markOptional GHC.AnnOpenC+    setContext (Set.singleton CaseAlt) $ do+      markMatchGroup l matches+    markOptional GHC.AnnCloseC++  markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do+    mark GHC.AnnIf+    markLocated e1+    markOffset GHC.AnnSemi 0+    mark GHC.AnnThen+    markLocated e2+    markOffset GHC.AnnSemi 1+    mark GHC.AnnElse+    markLocated e3++  markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do+    mark GHC.AnnLet+    markOptional GHC.AnnOpenC+    markLocalBindsWithLayout binds+    markOptional GHC.AnnCloseC+    mark GHC.AnnIn+    markLocated e++  markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do+    mark GHC.AnnDo+    markOptional GHC.AnnOpenC+    markListWithLayout es+    markOptional GHC.AnnCloseC++  markAST _ (GHC.HsCmdWrap {}) =+    traceM "warning: HsCmdWrap introduced after renaming"++  markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance Annotate (GHC.TyClDecl GHC.GhcPs) where++  markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi++  markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do+    -- There may be arbitrary parens around parts of the constructor that are+    -- infix.+    -- Turn these into comments so that they feed into the right place automatically+    -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]+    mark GHC.AnnType++    markTyClass fixity ln tyvars+    mark GHC.AnnEqual+    markLocated typ+    markTrailingSemi++  markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity+                (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do+    if nd == GHC.DataType+      then mark GHC.AnnData+      else mark GHC.AnnNewtype+    markMaybe mctyp+    markLocated ctx+    markTyClass fixity ln tyVars+    case mk of+      Nothing -> return ()+      Just k -> do+        mark GHC.AnnDcolon+        markLocated k+    if isGadt cons+      then mark GHC.AnnWhere+      else unless (null cons) $ mark GHC.AnnEqual+    markOptional GHC.AnnWhere+    markOptional GHC.AnnOpenC+    setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace)+                  $ markListWithContexts' listContexts cons+    markOptional GHC.AnnCloseC+    setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs+    markTrailingSemi++  -- -----------------------------------++  markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds+                          sigs meths ats atdefs docs) = do+    mark GHC.AnnClass+    markLocated ctx++    markTyClass fixity ln tyVars++    unless (null fds) $ do+      mark GHC.AnnVbar+      markListIntercalateWithFunLevel markLocated 2 fds+    mark GHC.AnnWhere+    markOptional GHC.AnnOpenC -- '{'+    markInside GHC.AnnSemi+    -- AZ:TODO: we end up with both the tyVars and the following body of the+    -- class defn in annSortKey for the class. This could cause problems when+    -- changing things.+    setContext (Set.singleton InClassDecl) $+      applyListAnnotationsLayout+                           (prepareListAnnotation sigs+                         ++ prepareListAnnotation (GHC.bagToList meths)+                         ++ prepareListAnnotation ats+                         ++ prepareListAnnotation atdefs+                         ++ prepareListAnnotation docs+                           )+    markOptional GHC.AnnCloseC -- '}'+    markTrailingSemi+{-+  | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs+                tcdCtxt    :: LHsContext pass,         -- ^ Context...+                tcdLName   :: Located (IdP pass),      -- ^ Name of the class+                tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables+                tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration+                tcdFDs     :: [Located (FunDep (Located (IdP pass)))],+                                                        -- ^ Functional deps+                tcdSigs    :: [LSig pass],              -- ^ Methods' signatures+                tcdMeths   :: LHsBinds pass,            -- ^ Default methods+                tcdATs     :: [LFamilyDecl pass],       -- ^ Associated types;+                tcdATDefs  :: [LTyFamDefltEqn pass],+                                                   -- ^ Associated type defaults+                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs+    }++-}++  markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _)+    = error "extension hit for TyClDecl"+  markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _))+    = error "extension hit for TyClDecl"+  markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _)+    = error "extension hit for TyClDecl"+  markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _)+    = error "extension hit for TyClDecl"+  markAST _ (GHC.XTyClDecl _)+    = error "extension hit for TyClDecl"+  +-- ---------------------------------------------------------------------++markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)+                => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated ()+markTyClass fixity ln tyVars = do+    -- There may be arbitrary parens around parts of the constructor+    -- Turn these into comments so that they feed into the right place automatically+    annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]+    let markParens = if fixity == GHC.Infix && length tyVars > 2+          then markMany+          else markManyOptional+    if fixity == GHC.Prefix+      then do+        markManyOptional GHC.AnnOpenP+        setContext (Set.singleton PrefixOp) $ markLocated ln+        -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars+        setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars+        when (length tyVars >= 2) $ do+          markParens GHC.AnnCloseP+          setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars+        markManyOptional GHC.AnnCloseP+      else do+        case tyVars of+          (x:y:xs) -> do+            markParens GHC.AnnOpenP+            markLocated x+            setContext (Set.singleton InfixOp) $ markLocated ln+            markLocated y+            markParens GHC.AnnCloseP+            mapM_ markLocated xs+            markManyOptional GHC.AnnCloseP+          _ -> error $ "markTyClass: Infix op without operands"++-- ---------------------------------------------------------------------++instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where+  markAST _ ds = mapM_ markLocated ds++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where+  markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do+    mark GHC.AnnDeriving+    case mstrategy of+      Nothing -> return ()+      Just (GHC.L _ (GHC.ViaStrategy{})) -> return ()+      Just s -> markLocated s+    markLocated typs+    case mstrategy of+      Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s+      _ -> return ()++  markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x++{-+  = HsDerivingClause+    { deriv_clause_ext :: XCHsDerivingClause pass+    , deriv_clause_strategy :: Maybe (LDerivStrategy pass)+      -- ^ The user-specified strategy (if any) to use when deriving+      -- 'deriv_clause_tys'.+    , deriv_clause_tys :: Located [LHsSigType pass]+      -- ^ The types to derive.+      --+      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,+      -- we can mention type variables that aren't bound by the datatype, e.g.+      --+      -- > data T b = ... deriving (C [a])+      --+      -- should produce a derived instance for @C [a] (T b)@.+    }++-}++-- ---------------------------------------------------------------------++instance Annotate (GHC.FamilyDecl GHC.GhcPs) where+  markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do+    case info of+      GHC.DataFamily -> mark GHC.AnnData+      _              -> mark GHC.AnnType++    mark GHC.AnnFamily++    markTyClass fixity ln tyvars+    case GHC.unLoc rsig of+      GHC.NoSig _ -> return ()+      GHC.KindSig _ _ -> do+        mark GHC.AnnDcolon+        markLocated rsig+      GHC.TyVarSig _ _ -> do+        mark GHC.AnnEqual+        markLocated rsig+      (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x+    case minj of+      Nothing -> return ()+      Just inj -> do+        mark GHC.AnnVbar+        markLocated inj+    case info of+      GHC.ClosedTypeFamily (Just eqns) -> do+        mark GHC.AnnWhere+        markOptional GHC.AnnOpenC -- {+        markListWithLayout eqns+        markOptional GHC.AnnCloseC -- }+      GHC.ClosedTypeFamily Nothing -> do+        mark GHC.AnnWhere+        mark GHC.AnnOpenC -- {+        mark GHC.AnnDotdot+        mark GHC.AnnCloseC -- }+      _ -> return ()+    markTrailingSemi++  markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _)+    = error "got extension for FamilyDecl"+  markAST _ (GHC.XFamilyDecl _)+    = error "got extension for FamilyDecl"++-- ---------------------------------------------------------------------++instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where+  markAST _ (GHC.NoSig _)        = return ()+  markAST _ (GHC.KindSig _ k)    = markLocated k+  markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv+  markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where+  markAST _ (GHC.InjectivityAnn ln lns) = do+    markLocated ln+    mark GHC.AnnRarrow+    mapM_ markLocated lns++-- ---------------------------------------------------------------------++instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where++  markAST _ (GHC.HsIB _ eqn) = do+    markFamEqn eqn+    markTrailingSemi+  markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where++  markAST _ (GHC.FamEqn _ ln (GHC.HsQTvs _ bndrs) fixity typ) = do+    mark GHC.AnnType+    mark GHC.AnnInstance+    markTyClass fixity ln bndrs+    mark GHC.AnnEqual+    markLocated typ++  markAST _ (GHC.FamEqn _ _ (GHC.XLHsQTyVars _) _ _)+    = error "TyFamDefltEqn hit extension point"+  markAST _ (GHC.XFamEqn _)+    = error "TyFamDefltEqn hit extension point"++-- ---------------------------------------------------------------------++-- TODO: modify lexer etc, in the meantime to not set haddock flag+instance Annotate GHC.DocDecl where+  markAST l v =+    let str =+          case v of+            (GHC.DocCommentNext ds)     -> GHC.unpackHDS ds+            (GHC.DocCommentPrev ds)     -> GHC.unpackHDS ds+            (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds+            (GHC.DocGroup _i ds)        -> GHC.unpackHDS ds+    in+      markExternal l GHC.AnnVal str >> markTrailingSemi+{-+data DocDecl+  = DocCommentNext HsDocString+  | DocCommentPrev HsDocString+  | DocCommentNamed String HsDocString+  | DocGroup Int HsDocString++-}++-- ---------------------------------------------------------------------++markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated ()+markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do+  markLocated ctx+  markMaybe typ+  if isGadt cons+    then markListWithLayout cons+    else markListIntercalateWithFunLevel markLocated 2 cons+  setContext (Set.singleton Deriving) $ markLocated derivs+markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x++-- ---------------------------------------------------------------------++-- Note: GHC.HsContext name aliases to here too+instance Annotate [GHC.LHsType GHC.GhcPs] where+  markAST l ts = do+    -- Note: A single item in parens in a standalone deriving clause+    -- is parsed as a HsSigType, which is always a HsForAllTy or+    -- HsQualTy. Without parens it is always a HsVar. So for round+    -- trip pretty printing we need to take this into account.+    let+      parenIfNeeded' pa =+        case ts of+          []  -> if l == GHC.noSrcSpan+            then markManyOptional pa+            else markMany pa+          [GHC.L _ GHC.HsForAllTy{}] -> markMany pa+          [GHC.L _ GHC.HsQualTy{}] -> markMany pa+          [_] -> markManyOptional pa+          _   -> markMany         pa++      parenIfNeeded'' pa =+        ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set?+          (markMany pa)+          (parenIfNeeded' pa)++      parenIfNeeded pa =+        case ts of+          [GHC.L _ GHC.HsParTy{}] -> markOptional pa+          _ -> parenIfNeeded'' pa++    -- -------------++    parenIfNeeded GHC.AnnOpenP++    unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts++    parenIfNeeded GHC.AnnCloseP++    ifInContext (Set.singleton NoDarrow)+      (return ())+      (if null ts && (l == GHC.noSrcSpan)+         then markOptional GHC.AnnDarrow+         else mark         GHC.AnnDarrow)++-- ---------------------------------------------------------------------++instance Annotate (GHC.ConDecl GHC.GhcPs) where+  markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx+                         dets _) = do+    case mqtvs of+      [] -> return ()+      bndrs -> do+        mark GHC.AnnForall+        mapM_ markLocated bndrs+        mark GHC.AnnDot++    case mctx of+      Just ctx -> do+        setContext (Set.fromList [NoDarrow]) $ markLocated ctx+        unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow+      Nothing -> return ()++    case dets of+      GHC.InfixCon _ _ -> return ()+      _ -> setContext (Set.singleton PrefixOp) $ markLocated ln++    markHsConDeclDetails False False [ln] dets++    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar+    markTrailingSemi+{-+  | ConDeclH98+      { con_ext     :: XConDeclH98 pass+      , con_name    :: Located (IdP pass)++      , con_forall  :: Bool   -- ^ True <=> explicit user-written forall+                              --     e.g. data T a = forall b. MkT b (b->a)+                              --     con_ex_tvs = {b}+                              -- False => con_ex_tvs is empty+      , con_ex_tvs :: [LHsTyVarBndr pass]      -- ^ Existentials only+      , con_mb_cxt :: Maybe (LHsContext pass)  -- ^ User-written context (if any)+      , con_args   :: HsConDeclDetails pass    -- ^ Arguments; can be InfixCon++      , con_doc       :: Maybe LHsDocString+          -- ^ A possible Haddock comment.+      }++-}+  markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do+    setContext (Set.singleton PrefixOp) $ markListIntercalate lns+    mark GHC.AnnDcolon+    annotationsToComments [GHC.AnnOpenP]+    markLocated (GHC.L l (ResTyGADTHook forall qvars))+    markMaybe mbCxt+    markHsConDeclDetails False True lns args+    markLocated typ+    markManyOptional GHC.AnnCloseP+    markTrailingSemi+{-+  = ConDeclGADT+      { con_g_ext   :: XConDeclGADT pass+      , con_names   :: [Located (IdP pass)]++      -- The next four fields describe the type after the '::'+      -- See Note [GADT abstract syntax]+      , con_forall  :: Located Bool      -- ^ True <=> explicit forall+                                         --   False => hsq_explicit is empty+      , con_qvars   :: LHsQTyVars pass+                       -- Whether or not there is an /explicit/ forall, we still+                       -- need to capture the implicitly-bound type/kind variables++      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)+      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon+      , con_res_ty  :: LHsType pass            -- ^ Result type++      , con_doc     :: Maybe LHsDocString+          -- ^ A possible Haddock comment.+      }++-}++  markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _)+    = error "hit extension point in ConDecl"+  markAST _ (GHC.XConDecl _)+    = error "hit extension point in ConDecl"++-- ResTyGADT has a SrcSpan for the original sigtype, we need to create+-- a type for exactPC and annotatePC+data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs]+                   deriving (Typeable)+deriving instance Data (ResTyGADTHook)++instance GHC.Outputable ResTyGADTHook where+  ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs+++-- WildCardAnon exists because the GHC anonymous wildcard type is defined as+--      = AnonWildCard (PostRn name Name)+-- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but+-- the instance doing this is parameterised on name, so we cannot put a value in+-- for the (PostRn name Name) field. This is used instead.+data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable)++instance Annotate WildCardAnon where+  markAST l WildCardAnon = do+    markExternal l GHC.AnnVal "_"++-- ---------------------------------------------------------------------++instance Annotate ResTyGADTHook where+  markAST _ (ResTyGADTHook forall bndrs) = do+    unless (null bndrs) $ do+      when forall $ mark GHC.AnnForall+      mapM_ markLocated bndrs+      when forall $ mark GHC.AnnDot++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where+  markAST _ (GHC.HsRecField n e punFlag) = do+    unsetContext Intercalate $ markLocated n+    unless punFlag $ do+      mark GHC.AnnEqual+      unsetContext Intercalate $ markLocated e+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma+++instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where+  markAST _ (GHC.HsRecField n e punFlag) = do+    unsetContext Intercalate $ markLocated n+    unless punFlag $ do+      mark GHC.AnnEqual+      unsetContext Intercalate $ markLocated e+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where++  markAST _ (ls,rs) = do+    mapM_ markLocated ls+    mark GHC.AnnRarrow+    mapM_ markLocated rs+    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance Annotate GHC.CType where+  markAST _ (GHC.CType src mh f) = do+    -- markWithString GHC.AnnOpen src+    markAnnOpen src ""+    case mh of+      Nothing -> return ()+      Just (GHC.Header srcH _h) ->+         -- markWithString GHC.AnnHeader srcH+         markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "")+    -- markWithString GHC.AnnVal (fst f)+    markSourceText  (fst f) (GHC.unpackFS $ snd f)+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++stringLiteralToString :: GHC.StringLiteral -> String+stringLiteralToString (GHC.StringLiteral st fs) =+  case st of+    GHC.NoSourceText   -> GHC.unpackFS fs+    GHC.SourceText src -> src

@@ -122,7 +122,9 @@       (G GHC.AnnStatic   ) -> "static"       (G GHC.AnnThen     ) -> "then"       (G GHC.AnnTilde    ) -> "~"+#if __GLASGOW_HASKELL__ <= 804       (G GHC.AnnTildehsh ) -> "~#"+#endif       (G GHC.AnnType     ) -> "type"       (G GHC.AnnUnit     ) -> "()"       (G GHC.AnnUsing    ) -> "using"@@ -150,6 +152,9 @@ #endif #if __GLASGOW_HASKELL__ >= 800       AnnTypeApp             -> "@"+#endif+#if __GLASGOW_HASKELL__ > 804+      (G GHC.AnnVia) -> "via" #endif  #if __GLASGOW_HASKELL__ <= 710

@@ -210,6 +210,9 @@     dp = case ann of            (G GHC.AnnAs)           -> tellKd (ann,DP (0,1))            (G GHC.AnnAt)           -> tellKd (ann,DP (0,0))+#if __GLASGOW_HASKELL__ >= 806+           (G GHC.AnnAnyclass)     -> tellKd (ann,DP (0,1))+#endif            (G GHC.AnnBackquote)    -> tellKd (ann,DP (0,1))            (G GHC.AnnBang)         -> tellKd (ann,DP (0,1))            (G GHC.AnnBy)           -> tellKd (ann,DP (0,1))@@ -217,6 +220,9 @@            (G GHC.AnnClass)        -> tellKd (ann,DP (0,1))            (G GHC.AnnClose)        -> tellKd (ann,DP (0,1))            (G GHC.AnnCloseC)       -> tellKd (ann,DP (0,0))+#if __GLASGOW_HASKELL__ >= 802+           (G GHC.AnnCloseQ)       -> tellKd (ann,DP (0,1))+#endif            (G GHC.AnnDcolon)       -> tellKd (ann,DP (0,1))            (G GHC.AnnDeriving)     -> tellKd (ann,DP (0,1))            (G GHC.AnnDo)           -> tellKd (ann,DP (0,1))@@ -234,6 +240,7 @@            (G GHC.AnnLam)          -> tellKd (ann,DP (0,1))            (G GHC.AnnMinus)        -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator            (G GHC.AnnModule)       -> tellKd (ann,DP (0,1))+           (G GHC.AnnNewtype)      -> tellKd (ann,DP (0,1))            (G GHC.AnnOf)           -> tellKd (ann,DP (0,1))            (G GHC.AnnOpenC)        -> tellKd (ann,DP (0,0))            (G GHC.AnnOpenPE)       -> tellKd (ann,DP (0,1))@@ -242,6 +249,9 @@            (G GHC.AnnRarrow)       -> tellKd (ann,DP (0,1))            (G GHC.AnnRole)         -> tellKd (ann,DP (0,1))            (G GHC.AnnSafe)         -> tellKd (ann,DP (0,1))+#if __GLASGOW_HASKELL__ >= 806+           (G GHC.AnnStock)        -> tellKd (ann,DP (0,1))+#endif            (G GHC.AnnSimpleQuote)  -> tellKd (ann,DP (0,1))            (G GHC.AnnThIdSplice)   -> tellKd (ann,DP (0,1))            (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1))@@ -253,6 +263,9 @@            (G GHC.AnnVal)          -> tellKd (ann,DP (0,1))            (G GHC.AnnValStr)       -> tellKd (ann,DP (0,1))            (G GHC.AnnVbar)         -> tellKd (ann,DP (0,1))+#if __GLASGOW_HASKELL__ >= 806+           (G GHC.AnnVia)          -> tellKd (ann,DP (0,1))+#endif            (G GHC.AnnWhere)        -> tellKd (ann,DP (1,2)) #if __GLASGOW_HASKELL__ >= 800            AnnTypeApp              -> tellKd (ann,DP (0,1))

@@ -250,27 +250,43 @@ -- nothing to any annotations that may be attached to either of the elements. -- It is used as a utility function in 'replaceDecls' decl2Bind :: GHC.LHsDecl name -> [GHC.LHsBind name]+#if __GLASGOW_HASKELL__ > 804+decl2Bind (GHC.L l (GHC.ValD _ s)) = [GHC.L l s]+#else decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s]+#endif decl2Bind _                      = []  -- |Pure function to convert a 'GHC.LSig' to a 'GHC.LHsBind'. This does -- nothing to any annotations that may be attached to either of the elements. -- It is used as a utility function in 'replaceDecls' decl2Sig :: GHC.LHsDecl name -> [GHC.LSig name]+#if __GLASGOW_HASKELL__ > 804+decl2Sig (GHC.L l (GHC.SigD _ s)) = [GHC.L l s]+#else decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s]+#endif decl2Sig _                      = []  -- ---------------------------------------------------------------------  -- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl' wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs+#if __GLASGOW_HASKELL__ > 804+wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s)+#else wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)+#endif  -- ---------------------------------------------------------------------  -- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl' wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs+#if __GLASGOW_HASKELL__ > 804+wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s)+#else wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)+#endif  -- --------------------------------------------------------------------- @@ -458,7 +474,11 @@   -- logTr $ "balanceComments entered"   -- logDataWithAnnsTr "first" first   case cast first :: Maybe (GHC.LHsDecl GhcPs) of-    Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do+#if __GLASGOW_HASKELL__ > 804+    Just (GHC.L l (GHC.ValD _ fb@(GHC.FunBind{}))) -> do+#else+    Just (GHC.L l (GHC.ValD   fb@(GHC.FunBind{}))) -> do+#endif       balanceCommentsFB (GHC.L l fb) second     _ -> case cast first :: Maybe (GHC.LHsBind GhcPs) of       Just fb'@(GHC.L _ (GHC.FunBind{})) -> do@@ -493,10 +513,12 @@ -- 'GHC.FunBind', these need to be pushed down from the top level to the last -- 'GHC.Match' if that 'GHC.Match' needs to be manipulated. balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m ()-#if __GLASGOW_HASKELL__ <= 710-balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do-#else+#if __GLASGOW_HASKELL__ > 804+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do+#elif __GLASGOW_HASKELL__ > 710 balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do+#else+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do #endif   -- logTr $ "balanceCommentsFB entered"   balanceComments' (last matches) second@@ -646,7 +668,9 @@ -- ---------------------------------------------------------------------  instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 804+  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _ (GHC.L _ lb)))) = do+#elif __GLASGOW_HASKELL__ >= 804   hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do #elif __GLASGOW_HASKELL__ >= 800   hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do@@ -657,8 +681,15 @@ #endif     decls <- hsDeclsValBinds lb     orderedDecls d decls+#if __GLASGOW_HASKELL__ > 804+  hsDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) = return []+  hsDecls (GHC.L _ (GHC.XMatch _))                   = return []+#endif -#if __GLASGOW_HASKELL__ >= 804++#if __GLASGOW_HASKELL__ > 804+  replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) []+#elif __GLASGOW_HASKELL__ >= 804   replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) [] #else   replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) []@@ -684,13 +715,17 @@         binds'' <- replaceDeclsValbinds (GHC.unLoc binds) []         let binds' = GHC.L (GHC.getLoc binds) binds'' #endif-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 804+        return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds')))+#elif __GLASGOW_HASKELL__ >= 804         return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) #else         return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) #endif -#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 804+  replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) newBinds+#elif __GLASGOW_HASKELL__ >= 804   replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds #else   replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds@@ -704,7 +739,11 @@ #else         case GHC.unLoc binds of #endif+#if __GLASGOW_HASKELL__ > 804+          GHC.EmptyLocalBinds{} -> do+#else           GHC.EmptyLocalBinds -> do+#endif             let               addWhere mkds =                 case Map.lookup (mkAnnKey m) mkds of@@ -729,25 +768,37 @@         let binds' = GHC.L (GHC.getLoc binds) binds'' #endif         -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'-#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ > 804+        return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds')))+#elif __GLASGOW_HASKELL__ >= 804         return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) #else         return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) #endif+#if __GLASGOW_HASKELL__ > 804+  replaceDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) _ = error "replaceDecls"+  replaceDecls (GHC.L _ (GHC.XMatch _)) _                   = error "replaceDecls"+#endif  -- ---------------------------------------------------------------------  instance HasDecls (GHC.LHsExpr GhcPs) where-#if __GLASGOW_HASKELL__ <= 710-  hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do-#else+#if __GLASGOW_HASKELL__ > 804+  hsDecls ls@(GHC.L _ (GHC.HsLet _ (GHC.L _ decls) _ex)) = do+#elif __GLASGOW_HASKELL__ > 710   hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do+#else+  hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do #endif     ds <- hsDeclsValBinds decls     orderedDecls ls ds   hsDecls _                               = return [] +#if __GLASGOW_HASKELL__ > 804+  replaceDecls e@(GHC.L l (GHC.HsLet x decls ex)) newDecls+#else   replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls+#endif     = do         logTr "replaceDecls HsLet"         modifyAnnsT (captureOrder e newDecls)@@ -757,12 +808,25 @@         decls'' <- replaceDeclsValbinds (GHC.unLoc decls) newDecls         let decls' = GHC.L (GHC.getLoc decls) decls'' #endif+#if __GLASGOW_HASKELL__ > 804+        return (GHC.L l (GHC.HsLet x decls' ex))+#else         return (GHC.L l (GHC.HsLet decls' ex))+#endif++#if __GLASGOW_HASKELL__ > 804+  replaceDecls (GHC.L l (GHC.HsPar x e)) newDecls+#else   replaceDecls (GHC.L l (GHC.HsPar e)) newDecls+#endif     = do         logTr "replaceDecls HsPar"         e' <- replaceDecls e newDecls+#if __GLASGOW_HASKELL__ > 804+        return (GHC.L l (GHC.HsPar x e'))+#else         return (GHC.L l (GHC.HsPar e'))+#endif   replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GhcPs) undefined for:" ++ showGhc old  -- ---------------------------------------------------------------------@@ -772,7 +836,11 @@ -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent. hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs]+#if __GLASGOW_HASKELL__ > 804+hsDeclsPatBindD (GHC.L l (GHC.ValD _ d)) = hsDeclsPatBind (GHC.L l d)+#else hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d)+#endif hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x  -- | Extract the immediate declarations for a 'GHC.PatBind'. This@@ -780,10 +848,12 @@ -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]-#if __GLASGOW_HASKELL__ <= 710-hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do-#else+#if __GLASGOW_HASKELL__ > 804+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ _ (GHC.GRHSs _ _grhs (GHC.L _ lb)) _)) = do+#elif __GLASGOW_HASKELL__ > 710 hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do+#else+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do #endif   decls <- hsDeclsValBinds lb   orderedDecls d decls@@ -797,9 +867,15 @@ -- idempotent. replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs]                      -> TransformT m (GHC.LHsDecl GhcPs)+#if __GLASGOW_HASKELL__ > 804+replaceDeclsPatBindD (GHC.L l (GHC.ValD x d)) newDecls = do+  (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls+  return (GHC.L l (GHC.ValD x d'))+#else replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do   (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls   return (GHC.L l (GHC.ValD d'))+#endif replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x  -- | Replace the immediate declarations for a 'GHC.PatBind'. This@@ -808,7 +884,11 @@ -- idempotent. replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs]                     -> TransformT m (GHC.LHsBind GhcPs)+#if __GLASGOW_HASKELL__ > 804+replaceDeclsPatBind p@(GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds) b)) newDecls+#else replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls+#endif     = do         logTr "replaceDecls PatBind"         -- Need to throw in a fresh where clause if the binds were empty,@@ -818,7 +898,11 @@ #else         case GHC.unLoc binds of #endif+#if __GLASGOW_HASKELL__ > 804+          GHC.EmptyLocalBinds{} -> do+#else           GHC.EmptyLocalBinds -> do+#endif             let               addWhere mkds =                 case Map.lookup (mkAnnKey p) mkds of@@ -839,33 +923,55 @@         binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls         let binds' = GHC.L (GHC.getLoc binds) binds'' #endif+#if __GLASGOW_HASKELL__ > 804+        return (GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds') b))+#else         return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d))+#endif replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x  -- ---------------------------------------------------------------------  instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where-#if __GLASGOW_HASKELL__ <= 710-  hsDecls ls@(GHC.L _ (GHC.LetStmt lb))       = do-#else+#if __GLASGOW_HASKELL__ > 804+  hsDecls ls@(GHC.L _ (GHC.LetStmt _ (GHC.L _ lb))) = do+#elif __GLASGOW_HASKELL__ > 710   hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do+#else+  hsDecls ls@(GHC.L _ (GHC.LetStmt lb))       = do #endif     decls <- hsDeclsValBinds lb     orderedDecls ls decls-#if __GLASGOW_HASKELL__ <= 710-  hsDecls (GHC.L _ (GHC.LastStmt e _))        = hsDecls e-#else+#if __GLASGOW_HASKELL__ > 804+  hsDecls (GHC.L _ (GHC.LastStmt _ e _ _))    = hsDecls e+#elif __GLASGOW_HASKELL__ >= 804   hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e-#endif-#if __GLASGOW_HASKELL__ <= 710-  hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e+#elif __GLASGOW_HASKELL__ > 800+  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e+#elif __GLASGOW_HASKELL__ > 710+  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e #else+  hsDecls (GHC.L _ (GHC.LastStmt e _))        = hsDecls e+#endif+#if __GLASGOW_HASKELL__ > 804+  hsDecls (GHC.L _ (GHC.BindStmt _ _pat e _ _)) = hsDecls e+#elif __GLASGOW_HASKELL__ > 710   hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e+#else+  hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e #endif+#if __GLASGOW_HASKELL__ > 804+  hsDecls (GHC.L _ (GHC.BodyStmt _ e _ _))    = hsDecls e+#else   hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _))    = hsDecls e+#endif   hsDecls _                                   = return [] +#if __GLASGOW_HASKELL__ > 804+  replaceDecls s@(GHC.L l (GHC.LetStmt x lb)) newDecls+#else   replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls+#endif     = do         modifyAnnsT (captureOrder s newDecls) #if __GLASGOW_HASKELL__ <= 710@@ -874,34 +980,55 @@         lb'' <- replaceDeclsValbinds (GHC.unLoc lb) newDecls         let lb' = GHC.L (GHC.getLoc lb) lb'' #endif-        return (GHC.L l (GHC.LetStmt lb'))-#if __GLASGOW_HASKELL__ <= 710-  replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls+#if __GLASGOW_HASKELL__ > 804+        return (GHC.L l (GHC.LetStmt x lb'))+#else+        return (GHC.L l (GHC.LetStmt   lb'))+#endif+#if __GLASGOW_HASKELL__ > 804+  replaceDecls (GHC.L l (GHC.LastStmt x e d se)) newDecls     = do         e' <- replaceDecls e newDecls-        return (GHC.L l (GHC.LastStmt e' se))-#else+        return (GHC.L l (GHC.LastStmt x e' d se))+#elif __GLASGOW_HASKELL__ > 710   replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls     = do         e' <- replaceDecls e newDecls         return (GHC.L l (GHC.LastStmt e' d se))+#else+  replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls+    = do+        e' <- replaceDecls e newDecls+        return (GHC.L l (GHC.LastStmt e' se)) #endif-#if __GLASGOW_HASKELL__ <= 710-  replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls+#if __GLASGOW_HASKELL__ > 804+  replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls     = do       e' <- replaceDecls e newDecls-      return (GHC.L l (GHC.BindStmt pat e' a b))-#else+      return (GHC.L l (GHC.BindStmt x pat e' a b))+#elif __GLASGOW_HASKELL__ > 710   replaceDecls (GHC.L l (GHC.BindStmt pat e a b c)) newDecls     = do       e' <- replaceDecls e newDecls       return (GHC.L l (GHC.BindStmt pat e' a b c))+#else+  replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls+    = do+      e' <- replaceDecls e newDecls+      return (GHC.L l (GHC.BindStmt pat e' a b)) #endif +#if __GLASGOW_HASKELL__ > 804+  replaceDecls (GHC.L l (GHC.BodyStmt x e a b)) newDecls+    = do+      e' <- replaceDecls e newDecls+      return (GHC.L l (GHC.BodyStmt x e' a b))+#else   replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls     = do       e' <- replaceDecls e newDecls       return (GHC.L l (GHC.BodyStmt e' a b c))+#endif   replaceDecls x _newDecls = return x  -- =====================================================================@@ -947,9 +1074,15 @@       = workerBind b     lhsbind x = return x +#if __GLASGOW_HASKELL__ > 804+    lvald (GHC.L l (GHC.ValD x d)) = do+      (GHC.L _ d') <- lhsbind (GHC.L l d)+      return (GHC.L l (GHC.ValD x d'))+#else     lvald (GHC.L l (GHC.ValD d)) = do       (GHC.L _ d') <- lhsbind (GHC.L l d)       return (GHC.L l (GHC.ValD d'))+#endif     lvald x = return x  -- ---------------------------------------------------------------------@@ -982,10 +1115,12 @@     -- ---------------------------------      lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]-#if __GLASGOW_HASKELL__ <= 710-    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do-#else+#if __GLASGOW_HASKELL__ > 804+    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do+#elif __GLASGOW_HASKELL__ > 710     lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do+#else+    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do #endif         dss <- mapM hsDecls matches         return (concat dss)@@ -995,7 +1130,11 @@      -- --------------------------------- +#if __GLASGOW_HASKELL__ > 804+    lhsbindd (GHC.L l (GHC.ValD _ d)) = lhsbind (GHC.L l d)+#else     lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d)+#endif     lhsbindd _ = return []      -- ---------------------------------@@ -1032,6 +1171,17 @@ -- context in the AST. hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsValBinds lb = case lb of+#if __GLASGOW_HASKELL__ > 804+    GHC.HsValBinds _ (GHC.ValBinds _ bs sigs) -> do+      let+        bds = map wrapDecl (GHC.bagToList bs)+        sds = map wrapSig sigs+      return (bds ++ sds)+    GHC.HsValBinds _ (GHC.XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"+    GHC.HsIPBinds {}       -> return []+    GHC.EmptyLocalBinds {} -> return []+    GHC.XHsLocalBindsLR {} -> return []+#else     GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do       let         bds = map wrapDecl (GHC.bagToList bs)@@ -1040,6 +1190,7 @@     GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"     GHC.HsIPBinds _     -> return []     GHC.EmptyLocalBinds -> return []+#endif  -- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with -- care, as this does not manage the declaration order, the@@ -1049,22 +1200,45 @@                      => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]                      -> TransformT m (GHC.HsLocalBinds GhcPs) replaceDeclsValbinds _ [] = do+#if __GLASGOW_HASKELL__ > 804+  return (GHC.EmptyLocalBinds GHC.noExt)+#else   return (GHC.EmptyLocalBinds)+#endif+#if __GLASGOW_HASKELL__ > 804+replaceDeclsValbinds (GHC.HsValBinds _ _b) new+#else replaceDeclsValbinds (GHC.HsValBinds _b) new+#endif     = do         logTr "replaceDecls HsLocalBinds"         let decs = GHC.listToBag $ concatMap decl2Bind new         let sigs = concatMap decl2Sig new+#if __GLASGOW_HASKELL__ > 804+        return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))+#else         return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))-replaceDeclsValbinds (GHC.HsIPBinds _b) _new    = error "undefined replaceDecls HsIPBinds"+#endif+replaceDeclsValbinds (GHC.HsIPBinds {}) _new    = error "undefined replaceDecls HsIPBinds"+#if __GLASGOW_HASKELL__ > 804+replaceDeclsValbinds (GHC.EmptyLocalBinds _) new+#else replaceDeclsValbinds (GHC.EmptyLocalBinds) new+#endif     = do         logTr "replaceDecls HsLocalBinds"         let newBinds = map decl2Bind new             newSigs  = map decl2Sig  new         let decs = GHC.listToBag $ concat newBinds         let sigs = concat newSigs+#if __GLASGOW_HASKELL__ > 804+        return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))+#else         return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))+#endif+#if __GLASGOW_HASKELL__ > 804+replaceDeclsValbinds (GHC.XHsLocalBindsLR _) _ = error "replaceDeclsValbinds. XHsLocalBindsLR"+#endif  -- --------------------------------------------------------------------- @@ -1080,7 +1254,11 @@                 -> Decl                 -> (Match -> [Decl] -> m ([Decl], Maybe t))                 -> m (Decl,Maybe t)+#if __GLASGOW_HASKELL__ > 804+modifyValD p pb@(GHC.L ss (GHC.ValD _ (GHC.PatBind {} ))) f =+#else modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f =+#endif   if ss == p      then do        ds <- liftT $ hsDeclsPatBindD pb

@@ -355,8 +355,27 @@ -- ---------------------------------------------------------------------  declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b++#if __GLASGOW_HASKELL__ > 804 declFun f (GHC.L l de) =   case de of+      GHC.TyClD _ d       -> f (GHC.L l d)+      GHC.InstD _ d       -> f (GHC.L l d)+      GHC.DerivD _ d      -> f (GHC.L l d)+      GHC.ValD _ d        -> f (GHC.L l d)+      GHC.SigD _ d        -> f (GHC.L l d)+      GHC.DefD _ d        -> f (GHC.L l d)+      GHC.ForD _ d        -> f (GHC.L l d)+      GHC.WarningD _ d    -> f (GHC.L l d)+      GHC.AnnD _ d        -> f (GHC.L l d)+      GHC.RuleD _ d       -> f (GHC.L l d)+      GHC.SpliceD _ d     -> f (GHC.L l d)+      GHC.DocD _ d        -> f (GHC.L l d)+      GHC.RoleAnnotD _ d  -> f (GHC.L l d)+      GHC.XHsDecl _       -> error "declFun:XHsDecl"+#else+declFun f (GHC.L l de) =+  case de of       GHC.TyClD d       -> f (GHC.L l d)       GHC.InstD d       -> f (GHC.L l d)       GHC.DerivD d      -> f (GHC.L l d)@@ -374,7 +393,7 @@ #if __GLASGOW_HASKELL__ < 711       GHC.QuasiQuoteD d -> f (GHC.L l d) #endif-+#endif  -- --------------------------------------------------------------------- 

@@ -263,7 +263,9 @@ isListComp cts = case cts of           GHC.ListComp  -> True           GHC.MonadComp -> True+#if __GLASGOW_HASKELL__ <= 804           GHC.PArrComp  -> True+#endif            GHC.DoExpr       -> False           GHC.MDoExpr      -> False

@@ -28,11 +28,14 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 deriving (Eq, Ord, Show)+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86+     deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion ghcVersion =-#if __GLASGOW_HASKELL__ > 802+#if __GLASGOW_HASKELL__ > 804+  GHC86+#elif __GLASGOW_HASKELL__ > 802   GHC84 #elif __GLASGOW_HASKELL__ > 800   GHC82@@ -46,14 +49,16 @@ testDirs :: [FilePath] testDirs =   case ghcVersion of-    GHC710 -> ["ghc710-only","ghc710"]-    GHC80  -> ["ghc710", "ghc80"]-    GHC82  -> ["ghc710", "ghc80", "ghc82"]-    GHC84  -> ["ghc710", "ghc80", "ghc82", "ghc84" ]-    -- GHC84  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc84-copied"]-    -- GHC84  -> ["ghc84-copied"]-    -- GHC84  -> ["ghc84"]+    GHC710 -> ["ghc710-only","ghc710", "vect"]+    GHC80  -> [              "ghc710", "ghc80", "vect"]+    GHC82  -> ["pre-ghc86",  "ghc710", "ghc80", "ghc82", "vect"]+    GHC84  -> ["pre-ghc86",  "ghc710", "ghc80", "ghc82", "ghc84", "vect" ]+    GHC86  -> [              "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ] +    -- GHC86  -> [             "ghc710", "ghc80", "ghc82", "ghc84"]+    -- GHC86  -> ["ghc86-copied"]+    -- GHC86  -> ["ghc86"]+ -- ---------------------------------------------------------------------  main :: IO ()@@ -192,39 +197,21 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ -      -- mkPrettyRoundtrip "ghc80" "Zwaluw.hs"-      -- mkPrettyRoundtrip "ghc80" "pmc007.hs"-      -- mkPrettyRoundtrip "ghc80" "MultiQuote.hs"-      -- mkPrettyRoundtrip "ghc80" "T10689a.hs"        -- mkPrettyRoundtrip "ghc82" "TensorTests.hs" -   --    mkParserTest      "ghc84" "Main.hs"-      -- mkParserTest      "ghc84" "Types.hs"-    -- , mkPrettyRoundtrip "ghc80" "BundleExport.hs"-    -- , mkPrettyRoundtrip "ghc80" "ExportSyntax.hs"-    -- , mkPrettyRoundtrip "ghc80" "export-class.hs"-    -- , mkPrettyRoundtrip "ghc80" "export-syntax.hs"-    -- , mkPrettyRoundtrip "ghc80" "export-type.hs"--      -- mkPrettyRoundtrip "ghc84" "Main.hs"-      -- mkPrettyRoundtrip "ghc84" "Types.hs"--      mkPrettyRoundtrip "ghc80" "Vta1.hs"-    , mkPrettyRoundtrip "ghc80" "Vta2.hs"--      -- mkParserTest      "ghc80" "BundleExport.hs"+      mkParserTest      "ghc710" "GADTContext.hs" -    -- , mkParserTest      "ghc710" "TypeOperators.hs"-    -- , mkParserTest      "ghc80" "TestUtils.hs"+      -- mkParserTest      "ghc86" "deriving-via-compile.hs"+    --   mkParserTest "pre-ghc86" "TensorTests.hs"+    -- , mkParserTest "pre-ghc86" "Webhook.hs"+    -- , mkParserTest "ghc710" "RdrNames.hs" -     --   mkParserTest "ghc84" "Functors.hs"-     -- , mkParserTest "ghc80" "MonadT.hs"+    --   mkPrettyRoundtrip "ghc86" "BinDU.hs"+    -- , mkPrettyRoundtrip "ghc86" "Dial.hs" -      -- mkParserTest "ghc80" "SemicolonIf.hs"-      -- mkParserTest "ghc80" "T10689a.hs"-      -- mkParserTest "ghc80" "MonadT.hs"-      -- mkParserTest "ghc710" "Ann01.hs"+      -- mkParserTest      "ghc84" "Types.hs"+    -- , mkPrettyRoundtrip "ghc80" "export-type.hs"     -- Needs GHC changes         -- mkParserTest "failing" "CtorOp.hs"

@@ -95,8 +95,13 @@ -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer changeLocalDecls2 ans (GHC.L l p) = do+#if __GLASGOW_HASKELL__ > 804+  Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+  Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig)))   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")+#else   Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")   Right (sigAnns, s@(GHC.L ls (GHC.SigD sig)))   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")+#endif   let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns   let  sigAnns' = setPrecedingLines (GHC.L ls  sig) 1 4 sigAnns   -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns@@ -110,8 +115,10 @@       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do #elif __GLASGOW_HASKELL__ <= 802       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do-#else+#elif __GLASGOW_HASKELL__ <= 804       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do+#else+      replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do #endif         newSpan <- uniqueSrcSpanT         let@@ -132,16 +139,24 @@         let decls = [s,d]         -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)         modifyAnnsT (captureOrderAnnKey newAnnKey decls)+#if __GLASGOW_HASKELL__ > 804+        let binds = (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt (GHC.listToBag $ [GHC.L ld decl])+                                    [GHC.L ls sig]))+#else         let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])                                     [GHC.L ls sig]))+#endif #if __GLASGOW_HASKELL__ <= 710         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds))) #elif __GLASGOW_HASKELL__ <= 802         bindSpan <- uniqueSrcSpanT         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds))))-#else+#elif __GLASGOW_HASKELL__ <= 804         bindSpan <- uniqueSrcSpanT         return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds))))+#else+        bindSpan <- uniqueSrcSpanT+        return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L bindSpan binds)))) #endif       replaceLocalBinds x = return x   -- putStrLn $ "log:" ++ intercalate "\n" w@@ -152,8 +167,13 @@ -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer changeLocalDecls ans (GHC.L l p) = do+#if __GLASGOW_HASKELL__ > 804+  Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+  Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig)))   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")+#else   Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")   Right (sigAnns, s@(GHC.L ls (GHC.SigD sig)))   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")+#endif   let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns   let  sigAnns' = setPrecedingLines (GHC.L ls  sig) 1 4 sigAnns   -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns@@ -167,8 +187,10 @@       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do #elif __GLASGOW_HASKELL__ <= 802       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do-#else+#elif __GLASGOW_HASKELL__ <= 804       replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do+#else+      replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do #endif         a1 <- getAnnsT         a' <- case sigs of@@ -181,15 +203,23 @@         let decls = s:d:oldDecls         -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)         modifyAnnsT (captureOrder m decls)+#if __GLASGOW_HASKELL__ > 804+        let binds' = (GHC.HsValBinds GHC.noExt+                          (GHC.ValBinds GHC.noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)+                                          (GHC.L ls sig:sigs)))+#else         let binds' = (GHC.HsValBinds                           (GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)                                           (GHC.L ls sig:sigs)))+#endif #if __GLASGOW_HASKELL__ <= 710         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds'))) #elif __GLASGOW_HASKELL__ <= 802         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds'))))-#else+#elif __GLASGOW_HASKELL__ <= 804         return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds'))))+#else+        return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L lb binds')))) #endif       replaceLocalBinds x = return x   -- putStrLn $ "log:" ++ intercalate "\n" w@@ -289,22 +319,26 @@     replaceRdr x = x      replaceHsVar :: GHC.LHsExpr GhcPs -> GHC.LHsExpr GhcPs-    replaceHsVar (GHC.L ln (GHC.HsVar _))+    replaceHsVar (GHC.L ln (GHC.HsVar{})) #if __GLASGOW_HASKELL__ <= 710         | cond ln = GHC.L ln (GHC.HsVar newName)-#else+#elif __GLASGOW_HASKELL__ <= 804         | cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName))+#else+        | cond ln = GHC.L ln (GHC.HsVar GHC.noExt (GHC.L ln newName)) #endif     replaceHsVar x = x  #if __GLASGOW_HASKELL__ > 802     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs #endif-    replacePat (GHC.L ln (GHC.VarPat _))+    replacePat (GHC.L ln (GHC.VarPat {})) #if __GLASGOW_HASKELL__ <= 710         | cond ln = GHC.L ln (GHC.VarPat newName)-#else+#elif __GLASGOW_HASKELL__ <= 804         | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))+#else+        | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName)) #endif     replacePat x = x @@ -334,16 +368,27 @@     replace :: GHC.HsExpr GhcPs -> GHC.HsExpr GhcPs #if __GLASGOW_HASKELL__ <= 710     replace (GHC.HsLet localDecls expr@(GHC.L _ _))-#else+#elif __GLASGOW_HASKELL__ <= 804     replace (GHC.HsLet (GHC.L lb localDecls) expr@(GHC.L _ _))+#else+    replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _)) #endif       =+#if __GLASGOW_HASKELL__ > 804+         let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls+             bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls+#else          let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls              bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls+#endif #if __GLASGOW_HASKELL__ <= 710          in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr)-#else+#elif __GLASGOW_HASKELL__ <= 802          in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr)+#elif __GLASGOW_HASKELL__ <= 804+         in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr)+#else+         in (GHC.HsLet GHC.noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) #endif      replace x = x@@ -494,8 +539,10 @@  #if __GLASGOW_HASKELL__ <= 710         let GHC.L _ (GHC.ValD (GHC.FunBind  _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1-#else+#elif __GLASGOW_HASKELL__ <= 804         let GHC.L _ (GHC.ValD (GHC.FunBind  _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1+#else+        let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 #endif         balanceComments m1 m2 @@ -601,8 +648,10 @@           go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs) #if __GLASGOW_HASKELL__ <= 710           go (GHC.HsLet lb expr) = do-#else+#elif __GLASGOW_HASKELL__ <= 804           go (GHC.HsLet (GHC.L l lb) expr) = do+#else+          go (GHC.HsLet _ (GHC.L l lb) expr) = do #endif             decs <- hsDeclsValBinds lb             let dec = last decs@@ -610,8 +659,10 @@             lb' <- replaceDeclsValbinds lb [dec] #if __GLASGOW_HASKELL__ <= 710             return (GHC.HsLet lb' expr)-#else+#elif __GLASGOW_HASKELL__ <= 804             return (GHC.HsLet (GHC.L l lb') expr)+#else+            return (GHC.HsLet GHC.noExt (GHC.L l lb') expr) #endif           go x = return x @@ -671,9 +722,12 @@ #if __GLASGOW_HASKELL__ <= 710              (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1              s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p)))-#else+#elif __GLASGOW_HASKELL__ <= 804              (GHC.L l (GHC.SigD (GHC.TypeSig names typ))) = s1              s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ)))+#else+             (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1+             s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ))) #endif          replaceDecls lp (s1':d1:d2) @@ -709,7 +763,10 @@           [GHC.L li imp1,imp2] = GHC.hsmodImports p           n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))           n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))-#if __GLASGOW_HASKELL__ > 800+#if __GLASGOW_HASKELL__ > 804+          v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1)))+          v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2)))+#elif __GLASGOW_HASKELL__ > 800           v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1)))           v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) #else@@ -740,7 +797,10 @@           Just (_,GHC.L lh ns) = GHC.ideclHiding imp1           n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))           n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))-#if __GLASGOW_HASKELL__ > 800+#if __GLASGOW_HASKELL__ > 804+          v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1)))+          v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2)))+#elif __GLASGOW_HASKELL__ > 800           v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1)))           v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) #else

@@ -1,40 +0,0 @@-{-# LANGUAGE ParallelArrays #-}-{-# OPTIONS -fvectorise -XParallelListComp #-}-module DiophantineVect (solution3) where--import Data.Array.Parallel-import Data.Array.Parallel.Prelude.Int as I--import qualified Prelude as P--solution3'- = let-     pow x i     = productP (replicateP i x)-     primes      = [: 2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73 :]-     a `cutTo` b = sliceP 0 (lengthP b) a-     sumpri xx   = productP [: pow p x | p <- primes `cutTo` xx | x <- xx :]-     distinct xx = productP [: x I.+ 1   | x <- xx :]--     series :: [:Int:] -> Int -> [:[:Int:]:]-     series xs n-       | n == 1      = [: [: 0 :] :]-       | otherwise   = [: [: x :] +:+ ps-                             | x <- xs-                             , ps <- series (I.enumFromToP 0 x) (n I.- 1) :]--     prob x y-      = let  xx      = [: (sumpri m ,m)-                             | m <- series (I.enumFromToP 1 3) x-                             , distinct [: x I.* 2 | x <- m :] > y :]-             i       = minIndexP [: a | (a, b) <- xx :]-        in   xx !: i-   in-   prob 5 200--solution3 :: (Int, PArray Int)-{-# NOINLINE solution3 #-}-solution3-  = let (i, is) = solution3'-    in-    (i, toPArrayP is)-

@@ -1,13 +0,0 @@-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE StandaloneDeriving #-}--data StackItem a where-  Snum :: forall a. Fractional a => a -> StackItem a-  Sop  :: OpDesc -> StackItem a-deriving instance Show a => Show (StackItem a)---- AZ added to test Trac #10399-data MaybeDefault v where-    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v-    SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v -> a -> MaybeDefault [a])

@@ -1,25 +0,0 @@-{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}--give :: b -> Pattern '[b] a-give b = Pattern (const (Just $ oneT b))---pfail :: Pattern '[] a-pfail = is (const False)--(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a-(/\) = mk2 (\a -> Just (a,a))--data Pattern :: [*] -> * where-  Nil :: Pattern '[]-  Cons :: Maybe h -> Pattern t -> Pattern (h ': t)--type Pos = '("vpos", V3 GLfloat)-type Tag = '("tagByte", V1 Word8)---- | Alias for the 'In' type from the 'Direction' kind, allows users to write--- the 'BroadcastChan In a' type without enabling DataKinds.-type In = 'In--- | Alias for the 'Out' type from the 'Direction' kind, allows users to write--- the 'BroadcastChan Out a' type without enabling DataKinds.-type Out = 'Out

@@ -4,3 +4,4 @@ (~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts) (~#) = cascadeW infixr 0 ~#+

@@ -1,14 +0,0 @@-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE KindSignatures      #-}-{-# LANGUAGE LiberalTypeSynonyms #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE TypeFamilies        #-}---type ( f :->   g) (r :: * -> *) ix = f r ix -> g r ix--type ( f :-->  g)  b ix = f b ix -> g b ix--type ((f :---> g)) b ix = f b ix -> g b ix

@@ -1,70 +0,0 @@-{-# LANGUAGE ParallelArrays #-}-{-# OPTIONS_GHC -fvectorise #-}-{-# LANGUAGE UnboxedTuples #-}--module Vect where---- import Data.Array.Parallel---{-# VECTORISe isFive = blah #-}-{-# NoVECTORISE isEq #-}--{-# VECTORISE SCALAR type Int  #-}-{-# VECTORISE        type Char #-}-{-# VECTORISE        type ( ) #-}-{-# VECTORISE        type (# #) #-}--{-# VECTORISE SCALAR type Integer = Int #-}-{-# VECTORISE        type Bool    = String  #-}--{-# Vectorise class Eq #-}--blah = 5--data MyBool = MyTrue | MyFalse--class Eq a => Cmp a where-  cmp :: a -> a -> Bool---- FIXME:--- instance Cmp Int where---   cmp = (==)--- isFive :: (Eq a, Num a) => a -> Bool-isFive :: Int -> Bool-isFive x = x == 5--isEq :: Eq a => a -> Bool-isEq x = x == x---fiveEq :: Int -> Bool-fiveEq x = isFive x && isEq x--cmpArrs :: PArray Int -> PArray Int -> Bool-{-# NOINLINE cmpArrs #-}-cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w)--cmpArrs' :: [:Int:] -> [:Int:] -> Bool-cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:]--isFives :: PArray Int -> Bool-{-# NOINLINE isFives #-}-isFives xs = isFives' (fromPArrayP xs)--isFives' :: [:Int:] -> Bool-isFives' xs = andP (mapP isFive xs)--isEqs :: PArray Int -> Bool-{-# NOINLINE isEqs #-}-isEqs xs = isEqs' (fromPArrayP xs)--isEqs' :: [:Int:] -> Bool-isEqs' xs = undefined -- andP (mapP isEq xs)---- fudge for compiler--fromPArrayP = undefined-andP = undefined-mapP = undefined-data PArray a = PArray a

@@ -1,9 +0,0 @@-{-# LANGUAGE TypeInType #-}--module BadTelescope where--import Data.Kind--data SameKind :: k -> k -> *--data X a k (b :: k) (c :: SameKind a b)

@@ -1,14 +0,0 @@-{-# 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

@@ -1,9 +0,0 @@-{-# LANGUAGE TypeInType, ExplicitForAll #-}--module BadTelescope3 where--import Data.Kind--data SameKind :: k -> k -> *--type S a k (b :: k) = SameKind a b

@@ -1,13 +0,0 @@-{-# 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.

@@ -1,26 +0,0 @@-{-# 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

@@ -0,0 +1,37 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++data StackItem a where+  Snum :: forall a. Fractional a => a -> StackItem a+  Sop  :: OpDesc -> StackItem a+deriving instance Show a => Show (StackItem a)++type MPI = ?mpi_secret :: MPISecret++mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)++data MaybeDefault v where+    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v+    SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v+                                            -> a -> MaybeDefault [a])+    TestParens  :: (forall v . (Eq v) => MaybeDefault v)+    TestParens2 :: (forall v . ((Eq v)) => MaybeDefault v)+    TestParens3 :: (forall v . (((Eq v)) => (MaybeDefault v)))+    TestParens4 :: (forall v . (((Eq v)) => (MaybeDefault v -> MaybeDefault v)))++data T a where+  K1 :: forall a. Ord a => { x :: [a], y :: Int } -> T a+  K2 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> T a+  K3 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> (T a)+  K4 :: (forall a. Ord a => { x :: [a], y :: Int } -> T a)++[t| Map.Map T.Text $tc |]++bar $( [p| x |] ) = x

@@ -1,43 +0,0 @@-{-# 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)

@@ -1,35 +0,0 @@-{-# 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.

@@ -1,23 +0,0 @@-{-# 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)

@@ -1,24 +0,0 @@-{-# 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) *)

@@ -1,63 +0,0 @@-{-# 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 = (* :: (* :: (* :: *)))

@@ -1,5 +0,0 @@-{-# LANGUAGE TypeInType #-}--module RenamingStar where--data Foo :: *

@@ -1,11 +0,0 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-module T10134a where--import GHC.TypeLits--data Vec :: Nat -> * -> * where-  Nil  :: Vec 0 a-  (:>) :: a -> Vec n a -> Vec (n + 1) a

@@ -1,14 +0,0 @@-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE GADTs          #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators  #-}--module T10321 where--import GHC.TypeLits--data Vec :: Nat -> * -> * where-  Nil  :: Vec 0 a-  (:>) :: a -> Vec n a -> Vec (n + 1) a--infixr 5 :>

@@ -1,114 +0,0 @@-{-# LANGUAGE TypeOperators-           , DataKinds-           , PolyKinds-           , TypeFamilies-           , GADTs-           , UndecidableInstances-           , RankNTypes-           , ScopedTypeVariables-  #-}--{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Werror #-}-{-# OPTIONS_GHC -O1 -fspec-constr #-}--{--ghc-stage2: panic! (the 'impossible' happened)-  (GHC version 7.11.20150723 for x86_64-unknown-linux):-        Template variable unbound in rewrite rule--}--module List (sFoldr1) where--data Proxy t--data family Sing (a :: k)--data TyFun (a :: *) (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

@@ -1,38 +0,0 @@-{-# 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

@@ -1,10 +0,0 @@-{-# 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

@@ -1,76 +0,0 @@-{-# 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

@@ -1,11 +0,0 @@-{-# LANGUAGE TypeInType #-}--module T9632 where--import Data.Kind--data B = T | F-data P :: B -> *--type B' = B-data P' :: B' -> *

@@ -1,243 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE Arrows          #-}--module Tutorial where---- import Abt.Class--- import Abt.Types--- import Abt.Concrete.LocallyNameless--import Control.Applicative-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Except--- import Data.Vinyl-import Prelude hiding (pi)---- | We'll start off with a monad in which to manipulate ABTs; we'll need some--- state for fresh variable generation.----newtype M α-  = M-  { _M ∷ State Int α-  } deriving (Functor, Applicative, Monad)---- | We'll run an ABT computation by starting the variable counter at @0@.----runM ∷ M α → α-runM (M m) = evalState m 0---- | Check out the source to see fresh variable generation.----instance MonadVar Var M where-  fresh = M $ do-    n ← get-    let n' = n + 1-    put n'-    return $ Var Nothing n'--  named a = do-    v ← fresh-    return $ v { _varName = Just a }---- | Next, we'll define the operators for a tiny lambda calculus as a datatype--- indexed by arities.----data Lang ns where-  LAM ∷ Lang '[S Z]-  APP ∷ Lang '[Z, Z]-  PI ∷ Lang '[Z, S Z]-  UNIT ∷ Lang '[]-  AX ∷ Lang '[]--instance Show1 Lang where-  show1 = \case-    LAM → "lam"-    APP → "ap"-    PI → "pi"-    UNIT → "unit"-    AX → "<>"--instance HEq1 Lang where-  heq1 LAM LAM = Just Refl-  heq1 APP APP = Just Refl-  heq1 PI PI = Just Refl-  heq1 UNIT UNIT = Just Refl-  heq1 AX AX = Just Refl-  heq1 _ _ = Nothing--lam ∷ Tm Lang (S Z) → Tm0 Lang-lam e = LAM $$ e :& RNil--app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang-app m n = APP $$ m :& n :& RNil--ax ∷ Tm0 Lang-ax = AX $$ RNil--unit ∷ Tm0 Lang-unit = UNIT $$ RNil--pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang-pi α xβ = PI $$ α :& xβ :& RNil---- | A monad transformer for small step operational semantics.----newtype StepT m α-  = StepT-  { runStepT ∷ MaybeT m α-  } deriving (Monad, Functor, Applicative, Alternative)---- | To indicate that a term is in normal form.----stepsExhausted-  ∷ Applicative m-  ⇒ StepT m α-stepsExhausted = StepT . MaybeT $ pure Nothing--instance MonadVar Var m ⇒ MonadVar Var (StepT m) where-  fresh = StepT . MaybeT $ Just <$> fresh-  named str = StepT . MaybeT $ Just <$> named str---- | A single evaluation step.----step-  ∷ Tm0 Lang-  → StepT M (Tm0 Lang)-step tm =-  out tm >>= \case-    APP :$ m :& n :& RNil →-      out m >>= \case-        LAM :$ xe :& RNil → xe // n-        _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n-    PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ-    _ → stepsExhausted---- | The reflexive-transitive closure of a small-step operational semantics.----star-  ∷ Monad m-  ⇒ (α → StepT m α)-  → (α → m α)-star f a =-  runMaybeT (runStepT $ f a) >>=-    return a `maybe` star f---- | Evaluate a term to normal form----eval ∷ Tm0 Lang → Tm0 Lang-eval = runM . star step--newtype JudgeT m α-  = JudgeT-  { runJudgeT ∷ ExceptT String m α-  } deriving (Monad, Functor, Applicative, Alternative)--instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where-  fresh = JudgeT . ExceptT $ Right <$> fresh-  named str = JudgeT . ExceptT $ Right <$> named str--type Ctx = [(Var, Tm0 Lang)]--raise ∷ Monad m ⇒ String → JudgeT m α-raise = JudgeT . ExceptT . return . Left--checkTy-  ∷ Ctx-  → Tm0 Lang-  → Tm0 Lang-  → JudgeT M ()-checkTy g tm ty = do-  let ntm = eval tm-      nty = eval ty-  (,) <$> out ntm <*> out nty >>= \case-    (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do-      z ← fresh-      ez ← xe // var z-      βz ← yβ // var z-      checkTy ((z,α):g) ez βz-    (AX :$ RNil, UNIT :$ RNil) → return ()-    _ → do-      ty' ← inferTy g tm-      if ty' === nty-        then return ()-        else raise "Type error"--inferTy-  ∷ Ctx-  → Tm0 Lang-  → JudgeT M (Tm0 Lang)-inferTy g tm = do-  out (eval tm) >>= \case-    V v | Just (eval → ty) ← lookup v g → return ty-        | otherwise → raise "Ill-scoped variable"-    APP :$ m :& n :& RNil → do-      inferTy g m >>= out >>= \case-        PI :$ α :& xβ :& RNil → do-          checkTy g n α-          eval <$> xβ // n-        _ → raise "Expected pi type for lambda abstraction"-    _ → raise "Only infer neutral terms"---- | @λx.x@----identityTm ∷ M (Tm0 Lang)-identityTm = do-  x ← fresh-  return $ lam (x \\ var x)---- | @(λx.x)(λx.x)@----appTm ∷ M (Tm0 Lang)-appTm = do-  tm ← identityTm-  return $ app tm tm---- | A demonstration of evaluating (and pretty-printing). Output:------ @--- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4]--- @----main ∷ IO ()-main = do-  -- Try out the type checker-  either fail print . runM . runExceptT . runJudgeT $ do-    x ← fresh-    checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit))--  print . runM $ do-    mm ← appTm-    mmStr ← toString mm-    mmStr' ← toString $ eval mm-    return $ mmStr ++ " ~>* " ++ mmStr'--doMap ∷ FilePath → IOSArrow XmlTree TiledMap-doMap mapPath = proc m → do-    mapWidth       ← getAttrR "width"      ⤙ m-    returnA -< baz---- ^ An opaque ESD handle for recording data from the soundcard via ESD.-data Recorder fr ch (r ∷ ★ → ★)-    = Recorder {-        reRate   ∷ !Int-      , reHandle ∷ !Handle-      , reCloseH ∷ !(FinalizerHandle r)-      }---- from ghc-prim---- | A backward-compatible (pre-GHC 8.0) synonym for 'Type'-type * = TYPE 'PtrRepLifted---- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type'-type ★ = TYPE 'PtrRepLifted

@@ -1,176 +0,0 @@-{-|-Module      : Servant.GitHub.Webhook-Description : Easily write safe GitHub webhook handlers with Servant-Copyright   : (c) Jacob Thomas Errington, 2016-License     : MIT-Maintainer  : servant-github-webhook@mail.jerrington.me-Stability   : experimental--The GitHub webhook machinery will attach three headers to the HTTP requests-that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@.-The former two headers correspond with the 'GitHubEvent' and-'GitHubSignedReqBody''' routing combinators. This library ignores the-@X-Github-Delivery@ header; if you would like to access its value, then use the-builtin 'Header' combinator from Servant.--Usage of the library is straightforward: protect routes with the 'GitHubEvent'-combinator to ensure that the route is only reached for specific-'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write-under that route with 'GitHubSignedReqBody'. It is advised to always include a-'GitHubSignedReqBody''', as this is the only way you can be sure that it is-GitHub who is sending the request, and not a malicious user. If you don't care-about the request body, then simply use Aeson\'s 'Object' type as the-deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and-ignore the @Object@ in the handler.--The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in-order to extract the signing key. This is the same key that must be entered in-the configuration of the webhook on GitHub. See 'GitHubKey'' for more details.--In order to support multiple keys on a per-route basis, the basic combinator-@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this,-create a datatype, e.g. @KeyIndex@ whose constructors identify the different-keys you will be using. Generally, this means one constructor per repository.-Use the @DataKinds@ extension to promote this datatype to a kind, and write an-instance of 'Reflect' for each promoted constructor of your datatype. Finally,-create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is-the datatype you've built up. Thus, your function can determine which key to-retrieve.--}--{-# LANGUAGE CPP #-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}---- GHC 8 seems to have improved its decidability check for type family--- instances and class instances. In particular, without UndecidableInstances--- enabled, the Demote' instance for lists, which we need, will not compile.--- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol,--- won't compile on GHC < 8 because the instance head is no smaller than the--- instance head.-#if __GLASGOW_HASKELL__ < 800-{-# LANGUAGE UndecidableInstances #-}-#endif--module Servant.GitHub.Webhook-( -- * Servant combinators-  GitHubSignedReqBody''-, GitHubSignedReqBody'-, GitHubSignedReqBody-, GitHubEvent--  -- ** Security-, GitHubKey'(..)-, GitHubKey-, gitHubKey--  -- * Reexports-  ---  -- | We reexport a few datatypes that are typically needed to use the-  -- library.-, RepoWebhookEvent(..)-, KProxy(..)--  -- * Implementation details--  -- ** Type-level programming machinery-, Demote-, Demote'-, Reflect(..)--  -- ** Stringy stuff-, parseHeaderMaybe-, matchEvent--  -- * Examples-  ---  -- $example1-  ---  -- $example2-) where--import Control.Monad.IO.Class ( liftIO )-import Data.Aeson ( decode', encode )-import qualified Data.ByteString as BS-import Data.ByteString.Lazy ( fromStrict, toStrict )-import qualified Data.ByteString.Base16 as B16-import Data.HMAC ( hmac_sha1 )-import Data.List ( intercalate )-import Data.Maybe ( catMaybes, fromMaybe )-import Data.Monoid ( (<>) )-import Data.Proxy-import Data.String.Conversions ( cs )-import qualified Data.Text.Encoding as E-import GHC.TypeLits-import GitHub.Data.Webhooks-import Network.HTTP.Types hiding (Header, ResponseHeaders)-import Network.Wai ( requestHeaders, strictRequestBody )-import Servant-import Servant.API.ContentTypes ( AllCTUnrender(..) )-import Servant.Server.Internal----- | A clone of Servant's 'ReqBody' combinator, except that it will also--- verify the signature provided by GitHub in the @X-Hub-Signature@ header by--- computing the SHA1 HMAC of the request body and comparing.------ The use of this combinator will require that the router context contain an--- appropriate 'GitHubKey'' entry. Specifically, the type parameter of--- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the--- index @key@ used here. Consequently, it will be necessary to use--- 'serveWithContext' instead of 'serve'.------ Other routes are not tried upon the failure of this combinator, and a 401--- response is generated.------ Use of this datatype directly is discouraged, since the choice of the index--- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use--- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just--- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for--- the implementation of the 'HasServer' instance for the datatype.-data GitHubSignedReqBody''-  (proxy :: KProxy k)-  (key :: k)-  (list :: [*])-  (result :: *) where---- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first--- type argument given just the second one.------ Use this type synonym if you are creating a webhook server to handle--- webhooks from multiple repositories, with different secret keys.-type GitHubSignedReqBody' (key :: k)-  = GitHubSignedReqBody'' ('KProxy :: KProxy k) key---- | A convenient alias for a trivial key index.------ USe this type synonym if you are creating a webhook server to handle only--- webhooks from a single repository, or for mutliple repositories using the--- same secret key.-type GitHubSignedReqBody = GitHubSignedReqBody' '()---- | A routing combinator that succeeds only for a webhook request that matches--- one of the given 'RepoWebhookEvent' given in the type-level list @events@.------ If the list contains 'WebhookWildcardEvent', then all events will be--- matched.------ The combinator will require that its associated handler take a--- 'RepoWebhookEvent' parameter, and the matched event will be passed to the--- handler. This allows the handler to determine which event triggered it from--- the list.------ Other routes are tried if there is a mismatch.-data GitHubEvent (events :: [RepoWebhookEvent]) where-

@@ -1,311 +0,0 @@-{-# 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

@@ -1,341 +0,0 @@-{- 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

@@ -1,9 +0,0 @@-{-# 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

@@ -1,50 +0,0 @@--- 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))

@@ -1,41 +0,0 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude,-             RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators,-             UndecidableInstances #-}--module TensorTests (tensorTests) where--import Apply.Cyc-import Tests-import Utils--import TestTypes--import Crypto.Lol-import Crypto.Lol.CRTrans-import Crypto.Lol.Cyclotomic.Tensor-import Crypto.Lol.Types--import Control.Applicative--import Data.Maybe--import Data.Singletons-import Data.Promotion.Prelude.Eq-import Data.Singletons.TypeRepStar ()--import qualified Test.Framework as TF--type TMRParams = ( '(,) <$> Tensors) <*> MRCombos-tmrParams :: Proxy TMRParams-tmrParams = Proxy----type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos-type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos-tremParams :: Proxy TrEmParams-tremParams = Proxy--type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos)--data Liftable :: TyFun (Factored, *) Bool -> *-type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq)-

@@ -0,0 +1,145 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Arith where++data E a b = E (a -> b) (b -> a)++eqRefl :: E a a+eqRefl = E id id++-- just to construct unique strings+data W+data M a++-- terms+data Var a where+  VarW :: Var W+  VarM :: Var (M a)++-- expose s in the type level making sure it is a string+data Abs s e1  where+  Abs :: (Var s) -> e1 -> Abs (Var s) e1++data App e1 e2 = App e1 e2+data Lit       = Lit++data TyBase      = TyBase+data TyArr t1 t2 = TyArr t1 t2++-- (x:ty) in G+data IN g p where+  INOne :: IN (g,(x,ty)) (x,ty)+  INShift :: IN g0 (x,ty) -> IN (g0,a) (x,ty)++data INEX g x where+  INEX :: IN g (x,v) -> INEX g x+++-- G1 subseteq G2+type SUP g1 g2 = forall a. IN g1 a -> IN g2 a++-- typing derivations+data DER g a ty where+  DVar :: IN (g,g0) ((Var a),ty) -> DER (g,g0) (Var a) ty -- the g,g0 makes sure that env is non-empty+  DApp :: DER g a1 (TyArr ty1 ty2) ->+            DER g a2 ty1 -> DER g (App a1 a2) ty2+  DAbs :: DER (g,(Var a,ty1)) e ty2 ->+            DER g (Abs (Var a) e) (TyArr ty1 ty2)+  DLit :: DER g Lit TyBase++-- G |- \x.x : a -> a+test1 :: DER g (Abs (Var W) (Var W)) (TyArr ty ty)+test1 = DAbs (DVar INOne)++-- G |- (\x.x) Lit : Lit+test2 :: DER g (App (Abs (Var W) (Var W)) Lit) TyBase+test2 = DApp (DAbs (DVar INOne)) DLit++-- G |- \x.\y. x y : (C -> C) -> C -> C+test3 :: DER g (Abs (Var W) (Abs (Var (M W)) (App (Var W) (Var (M W))))) (TyArr (TyArr ty ty) (TyArr ty ty))+test3 = DAbs (DAbs (DApp (DVar (INShift INOne)) (DVar INOne)))++data ISVAL e where+ ISVALAbs :: ISVAL (Abs (Var v) e)+ ISVALLit :: ISVAL Lit++data React e1 e2 where+  SUBSTReact :: React (Abs (Var y) e) v++-- evaluation+data EDER e1 e2 where+ -- EVar    :: IN (a,val) -> ISVAL val -> EDER c a val+ EApp1   :: EDER e1 e1' -> EDER (App e1 e2) (App e1' e2)+ EApp2   :: ISVAL v1 -> EDER e2 e2' -> EDER (App v1 e2) (App v1 e2')+ EAppAbs :: ISVAL v2 -> React (Abs (Var v) e) v2 -> EDER (App (Abs (Var v) e) v2) e1++-- (\x.x) 3 -> 3+-- test4 :: EDER (App (Abs (Var W) (Var W)) Lit) Lit+-- test4 = EAppAbs ISVALLit SUBSTEqVar+++-- existential+data REDUCES e1 where+   REDUCES :: EDER e1 e2 -> REDUCES e1++-- data WFEnv x c g  where+--  WFOne ::  ISVAL v -> DER g v ty -> WFEnv (Var x) (c,(Var x,v)) (g,(Var x,ty))+--  WFShift :: WFEnv v c0 g0 -> WFEnv v (c0,(y,y1)) (g0,(z,z1))++-- data WFENVWRAP c g where+--    WFENVWRAP :: (forall v ty . IN g (v,ty) -> WFEnv v c g) -> WFENVWRAP c g+++-- data INEXVAL c x where+--   INEXVAL :: IN c (x,v) -> ISVAL v -> INEXVAL c x++-- -- the first cool theorem!+-- fromTEnvToEnv :: IN g (x,ty) -> WFEnv x c g ->  INEXVAL c x+-- fromTEnvToEnv INOne (WFOne isv _)  = INEXVAL INOne isv+-- fromTEnvToEnv (INShift ind1) (WFShift ind2) =+--           case (fromTEnvToEnv ind1 ind2) of+--              INEXVAL i isv -> INEXVAL (INShift i) isv+++data ISLAMBDA v where ISLAMBDA :: ISLAMBDA (Abs (Var x) e)+data ISLIT v where ISLIT :: ISLIT Lit++data EXISTAbs where+  EXISTSAbs :: (Abs (Var x) e) -> EXISTAbs++bot = bot++canFormsLam :: ISVAL v -> DER g v (TyArr ty1 ty2) -> ISLAMBDA v+canFormsLam ISVALAbs _ = ISLAMBDA+-- canFormsLam ISVALLit _ = bot         <== unfortunately I cannot catch this ... requires some exhaustiveness check :-(++canFormsLit :: ISVAL v -> DER g v TyBase -> ISLIT v+canFormsLit ISVALLit _ = ISLIT++data NULL++progress :: DER NULL e ty -> Either (ISVAL e) (REDUCES e)++progress (DAbs prem)  = Left ISVALAbs+progress (DLit)       = Left ISVALLit+-- progress (DVar iw)    = bot             <== here is the cool trick! I cannot even wite this down!+progress (DApp e1 e2)  =+     case (progress e1) of+         Right (REDUCES r1) -> Right (REDUCES (EApp1 r1))+         Left  isv1         -> case (progress e2) of+                                    Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2))+                                    Left isv2 -> case (canFormsLam isv1 e1) of+                                                    ISLAMBDA -> Right (REDUCES (EAppAbs isv2 SUBSTReact))+++--    case fromTEnvToEnv iw (f iw) of+--      INEXVAL i isv -> Right (REDUCES (EVar i isv))+-- progress (WFENVWRAP f) (DApp e1 e2) =+--       case (progress (WFENVWRAP f) e1) of+--          Right (REDUCES r1) -> Right (REDUCES (EApp1 r1))+--          Left  isv1         -> case (progress (WFENVWRAP f) e2) of+--                                  Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2))+--                                  Left isv2 -> case (canFormsLam isv1 e1) of+--                                                ISLAMBDA -> EAppAbs isv2 e1+

@@ -0,0 +1,9 @@+{-# LANGUAGE TypeInType #-}++module BadTelescope where++import Data.Kind++data SameKind :: k -> k -> Type++data X a k (b :: k) (c :: SameKind a b)

@@ -0,0 +1,14 @@+{-# LANGUAGE TypeInType, ExplicitForAll #-}++module BadTelescope2 where++import Data.Kind+import Data.Proxy++data SameKind :: k -> k -> Type++foo :: forall a k (b :: k). SameKind a b+foo = undefined++bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d+bar = undefined

@@ -0,0 +1,9 @@+{-# LANGUAGE TypeInType, ExplicitForAll #-}++module BadTelescope3 where++import Data.Kind++data SameKind :: k -> k -> Type++type S a k (b :: k) = SameKind a b

@@ -0,0 +1,13 @@+{-# LANGUAGE ExistentialQuantification, TypeInType #-}+module BadTelescope4 where++import Data.Proxy+import Data.Kind++data SameKind :: k -> k -> Type++data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)++data Borked a (b :: k) = forall (c :: k). B (Proxy c)+  -- this last one is OK. But there was a bug involving renaming+  -- that failed here, so the test case remains.

@@ -0,0 +1,7 @@+{-# LANGUAGE RankNTypes #-}+module Boot where++import A++data Data = forall n. Class n => D n+

@@ -0,0 +1,26 @@+{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-}++module Dep3 where++import Data.Kind+import GHC.Exts ( Constraint )++type Star1 = Type++data Id1 (a :: Star1) where+  Id1 :: a -> Id1 a++data Id1' :: Star1 -> Type where+  Id1' :: a -> Id1' a++type family Star2 x where+  Star2 x = Type++data Id2a (a :: Star2 Constraint) = Id2a a+++data Id2 (a :: Star2 Constraint) where+  Id2 :: a -> Id2 a++data Id2' :: Star2 Constraint -> Type where+  Id2' :: a -> Id2' a

@@ -0,0 +1,22 @@+{-# LANGUAGE RankNTypes #-}++data Empty+data NonEmpty++data SafeList x y where+     Nil :: SafeList x Empty+     Cons:: Eq x => x -> SafeList x y  -> SafeList x NonEmpty+     One :: Eq x => x -> SafeList x Empty -> SafeList x NonEmpty++safeHead :: SafeList x NonEmpty -> x+safeHead (Cons x _) = x++foo = Cons 3 (Cons 6 (Cons 9 Nil))+++data Dict x where+        DictN :: Num x => x -> Dict x+        DictE :: Eq x =>  x -> Dict x++data Exist where+        Exist :: forall a. a -> Exist

@@ -0,0 +1,341 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.HashTable+-- Copyright   :  (c) The University of Glasgow 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- An implementation of extensible hash tables, as described in+-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,+-- pp. 446--457.  The implementation is also derived from the one+-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).+--+-----------------------------------------------------------------------------++module Data.HashTab (+        -- * Basic hash table operations+        HashTable, new, insert, delete, lookup, update,+        -- * Converting to and from lists+        fromList, toList,+        -- * Hash functions+        -- $hash_functions+        hashInt, hashString,+        prime,+        -- * Diagnostics+        longestChain+ ) where++-- This module is imported by Data.Typeable, which is pretty low down in the+-- module hierarchy, so don't import "high-level" modules++-- Right now we import high-level modules with gay abandon.+import Prelude  hiding  ( lookup )+import Data.Tuple       ( fst )+import Data.Bits+import Data.Maybe+import Data.List        ( maximumBy, partition, concat, foldl )+import Data.Int         ( Int32 )++import Data.Array.Base+import Data.Array       hiding (bounds)+import Data.Array.IO++import Data.Char        ( ord )+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )+import Control.Monad    ( mapM, sequence_ )+++-----------------------------------------------------------------------++readHTArray  :: HTArray a -> Int32 -> IO a+readMutArray  :: MutArray a -> Int32 -> IO a+writeMutArray :: MutArray a -> Int32 -> a -> IO ()+freezeArray  :: MutArray a -> IO (HTArray a)+thawArray    :: HTArray a -> IO (MutArray a)+newMutArray   :: (Int32, Int32) -> a -> IO (MutArray a)+#if defined(DEBUG) || defined(__NHC__)+type MutArray a = IOArray Int32 a+type HTArray a = MutArray a+newMutArray = newArray+readHTArray  = readArray+readMutArray = readArray+writeMutArray = writeArray+freezeArray = return+thawArray = return+#else+type MutArray a = IOArray Int32 a+type HTArray a = Array Int32 a+newMutArray = newArray+readHTArray arr i = return $! (unsafeAt arr (fromIntegral i))+readMutArray arr i = unsafeRead arr (fromIntegral i)+writeMutArray arr i x = unsafeWrite arr (fromIntegral i) x+freezeArray = unsafeFreeze+thawArray = unsafeThaw+#endif++newtype HashTable key val = HashTable (IORef (HT key val))+-- TODO: the IORef should really be an MVar.++data HT key val+  = HT {+        kcount  :: !Int32,              -- Total number of keys.+        buckets :: !(HTArray [(key,val)]),+        bmask   :: !Int32,+        hash_fn :: key -> Int32,+        cmp     :: key -> key -> Bool+   }++-- -----------------------------------------------------------------------------+-- Sample hash functions++-- $hash_functions+--+-- This implementation of hash tables uses the low-order /n/ bits of the hash+-- value for a key, where /n/ varies as the hash table grows.  A good hash+-- function therefore will give an even distribution regardless of /n/.+--+-- If your keyspace is integrals such that the low-order bits between+-- keys are highly variable, then you could get away with using 'id'+-- as the hash function.+--+-- We provide some sample hash functions for 'Int' and 'String' below.++-- | A sample hash function for 'Int', implemented as simply @(x `mod` P)@+-- where P is a suitable prime (currently 1500007).  Should give+-- reasonable results for most distributions of 'Int' values, except+-- when the keys are all multiples of the prime!+--+hashInt :: Int -> Int32+hashInt = (`rem` prime) . fromIntegral++-- | A sample hash function for 'String's.  The implementation is:+--+-- >    hashString = fromIntegral . foldr f 0+-- >      where f c m = ord c + (m * 128) `rem` 1500007+--+-- which seems to give reasonable results.+--+hashString :: String -> Int32+hashString = fromIntegral . foldl f 0+  where f m c = ord c + (m * 128) `rem` fromIntegral prime++-- | A prime larger than the maximum hash table size+prime :: Int32+prime = 1500007++-- -----------------------------------------------------------------------------+-- Parameters++tABLE_MAX  = 1024 * 1024 :: Int32  -- Maximum size of hash table+#if tABLE_MIN+#else+tABLE_MIN  = 16 :: Int32++hLOAD = 4 :: Int32 -- Maximum average load of a single hash bucket++hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation+#endif++{- Hysteresis favors long association-list-like behavior for small tables. -}++-- -----------------------------------------------------------------------------+-- Creating a new hash table++-- | Creates a new hash table.  The following property should hold for the @eq@+-- and @hash@ functions passed to 'new':+--+-- >   eq A B  =>  hash A == hash B+--+new+  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys+  -> (key -> Int32)          -- ^ @hash@: A hash function on keys+  -> IO (HashTable key val)  -- ^ Returns: an empty hash table++new cmpr hash = do+  -- make a new hash table with a single, empty, segment+  let mask = tABLE_MIN-1+  bkts'  <- newMutArray (0,mask) []+  bkts   <- freezeArray bkts'++  let+    kcnt = 0+    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask,+               hash_fn=hash, cmp=cmpr }++  table <- newIORef ht+  return (HashTable table)++-- -----------------------------------------------------------------------------+-- Inserting a key\/value pair into the hash table++-- | Inserts a key\/value mapping into the hash table.+--+-- Note that 'insert' doesn't remove the old entry from the table -+-- the behaviour is like an association list, where 'lookup' returns+-- the most-recently-inserted mapping for a key in the table.  The+-- reason for this is to keep 'insert' as efficient as possible.  If+-- you need to update a mapping, then we provide 'update'.+--+insert :: HashTable key val -> key -> val -> IO ()++insert (HashTable ref) key val = do+  table@HT{ kcount=k, buckets=bkts, bmask=b } <- readIORef ref+  let table1 = table{ kcount = k+1 }+      indx = bucketIndex table key+  bucket <- readHTArray bkts indx+  bkts' <- thawArray bkts+  writeMutArray bkts' indx ((key,val):bucket)+  freezeArray bkts'+  table2 <-+        if tooBig k b+           then expandHashTable table1+           else return table1+  writeIORef ref table2++tooBig :: Int32 -> Int32 -> Bool+tooBig k b = k-hYSTERESIS > hLOAD * b++bucketIndex :: HT key val -> key -> Int32+bucketIndex HT{ hash_fn=hash, bmask=mask } key =+  let h = hash key+  in  (h .&. mask)++expandHashTable :: HT key val -> IO (HT key val)+expandHashTable+      table@HT{ buckets=bkts, bmask=mask } = do+   let+      oldsize = mask + 1+      newmask = mask + mask + 1+      newsize = newmask + 1+   --+   if newsize > tABLE_MAX+      then return table+      else do+   --+   newbkts' <- newMutArray (0,newmask) []++   let+    table'=table{ bmask=newmask }+    splitBucket oldindex = do+      bucket <- readHTArray bkts oldindex+      let (oldb,newb) = partition ((oldindex==).bucketIndex table' . fst) bucket+      writeMutArray newbkts' oldindex oldb+      writeMutArray newbkts' (oldindex + oldsize) newb+   mapM_ splitBucket [0..mask]++   newbkts <- freezeArray newbkts'++   return ( table'{ buckets=newbkts } )++-- -----------------------------------------------------------------------------+-- Deleting a mapping from the hash table++-- Remove a key from a bucket+deleteBucket :: (key -> Bool) -> [(key,val)] -> (Int32, [(key, val)])+deleteBucket _   [] = (0,[])+deleteBucket del (pair@(k,_):bucket) =+  case deleteBucket del bucket of+    (dels, bucket') | del k     -> dels' `seq` (dels', bucket')+                    | otherwise -> (dels, pair:bucket')+      where dels' = dels + 1++-- | Remove an entry from the hash table.+delete :: HashTable key val -> key -> IO ()++delete (HashTable ref) key = do+  table@HT{ buckets=bkts, kcount=kcnt, cmp=cmpr } <- readIORef ref+  let indx = bucketIndex table key+  bkts' <- thawArray bkts+  bucket <- readMutArray bkts' indx+  let (removed,bucket') = deleteBucket (cmpr key) bucket+  writeMutArray bkts' indx bucket'+  freezeArray bkts'+  writeIORef ref ( table{kcount = kcnt - removed} )++-- -----------------------------------------------------------------------------+-- Updating a mapping in the hash table++-- | Updates an entry in the hash table, returning 'True' if there was+-- already an entry for this key, or 'False' otherwise.  After 'update'+-- there will always be exactly one entry for the given key in the table.+--+-- 'insert' is more efficient than 'update' if you don't care about+-- multiple entries, or you know for sure that multiple entries can't+-- occur.  However, 'update' is more efficient than 'delete' followed+-- by 'insert'.+update :: HashTable key val -> key -> val -> IO Bool++update (HashTable ref) key val = do+  table@HT{ kcount=k, buckets=bkts, cmp=cmpr, bmask=b } <- readIORef ref+  let indx = bucketIndex table key+  bkts' <- thawArray bkts+  bucket <- readMutArray bkts' indx+  let (deleted,bucket') = deleteBucket (cmpr key) bucket+      k' = k + 1 - deleted+      table1 = table{ kcount=k' }++  writeMutArray bkts' indx ((key,val):bucket')+  freezeArray bkts'+  table2 <-+        if tooBig k' b          -- off by one from insert's resize heuristic.+           then expandHashTable table1+           else return table1+  writeIORef ref table2+  return (deleted>0)++-- -----------------------------------------------------------------------------+-- Looking up an entry in the hash table++-- | Looks up the value of a key in the hash table.+lookup :: HashTable key val -> key -> IO (Maybe val)++lookup (HashTable ref) key = do+  table@HT{ buckets=bkts, cmp=cmpr } <- readIORef ref+  let indx = bucketIndex table key+  bucket <- readHTArray bkts indx+  case [ val | (key',val) <- bucket, cmpr key key' ] of+        [] -> return Nothing+        (v:_) -> return (Just v)++-- -----------------------------------------------------------------------------+-- Converting to/from lists++-- | Convert a list of key\/value pairs into a hash table.  Equality on keys+-- is taken from the Eq instance for the key type.+--+fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)+fromList hash list = do+  table <- new (==) hash+  sequence_ [ insert table k v | (k,v) <- list ]+  return table++-- | Converts a hash table to a list of key\/value pairs.+--+toList :: (Ord key, Ord val) => HashTable key val -> IO [(key,val)]+toList (HashTable ref) = do+  HT{ buckets=bkts, bmask=b } <- readIORef ref+  fmap concat (mapM (readHTArray bkts) [0..b])++-- -----------------------------------------------------------------------------+-- Diagnostics++-- | This function is useful for determining whether your hash function+-- is working well for your data set.  It returns the longest chain+-- of key\/value pairs in the hash table for which all the keys hash to+-- the same bucket.  If this chain is particularly long (say, longer+-- than 10 elements), then it might be a good idea to try a different+-- hash function.+--+longestChain :: HashTable key val -> IO [(key,val)]+longestChain (HashTable ref) = do+  HT{ buckets=bkts, bmask=b } <- readIORef ref+  let lengthCmp (_:x)(_:y) = lengthCmp x y+      lengthCmp []   []    = EQ+      lengthCmp []   _     = LT+      lengthCmp _    []    = GT+  fmap (maximumBy lengthCmp) (mapM (readHTArray bkts) [0..b])+

@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll,+             TemplateHaskell, UndecidableInstances, ScopedTypeVariables,+             TypeInType #-}++module KindEqualities2 where++import Data.Kind+import GHC.Exts ( Any )++data Kind = Star | Arr Kind Kind++data Ty :: Kind -> Type where+  TInt :: Ty Star+  TBool :: Ty Star+  TMaybe :: Ty (Arr Star Star)+  TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2+++data TyRep (k :: Kind) (t :: Ty k) where+  TyInt :: TyRep Star TInt+  TyBool :: TyRep Star TBool+  TyMaybe :: TyRep (Arr Star Star) TMaybe+  TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b)++type family IK (k :: Kind)+type instance IK Star = Type+type instance IK (Arr k1 k2) = IK k1 -> IK k2++$(return [])  -- necessary because the following instances depend on the+              -- previous ones.++type family I (t :: Ty k) :: IK k+type instance I TInt = Int+type instance I TBool = Bool+type instance I TMaybe = Maybe+type instance I (TApp a b) = (I a) (I b)++zero :: forall (a :: Ty 'Star). TyRep Star a -> I a+zero TyInt = 0+zero TyBool = False+zero (TyApp TyMaybe TyInt) = Nothing++main = print $ zero (TyApp TyMaybe TyInt)

@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}++give :: b -> Pattern '[b] a+give b = Pattern (const (Just $ oneT b))+++pfail :: Pattern '[] a+pfail = is (const False)++(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a+(/\) = mk2 (\a -> Just (a,a))++data Pattern :: [Type] -> Type where+  Nil :: Pattern '[]+  Cons :: Maybe h -> Pattern t -> Pattern (h ': t)++type Pos = '("vpos", V3 GLfloat)+type Tag = '("tagByte", V1 Word8)++-- | Alias for the 'In' type from the 'Direction' kind, allows users to write+-- the 'BroadcastChan In a' type without enabling DataKinds.+type In = 'In+-- | Alias for the 'Out' type from the 'Direction' kind, allows users to write+-- the 'BroadcastChan Out a' type without enabling DataKinds.+type Out = 'Out

@@ -0,0 +1,166 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC+ -Weverything+ -fno-warn-unsafe+ -fno-warn-implicit-prelude+ -fno-warn-missing-import-lists+ -fno-warn-noncanonical-monoid-instances+ -O2+#-}++module Packed.Bytes.Parser+  ( Parser(..)+  , Result(..)+  , Leftovers(..)+  , parseStreamST+  , any+  , failure+  ) where++import Control.Applicative+import Data.Primitive (ByteArray(..))+import GHC.Int (Int(I#))+import GHC.ST (ST(..),runST)+import GHC.Types (TYPE)+import GHC.Word (Word8(W8#))+import Packed.Bytes (Bytes(..))+import Packed.Bytes.Stream.ST (ByteStream(..))+import Prelude hiding (any,replicate)++import qualified Data.Primitive as PM+import qualified Control.Monad++import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#)++type Bytes# = (# ByteArray#, Int#, Int# #)+type Maybe# (a :: TYPE r) = (# (# #) | a #)+type Leftovers# s = (# Bytes# , ByteStream s #)+type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #)++data Result s a = Result+  { resultLeftovers :: !(Maybe (Leftovers s))+  , resultValue :: !(Maybe a)+  }++data Leftovers s = Leftovers+  { leftoversChunk :: {-# UNPACK #-} !Bytes+    -- ^ The last chunk pulled from the stream+  , leftoversStream :: ByteStream s+    -- ^ The remaining stream+  }++data PureResult a = PureResult+  { pureResultLeftovers :: {-# UNPACK #-} !Bytes+  , pureResultValue :: !(Maybe a)+  } deriving (Show)++emptyByteArray :: ByteArray+emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray)++parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a)+parseStreamST stream (Parser f) = ST $ \s0 ->+  case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of+    (# s1, r #) -> (# s1, boxResult r #)++boxResult :: Result# s a -> Result s a+boxResult (# leftovers, val #) = case val of+  (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing+  (# | a #) -> Result (boxLeftovers leftovers) (Just a)++boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s)+boxLeftovers (# (# #) | #) = Nothing+boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream)++instance Functor Parser where+  fmap = mapParser++-- Remember to write liftA2 by hand at some point.+instance Applicative Parser where+  pure = pureParser+  (<*>) = Control.Monad.ap++instance Monad Parser where+  return = pure+  (>>=) = bindLifted++newtype Parser a = Parser+  { getParser :: forall s.+       Maybe# (Leftovers# s)+    -> State# s+    -> (# State# s, Result# s a #)+  }++nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #)+nextNonEmpty (ByteStream f) s0 = case f s0 of+  (# s1, r #) -> case r of+    (# (# #) | #) -> (# s1, (# (# #) | #) #)+    (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of+      0# -> nextNonEmpty stream s1+      _ -> (# s1, (# | (# theBytes, stream #) #) #)++withNonEmpty :: forall s b.+     Maybe# (Leftovers# s)+  -> State# s+  -> (State# s -> (# State# s, Result# s b #))+  -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #))+     -- The first argument is a Word8, not a full machine word.+     -- The second argument is the complete,non-empty chunk+     -- with the head byte still intact.+  -> (# State# s, Result# s b #)+withNonEmpty (# (# #) | #) s0 g _ = g s0+withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of+  1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0+  _ -> case nextNonEmpty stream0 s0 of+    (# s1, r #) -> case r of+      (# (# #) | #) -> g s1+      (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) ->+        f (indexWord8Array# arr1 off1) bytes1 stream1 s1++-- | Consume the next byte from the input.+any :: Parser Word8+any = Parser go where+  go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #)+  go m s0 = withNonEmpty m s0+    (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #))+    (\theByte theBytes stream s ->+      (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #)+    )++-- TODO: improve this+mapParser :: (a -> b) -> Parser a -> Parser b+mapParser f p = bindLifted p (pureParser . f)++pureParser :: a -> Parser a+pureParser a = Parser $ \leftovers0 s0 ->+  (# s0, (# leftovers0, (# | a #) #) #)++bindLifted :: Parser a -> (a -> Parser b) -> Parser b+bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of+  (# s1, (# leftovers1, val #) #) -> case val of+    (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #)+    (# | x #) -> case g x of+      Parser k -> k leftovers1 s1++-- This assumes that the Bytes is longer than the index. It also does+-- not eliminate zero-length references to byte arrays.+unsafeDrop# :: Int# -> Bytes# -> Bytes#+unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #)++unboxByteArray :: ByteArray -> ByteArray#+unboxByteArray (ByteArray arr) = arr++boxBytes :: Bytes# -> Bytes+boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)++failure :: Parser a+failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #))+

@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds,+             PolyKinds, TypeFamilies, GADTs, TypeInType #-}++module RAE_T32a where++import Data.Kind++data family Sing (k :: Type) :: k -> Type++data TyArr' (a :: Type) (b :: Type) :: Type+type TyArr (a :: Type) (b :: Type) = TyArr' a b -> Type+type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2+data TyPi' (a :: Type) (b :: TyArr a Type) :: Type+type TyPi (a :: Type) (b :: TyArr a Type) = TyPi' a b -> Type+type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b+$(return [])++data MkStar (p :: Type) (x :: TyArr' p Type)+type instance MkStar p @@ x = Type+$(return [])++data Sigma (p :: Type) (r :: TyPi p (MkStar p)) :: Type where+  Sigma ::+    forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a).+    Sing Type p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r+$(return [])++data instance Sing Sigma (Sigma p r) x where+  SSigma ::+    forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a)+    (sp :: Sing Type p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b).+    Sing (Sing (r @@@ a) b) sb ->+    Sing (Sigma p r) ('Sigma sp sr sa sb)++-- I (RAE) believe this last definition is ill-typed.

@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds,+             RankNTypes, TypeOperators, TypeInType #-}++module RAE_T32b where++import Data.Kind++data family Sing (k :: Type) :: k -> Type++data TyArr (a :: Type) (b :: Type) :: Type+type family (a :: TyArr k1 k2 -> Type) @@ (b :: k1) :: k2+$(return [])++data Sigma (p :: Type) (r :: TyArr p Type -> Type) :: Type where+  Sigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a).+           Sing Type p -> Sing (TyArr p Type -> Type) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r+$(return [])++data instance Sing (Sigma p r) (x :: Sigma p r) :: Type where+  SSigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a)+            (sp :: Sing Type p) (sr :: Sing (TyArr p Type -> Type) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b).+            Sing (Sing (r @@ a) b) sb ->+            Sing (Sigma p r) ('Sigma sp sr sa sb)

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds,+             TypeFamilies, TypeInType #-}++module A where++import Data.Kind++data family Sing (k :: Type) :: k -> Type+type Sing' (x :: k) = Sing k x+data TyFun' (a :: Type) (b :: Type) :: Type+type TyFun (a :: Type) (b :: Type) = TyFun' a b -> Type+type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2+data TyPi' (a :: Type) (b :: TyFun a Type) :: Type+type TyPi (a :: Type) (b :: TyFun a Type) = TyPi' a b -> Type+type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b+$(return [])++data A (a :: Type) (b :: a) (c :: TyFun' a Type) -- A :: forall a -> a -> a ~> Type+type instance (@@) (A a b) c = Type+$(return [])+data B (a :: Type) (b :: TyFun' a Type) -- B :: forall a -> a ~> Type+type instance (@@) (B a) b = TyPi a (A a b)+$(return [])+data C (a :: Type) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) Type)

@@ -0,0 +1,63 @@+{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies,+             TypeInType #-}+{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-}++module RaeBlogPost where++import Data.Kind++-- a Proxy type with an explicit kind+data Proxy k (a :: k) = P+prox :: Proxy * Bool+prox = P++prox2 :: Proxy Bool 'True+prox2 = P++-- implicit kinds still work+data A+data B :: A -> Type+data C :: B a -> Type+data D :: C b -> Type+data E :: D c -> Type+-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> Type++-- a kind-indexed GADT+data TypeRep (a :: k) where+  TInt   :: TypeRep Int+  TMaybe :: TypeRep Maybe+  TApp   :: TypeRep a -> TypeRep b -> TypeRep (a b)++zero :: TypeRep a -> a+zero TInt            = 0+zero (TApp TMaybe _) = Nothing++data Nat = Zero | Succ Nat+type family a + b where+  'Zero     + b = b+  ('Succ a) + b = 'Succ (a + b)++data Vec :: Type -> Nat -> Type where+  Nil  :: Vec a 'Zero+  (:>) :: a -> Vec a n -> Vec a ('Succ n)+infixr 5 :>++-- promoted GADT, and using + as a "kind family":+type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where+  'Nil      ++ y = y+  (h ':> t) ++ y = h ':> (t ++ y)++-- datatype that mentions Type+data U = Star (Type)+       | Bool Bool++-- kind synonym+type Monadish = Type -> Type+class MonadTrans (t :: Monadish -> Monadish) where+  lift :: Monad m => m a -> t m a+data Free :: Monadish where+  Return :: a -> Free a+  Bind   :: Free a -> (a -> Free b) -> Free b++-- yes, Type really does have type Type.+type Star = (Type :: (Type :: (Type :: Type)))

@@ -0,0 +1,5 @@+{-# LANGUAGE TypeInType #-}++module RenamingStar where++data Foo :: Type

@@ -0,0 +1,62 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}++{-# OPTIONS_GHC -O2 #-}++module Packed.Bytes.Stream.ST+  ( ByteStream(..)+  , empty+  , unpack+  , fromBytes+  ) where++import Data.Primitive (Array,ByteArray(..))+import Data.Semigroup (Semigroup)+import Data.Word (Word8)+import GHC.Exts (RealWorld,State#,Int#,ByteArray#)+import GHC.Int (Int(I#))+import GHC.ST (ST(..))+import Packed.Bytes (Bytes(..))+import System.IO (Handle)+import qualified Data.Primitive as PM+import qualified Data.Semigroup as SG+import qualified Packed.Bytes as B++type Bytes# = (# ByteArray#, Int#, Int# #)++newtype ByteStream s = ByteStream+  (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) )++fromBytes :: Bytes -> ByteStream s+fromBytes b = ByteStream+  (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #))++nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s))+nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of+  (# s1, r #) -> case r of+    (# (# #) | #) -> (# s1, Nothing #)+    (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #)++empty :: ByteStream s+empty = ByteStream (\s -> (# s, (# (# #) | #) #) )++boxBytes :: Bytes# -> Bytes+boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)++unboxBytes :: Bytes -> Bytes#+unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #)++unpack :: ByteStream s -> ST s [Word8]+unpack stream = ST (unpackInternal stream)++unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #)+unpackInternal (ByteStream f) s0 = case f s0 of+  (# s1, r #) -> case r of+    (# (# #) | #) -> (# s1, [] #)+    (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of+      (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #)+

@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE TypeFamilies        #-}+++type ( f :->   g) (r :: Type -> Type) ix = f r ix -> g r ix++type ( f :-->  g)  b ix = f b ix -> g b ix++type ((f :---> g)) b ix = f b ix -> g b ix

@@ -0,0 +1,11 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module T10134a where++import GHC.TypeLits++data Vec :: Nat -> Type -> Type where+  Nil  :: Vec 0 a+  (:>) :: a -> Vec n a -> Vec (n + 1) a

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+module T10279 where+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- NB: rts-1.0 is used here because it doesn't change.+-- You do need to pick the right version number, otherwise the+-- error message doesn't recognize it as a source package ID,+-- (This is OK,  since it will look obviously wrong when they+-- try to find the package in their package database.)+blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A"))))+

@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++module T10321 where++import GHC.TypeLits++data Vec :: Nat -> Type -> Type where+  Nil  :: Vec 0 a+  (:>) :: a -> Vec n a -> Vec (n + 1) a++infixr 5 :>

@@ -0,0 +1,33 @@+{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import GHC.Exts++{-+   the prim and javascript calling conventions do not support+   headers and the static keyword.+-}++-- check that quasiquoting roundtrips successfully and that the declaration+-- does not include the static keyword+test1 :: String+test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <-+               [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |]+             addTopDecls ds+             case p of+              "test1" -> return (LitE . stringL $ p)+              _       -> error $ "unexpected value: " ++ show p+         )++-- check that constructed prim imports with the static keyword are rejected+test2 :: String+test2 = $(do t <- [t| Int# -> Int# |]+             cmm_test2 <- newName "cmm_test2"+             addTopDecls+               [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)]+             [| test1 |]+         )+

@@ -0,0 +1,115 @@+{-# LANGUAGE TypeOperators+           , DataKinds+           , PolyKinds+           , TypeFamilies+           , GADTs+           , UndecidableInstances+           , RankNTypes+           , ScopedTypeVariables+  #-}++{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Werror #-}+{-# OPTIONS_GHC -O1 -fspec-constr #-}++{-+ghc-stage2: panic! (the 'impossible' happened)+  (GHC version 7.11.20150723 for x86_64-unknown-linux):+        Template variable unbound in rewrite rule+-}++module List (sFoldr1) where++data Proxy t++data family Sing (a :: k)++data TyFun (a :: Type) (b :: Type)++type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2++data instance Sing (f :: TyFun k1 k2 -> Type) =+  SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) }++type SingFunction1 f = forall t. Sing t -> Sing (Apply f t)++type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t)+singFun2 :: Proxy f -> SingFunction2 f -> Sing f+singFun2 _ f = SLambda (\x -> SLambda (f x))++data (:$$) (j :: a) (i :: TyFun [a] [a])+type instance Apply ((:$$) j) i = (:) j i++data (:$) (l :: TyFun a (TyFun [a] [a] -> Type))+type instance Apply (:$) l = (:$$) l+data instance Sing (z :: [a])+  = z ~ '[] =>+    SNil+  | forall (m :: a)+           (n :: [a]). z ~ (:) m n =>+    SCons (Sing m) (Sing n)++data ErrorSym0 (t1 :: TyFun k1 k2)++type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh++type Let1627448493Xs f_afe9+                     x_afea+                     wild_1627448474_afeb+                     wild_1627448476_afec =+    Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec+type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)+                           -> Type)+                (t_afdZ :: [a_afdP]) =+    Foldr1 t_afdY t_afdZ+data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)+                           -> Type)+                (l_afe2 :: TyFun [a_afdP] a_afdP)+type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2++data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP+                                                -> Type)+                                  -> Type) (TyFun [a_afdP] a_afdP -> Type))+type instance Apply Foldr1Sym0 l = Foldr1Sym1 l++type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP+                                            -> Type)+                              -> Type)+                   (a_afe6 :: [a_afdP]) :: a_afdP where+  Foldr1 z_afe7 '[x_afe8] = x_afe8+  Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec))+  Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list"++sFoldr1 ::+  forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type)+         (y :: [a_afdP]).+  Sing x+  -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y)+sFoldr1 _ (SCons _sX SNil) = undefined+sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476))+  = let+      lambda_afeC ::+        forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec.+        Sing f_afe9+        -> Sing x_afea+           -> Sing wild_1627448474_afeb+              -> Sing wild_1627448476_afec+                 -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec)))+      lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG+        = let+            sXs ::+              Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)+            sXs+              = applySing+                  (applySing+                     (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF)+                  wild_1627448476_afeG+          in+            applySing+              (applySing f_afeD x_afeE)+              (applySing+                 (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD)+                 sXs)+    in lambda_afeC sF sX sWild_1627448474 sWild_1627448476+sFoldr1 _ SNil = undefined+