packages feed

ghc-exactprint 0.5.8.2 → 1.14.0.0

raw patch · 2213 files changed

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

ChangeLog view
@@ -1,3 +1,79 @@+2025-10-14 v1.14.0.0+	* Support GHC 9.14.1+2025-01-21 v1.12.0.0+	* Harmonise layout processing so we do not have a special case for+	the top level This is a breaking change, in that the hand-crafted+	different line deltas will have to have 1 subtracted from the+	column.+2024-12-06 v1.11.0.0+	* Support GHC 9.12.1 (rc1)+2024-05-21 v1.10.0.0+	* Make the Language.Haskell.GHC.ExactPrint.Transform API pure+	* Remove EPOoptions fields that had no effect+2024-05-16 v1.9.0.0+	* Support GHC 9.10.1+2022-12-19 v1.8.0.0+	* Support GHC 9.8.1+2022-12-19 v1.7.1.0+	* Add CI for GHC 9.6.3+	* Reinstate MonadTrans on TransFormT (via @Vekhir)+2022-11-08 v1.7.0.1+	* Add CI for GHC 9.6.2+	* Correctly deal with comments when using GHC flag -haddock+2022-11-08 v1.7+	* Support GHC 9.6.1+2022-11-08 v1.6.1+	* Add GHC 9.4.4 to CI+	* Add support for exact printing HsDocTy. #121+2022-11-08 v1.6.1+	* Support GHC 9.4.3+2022-09-30 v1.6.0+	* Support GHC 9.4.1 and GHC 9.4.2+2022-02-01 v1.5.0+	* Add private version of showAstData, to be able to render+	AnchorOperation's hacked into SrcSpan's.+	* Change the starting top level margin from 0 to 1. This means we+	can use (DifferentLine n 0) everywhere with the same meaning, not+	needing (DifferentLine n 1) at the top level. Hence 1.5 bump.+2022-01-03 v1.4.1+	* Fix delta-in of open/close parentheses in AnnContext (@pepeiborra)+2022-01-03 v1.4.0.1+	* Add haddock docs to makeDeltaAst+2022-01-03 v1.4+	* Fix handling of AnnContext (@pepeiborra)+	* Fix crashy bogus instances (@pepeiborra)+	* Remove head.hackage overlay from cabal project file+2021-11-23 v1.3+	* Update for GHC 9.2.1 as released+	* Introduce makeDeltaAst command to convert all EpaSpan's to equivalent EpaDelta versions+2021-08-23 v1.2+	* Remove types and functions from previous version, now obsolete+2021-08-23 v1.1+	* Add support for GHC 9.2 rc1, and this version drops support for+	prior GHC versions.+2021-02-24 v0.6.4+	* Add support for GHC 9.0.1+2021-02-01 v0.6.3.4+	* Use env var to get ghc libdir by @jneira+2020-11-11 v0.6.3.3+	* Sort comments properly, ignoring SrcSpan's file by @zliu41+2020-07-16 v0.6.3.2+	* Add support for GHC 8.8.4+2020-06-13 v0.6.3.1+	* Always print "=>" in ConDecl (for GHC >= 8.6) by @zliu41+2020-03-26 v0.6.3+        * Support GHC 8.8.1, 8.8.2, 8.8.3, 8.10.1+2019-08-28 v0.6.2+        * Support GHC 8.8.1 (release candidate)+2019-05-27 v0.6.1+        * Support GHC 8.8 (alpha1)+2019-03-01 v0.6+        * Remove orphan MonadFail Identity instance+	* MonadFail TransformT instance is defined unconditionally+	* Generalise HasTransform (TransformT Identity) to+	Monad m => HasTransform (TransformT m)+	* Add hoistTransform function+  The 0.6 changes are all thanks to @phadej 2018-10-27 v0.5.8.2 	* Support GHC 8.4.4 by selecting correct source directory 2018-09-23 v0.5.8.1
ghc-exactprint.cabal view
@@ -1,58 +1,32 @@+cabal-version:       2.4 name:                ghc-exactprint-version:             0.5.8.2+version:             1.14.0.0 synopsis:            ExactPrint for GHC-description:         Using the API Annotations available from GHC 7.10.2, this+description:         Using the API Annotations available from GHC 9.2.1, this                      library provides a means to round trip any code that can                      be compiled by GHC, currently excluding lhs files.                      .-                     It does this with a phased approach-                     .-                        * Delta - converts GHC API Annotations into relative-                          offsets, indexed by SrcSpan-                     .-                        * Transform - functions to facilitate changes to-                          the AST, adjusting the annotations generated in the-                          Delta phase to suit the changes.-                     .-                        * Print - converts an AST and its annotations to-                          properly formatted source text.-                     .-                        * Pretty - adds annotations to an AST (fragment) so that-                          the output can be parsed back to the same AST.-                     .+                     Note: requires GHC 9.14.*. For earlier GHC+                     versions see lower version numbers.                      .-                     Note: requires GHC 7.10.2 or later -license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Alan Zimmerman, Matthew Pickering maintainer:          alan.zimm@gmail.com category:            Development build-type:          Simple-tested-with:         GHC == 7.10.3-                   , GHC == 8.0.1-                   , GHC == 8.0.2-                   , GHC == 8.2.2-                   , GHC == 8.4.2-                   , GHC == 8.4.3-                   , GHC == 8.4.4-                   , GHC == 8.6.1-extra-source-files:  ChangeLog-                     src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs-                     tests/examples/failing/*.hs-                     tests/examples/ghc710/*.hs-                     tests/examples/ghc710-only/*.hs-                     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+tested-with:         GHC == 9.14.1+extra-doc-files:     ChangeLog+extra-source-files:  tests/examples/failing/*.hs                      tests/examples/failing/*.hs.bad+                     tests/examples/ghc910/*.hs+                     tests/examples/ghc912/*.hs+                     tests/examples/ghc914/*.hs+                     tests/examples/pre-ghc910/*.hs+                     tests/examples/pre-ghc910/*.hs-boot+                     tests/examples/transform/*.hs                      tests/examples/transform/*.hs.expected-                     tests/examples/ghc710/*.hs-boot-cabal-version:       >=1.10  source-repository head   type:     git@@ -68,61 +42,33 @@   Default:     False } +common warnings+  GHC-options: -Wall -Wredundant-constraints -Wunused-packages  library+  import: warnings   exposed-modules:     Language.Haskell.GHC.ExactPrint-                     , Language.Haskell.GHC.ExactPrint.Annotate-                     , Language.Haskell.GHC.ExactPrint.AnnotateTypes-                     , Language.Haskell.GHC.ExactPrint.Annotater-                     , Language.Haskell.GHC.ExactPrint.Delta-                     , Language.Haskell.GHC.ExactPrint.Lookup+                     , Language.Haskell.GHC.ExactPrint.ExactPrint                      , Language.Haskell.GHC.ExactPrint.Parsers                      , Language.Haskell.GHC.ExactPrint.Preprocess-                     , Language.Haskell.GHC.ExactPrint.Pretty-                     , Language.Haskell.GHC.ExactPrint.Print                      , Language.Haskell.GHC.ExactPrint.Transform                      , Language.Haskell.GHC.ExactPrint.Types                      , Language.Haskell.GHC.ExactPrint.Utils -  if impl (ghc <= 8.0.2)-      exposed-modules: Language.Haskell.GHC.ExactPrint.GhcInterim--  -- other-modules:-  -- other-extensions:-  GHC-Options:         -Wall-  build-depends:       base >=4.7 && <4.13-                     , bytestring >= 0.10.6-                     , containers >= 0.5-                     , directory >= 1.2-                     , filepath  >= 1.4-                     , ghc       >= 7.10.2-                     , ghc-paths >= 0.1-                     , mtl       >= 2.2.1-                     , syb       >= 0.5-                     , free      >= 4.12-  if impl (ghc >= 7.11)-      build-depends: ghc-boot   hs-source-dirs:      src--  if impl (ghc > 8.4.4)-      hs-source-dirs: src-ghc86-  else-    if impl (ghc > 8.2.2)-        hs-source-dirs: src-ghc84-    else-      if impl (ghc > 8.0.3)-          hs-source-dirs: src-ghc82-      else-        if impl (ghc > 7.10.3)-            hs-source-dirs: src-ghc80-        else-            hs-source-dirs: src-ghc710+  build-depends:       base >=4.22 && <4.23+                     , containers >= 0.5  && < 0.9+                     , ghc       >= 9.14 && < 9.15+                     , ghc-boot  >= 9.14 && < 9.15+                     , mtl       >= 2.2.1 && < 2.5+                     , syb       >= 0.5 && < 0.8    default-language:    Haskell2010-  if impl (ghc < 7.10.2)-      buildable: False+  if impl (ghc < 9.12)+    buildable: False  Test-Suite test+  import: warnings   type:                exitcode-stdio-1.0   if flag (dev)     hs-source-dirs:      tests@@ -130,117 +76,92 @@   else     hs-source-dirs:      tests -  if impl (ghc > 8.4.4)-      hs-source-dirs: src-ghc86-  else-    if impl (ghc > 8.2.2)-        hs-source-dirs: src-ghc84-    else-      if impl (ghc > 8.0.3)-          hs-source-dirs: src-ghc82-      else-        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-                     , Test.Consistency+                     , Test.CommonUtils                      , Test.NoAnnotations                      , Test.Transform-  GHC-Options:         -threaded -Wall+  GHC-Options:         -threaded   Default-language:    Haskell2010-  if impl (ghc < 7.10.2)-      buildable: False-  Build-depends:       HUnit >= 1.2-                     , base < 4.13-                     , bytestring+  Build-depends:       base < 4.23+                     , HUnit >= 1.2                      , containers >= 0.5                      , Diff                      , directory >= 1.2                      , filepath  >= 1.4-                     , ghc  >= 7.10.2+                     , ghc       >= 9.14                      , ghc-paths  >= 0.1-                     , mtl        >= 2.2.1                      , syb        >= 0.5                      , silently   >= 1.2-                     , filemanip  >= 0.3-                     -- for the lib only+                     , ghc-boot   if flag (dev)-      build-depends: free+      build-depends:+                     mtl        >= 2.2.1   else       build-depends: ghc-exactprint--  if impl (ghc >= 7.11)-      build-depends: ghc-boot+  if impl (ghc < 9.14)+      buildable: False  executable roundtrip+  import: warnings   main-is: Roundtrip.hs   hs-source-dirs: tests   other-modules: Test.Common                  Test.CommonUtils-                 Test.Consistency   default-language:    Haskell2010-  if impl (ghc >= 7.10.2) && flag (roundtrip)+  if impl (ghc >= 9.14) && flag (roundtrip)     build-depends:-                 HUnit-               , base-               , containers-               , directory-               , filemanip-               , filepath-               , ghc+                 HUnit      < 1.7+               , base       < 4.23+               , containers < 0.9+               , directory  < 1.4+               , extra      < 1.9+               , filepath   < 1.6+               , ghc        >= 9.14 && < 9.15                , ghc-exactprint-               , ghc-paths-               , syb-               , temporary-               , time-    if impl (ghc >= 7.11)-        build-depends: ghc-boot+               , ghc-paths  < 0.2+               , time       < 1.16+               , ghc-boot     buildable: True   else     buildable: False-  ghc-options:-    -threaded -Wall+  GHC-Options: -threaded  executable static+  import: warnings   main-is: Static.hs   hs-source-dirs: tests+  other-modules: Test.CommonUtils   default-language:    Haskell2010   if flag (roundtrip)-    build-depends: base-                 , directory-                 , filemanip-                 , filepath-                 , ghc-                 , Diff+    build-depends: base < 4.23+                 , directory < 1.4+                 , extra     < 1.9+                 , filepath  < 1.6+                 , ghc       >= 9.14 && < 9.15+                 , Diff      < 1.1     buildable: True-    if impl (ghc >= 7.11)-        build-depends: ghc-boot   else     buildable: False-  ghc-options:-    -threaded -Wall+  GHC-Options: -threaded -executable prepare-hackage-  main-is: PrepareHackage.hs-  hs-source-dirs: tests-  default-language:    Haskell2010-  if flag (roundtrip)-    build-depends: base-                 , containers-                 , directory-                 , filemanip-                 , filepath-                 , ghc       >= 7.10.2-                 , ghc-paths >= 0.1-                 , HUnit-                 , text   >= 1.2.2-                 , turtle >= 1.3.0-    buildable: True-    if impl (ghc >= 7.11)-        build-depends: ghc-boot-  else-    buildable: False-  GHC-Options:         -threaded+-- executable prepare-hackage+--   import: warnings+--   main-is: PrepareHackage.hs+--   other-modules: Test.CommonUtils+--   hs-source-dirs: tests+--   default-language:    Haskell2010+--   if flag (roundtrip)+--     build-depends: base < 4.22+--                  , containers+--                  , directory+--                  , extra+--                  , filepath+--                  , ghc       >= 9.12+--                  , HUnit+--                  , text   >= 1.2.2+--                  , turtle >= 1.3.0+--     buildable: True+--   else+--     buildable: False+--   GHC-Options: -threaded
− src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs 
@@ -1,2556 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook--- | '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 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.RdrName) 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => GHC.HsLocalBinds name -> 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.RdrName) 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 ls txt) lss) = do-    markExternal ls GHC.AnnOpen txt-    mark GHC.AnnOpenS-    markListIntercalate lss-    mark GHC.AnnCloseS-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do-    markExternal ls GHC.AnnOpen txt-    mark GHC.AnnOpenS-    markListIntercalate lss-    mark GHC.AnnCloseS-    markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance Annotate (GHC.SourceText,GHC.FastString) where-  markAST l (src,_fs) = do-    markExternal l GHC.AnnVal src---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.LIE name] 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 (GHC.DataId name,GHC.HasOccName name, Annotate name)-  => Annotate (GHC.IE name) where-  markAST _ ie = do--    case ie of-        (GHC.IEVar ln) -> do-          -- TODO: I am pretty sure this criterion is inadequate-          if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln-            then mark GHC.AnnPattern-            else markOptional GHC.AnnPattern-          setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln--        (GHC.IEThingAbs ln@(GHC.L _ n)) -> do-          {--          At the moment (7.10.2) GHC does not cleanly represent an export of the form-           "type Foo"-          and it only captures the name "Foo".--          The Api Annotations workaround is to have the IEThingAbs SrcSpan-          extend across both the "type" and "Foo", and then to capture the-          individual item locations in an AnnType and AnnVal annotation.--          This need to be fixed for 7.12.--          -}--          if GHC.isTcOcc (GHC.occName n) && GHC.isSymOcc (GHC.occName n)-            then do-              mark GHC.AnnType-              setContext (Set.singleton PrefixOp) $ markLocatedFromKw GHC.AnnVal ln-            else setContext (Set.singleton PrefixOp) $ markLocated ln--        (GHC.IEThingWith ln ns) -> do-          setContext (Set.singleton PrefixOp) $ markLocated ln-          mark GHC.AnnOpenP-          setContext (Set.singleton 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 ()-    ifInContext (Set.fromList [Intercalate])-      (mark         GHC.AnnComma)-      (markOptional GHC.AnnComma)---- ----------------------------------------------------------------------{---- For details on above see note [Api annotations] in ApiAnnotation-data RdrName-  = Unqual OccName-        -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.-        -- Create such a 'RdrName' with 'mkRdrUnqual'--  | Qual ModuleName OccName-        -- ^ A qualified name written by the user in-        -- /source/ code.  The module isn't necessarily-        -- the module where the thing is defined;-        -- just the one from which it is imported.-        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.-        -- Create such a 'RdrName' with 'mkRdrQual'--  | Orig Module OccName-        -- ^ An original name; the module is the /defining/ module.-        -- This is used when GHC generates code that will be fed-        -- into the renamer (e.g. from deriving clauses), but where-        -- we want to say \"Use Prelude.map dammit\". One of these-        -- can be created with 'mkOrig'--  | Exact Name-        -- ^ We know exactly the 'Name'. This is used:-        ---        --  (1) When the parser parses built-in syntax like @[]@-        --      and @(,)@, but wants a 'RdrName' from it-        ---        --  (2) By Template Haskell, when TH has generated a unique name-        ---        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'-  deriving (Data, Typeable)--}--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 && rdrName2String n /= "$"-      doNormalRdrName = do-        let str' = case str of-              -- TODO: unicode support?-                        "forall" -> if spanLength l == 1 then "∀" else str-                        _ -> str-        when (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) $ inContext (Set.singleton InIE) $ mark GHC.AnnType-        markOptional GHC.AnnType--        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--        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 _ _ -> markExternal l GHC.AnnVal 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-           mark GHC.AnnOpenP-           mark GHC.AnnTilde-           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")---- ------------------------------------------------------------------------- TODO: What is this used for? Not in ExactPrint-instance Annotate GHC.Name where-  markAST l n = do-    markExternal l GHC.AnnVal (showGhc n)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.ImportDecl name) 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 "#-}"-   when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc)-             >> markWithString GHC.AnnClose "#-}")-   when safeflag (mark GHC.AnnSafe)-   when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)-   case mpkg of-    Nothing -> return ()-    Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg))--   markLocated modname--   case GHC.ideclAs imp of-      Nothing -> return ()-      Just mn -> do-          mark GHC.AnnAs-          markWithString GHC.AnnVal (GHC.moduleNameString mn)--   case hiding of-     Nothing -> return ()-     Just (isHiding,lie) -> do-       if isHiding-         then setContext (Set.singleton HasHiding) $-                markLocated lie-         else markLocated lie-   markTrailingSemi---- -----------------------------------------------------------------------instance Annotate GHC.ModuleName where-   markAST l mname =-    markExternal l GHC.AnnVal (GHC.moduleNameString mname)---- -----------------------------------------------------------------------markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-            => GHC.LHsDecl name -> 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.VectD 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.QuasiQuoteD d -> markLocated (GHC.L l d)--instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-            => Annotate (GHC.HsDecl name) where-  markAST l d = markLHsDecl (GHC.L l d)---- -----------------------------------------------------------------------instance (Annotate name)-   => Annotate (GHC.RoleAnnotDecl name) where-  markAST _ (GHC.RoleAnnotDecl ln mr) = do-    mark GHC.AnnType-    mark GHC.AnnRole-    markLocated ln-    mapM_ markLocated mr--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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.SpliceDecl name) where-  markAST _ (GHC.SpliceDecl e flag) = do-    case flag of-      GHC.ExplicitSplice -> mark GHC.AnnOpenPE-      GHC.ImplicitSplice -> return ()--    setContext (Set.singleton InSpliceDecl) $ markLocated e--    case flag of-      GHC.ExplicitSplice -> mark GHC.AnnCloseP-      GHC.ImplicitSplice -> return ()--    markTrailingSemi--{--- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y)--                           ImplicitSplice   -- <=> f x y,  i.e. a naked--                           top level expression----}---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.VectDecl name) where-  markAST _ (GHC.HsVect src ln e) = do-    markWithString GHC.AnnOpen src -- "{-# VECTORISE"-    markLocated ln-    mark GHC.AnnEqual-    markLocated e-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsNoVect src ln) = do-    markWithString GHC.AnnOpen src -- "{-# NOVECTORISE"-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsVectTypeIn src _b ln mln) = do-    markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR"-    mark GHC.AnnType-    markLocated ln-    case mln of-      Nothing -> return ()-      Just lnn -> do-        mark GHC.AnnEqual-        markLocated lnn-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectTypeOut {} =-    traceM "warning: HsVectTypeOut appears after renaming"--  markAST _ (GHC.HsVectClassIn src ln) = do-    markWithString GHC.AnnOpen src -- "{-# VECTORISE"-    mark GHC.AnnClass-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectClassOut {} =-    traceM "warning: HsVecClassOut appears after renaming"-  markAST _ GHC.HsVectInstIn {}   =-    traceM "warning: HsVecInstsIn appears after renaming"-  markAST _ GHC.HsVectInstOut {}   =-    traceM "warning: HsVecInstOut appears after renaming"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.RuleDecls name) where-   markAST _ (GHC.HsRules src rules) = do-     markWithString GHC.AnnOpen src-     setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules-     markWithString GHC.AnnClose "#-}"-     markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.RuleDecl name) where-  markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do-    markLocated ln-    setContext (Set.singleton ExplicitNeverActive) $ markActivation 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---- -----------------------------------------------------------------------markActivation :: GHC.Activation -> Annotated ()-markActivation act = do-  case act of-    GHC.ActiveBefore n -> do-      mark GHC.AnnOpenS --  '['-      mark GHC.AnnTilde -- ~-      markWithString GHC.AnnVal (show n)-      mark GHC.AnnCloseS -- ']'-    GHC.ActiveAfter n -> do-      mark GHC.AnnOpenS --  '['-      markWithString GHC.AnnVal (show n)-      mark GHC.AnnCloseS -- ']'-    GHC.NeverActive -> do-      inContext (Set.singleton ExplicitNeverActive) $ do-        mark GHC.AnnOpenS --  '['-        mark GHC.AnnTilde -- ~-        mark GHC.AnnCloseS -- ']'-    _ -> return ()---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.RuleBndr name) where-  markAST _ (GHC.RuleBndr ln) = markLocated ln-  markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do-    mark GHC.AnnOpenP -- "("-    markLocated ln-    mark GHC.AnnDcolon-    markLocated thing-    mark GHC.AnnCloseP -- ")"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.AnnDecl name) where-   markAST _ (GHC.HsAnnotation src prov e) = do-     markWithString GHC.AnnOpen src-     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---- -----------------------------------------------------------------------instance Annotate name => Annotate (GHC.WarnDecls name) where-   markAST _ (GHC.Warnings src warns) = do-     markWithString GHC.AnnOpen src-     mapM_ markLocated warns-     markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance (Annotate name)-   => Annotate (GHC.WarnDecl name) 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 -- "]"--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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.ForeignDecl name) where-  markAST _ (GHC.ForeignImport ln 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-    markExternal ls GHC.AnnVal (show src)-    markLocated ln-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi---  markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do-    mark GHC.AnnForeign-    mark GHC.AnnExport-    markLocated spec-    markExternal ls GHC.AnnVal (show src)-    setContext (Set.singleton PrefixOp) $ markLocated ln-    mark GHC.AnnDcolon-    markLocated typ----- -----------------------------------------------------------------------instance (Annotate GHC.CExportSpec) where-  markAST l (GHC.CExportStatic _ 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.DerivDecl name) where--  markAST _ (GHC.DerivDecl typ mov) = do-    mark GHC.AnnDeriving-    mark GHC.AnnInstance-    markMaybe mov-    markLocated typ-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.DefaultDecl name) where--  markAST _ (GHC.DefaultDecl typs) = do-    mark GHC.AnnDefault-    mark GHC.AnnOpenP -- '('-    markListIntercalate typs-    mark GHC.AnnCloseP -- ')'-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.InstDecl name) 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---- -----------------------------------------------------------------------instance Annotate GHC.OverlapMode where-  markAST _ (GHC.NoOverlap src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Overlappable src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Overlapping src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Overlaps src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Incoherent src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.ClsInstDecl name) where--  markAST _ (GHC.ClsInstDecl 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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.TyFamInstDecl name) where--  markAST _ (GHC.TyFamInstDecl eqn _) = do-    mark GHC.AnnType-    inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional-    markLocated eqn-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.DataFamInstDecl name) where--  markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _)-             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-    inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance--    markLocated ctx--    markTyClass ln pats--    if isGadt $ GHC.dd_cons defn-      then mark GHC.AnnWhere-      else mark GHC.AnnEqual-    markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs)-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsBind name) where-  markAST _ (GHC.FunBind _ _ (GHC.MG 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 lb) _typ _fvs _ticks) = do-    markLocated lhs-    case grhs of-      (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards-      _ -> return ()-    markListIntercalateWithFunLevel markLocated 2 grhs-    unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere-    markOptional GHC.AnnWhere--    markLocalBindsWithLayout lb-    markTrailingSemi--  markAST _ (GHC.VarBind _n rhse _) =-    -- Note: this bind is introduced by the typechecker-    markLocated rhse--  markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do-    mark GHC.AnnPattern-    case args of-      GHC.InfixPatSyn la lb -> do-        markLocated la-        setContext (Set.singleton InfixOp) $ markLocated ln-        markLocated lb-      GHC.PrefixPatSyn ns -> do-        markLocated ln-        mapM_ markLocated ns-    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--  -- Introduced after renaming.-  markAST _ (GHC.AbsBinds _ _ _ _ _) =-    traceM "warning: AbsBinds introduced after renaming"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-    => Annotate (GHC.IPBind name) where-  markAST _ (GHC.IPBind en e) = do-    case en of-      Left n -> markLocated n-      Right _i -> return ()-    mark GHC.AnnEqual-    markLocated e-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate GHC.HsIPName where-  markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,-                                                  Annotate body)-  => Annotate (GHC.Match name (GHC.Located body)) where--  markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do-    let-      get_infix Nothing = False-      get_infix (Just (_,f)) = f-      isFunBind = isJust-    case (get_infix mln,pats) of-      (True, a:b:xs) -> do-        if null xs-          then markOptional GHC.AnnOpenP-          else mark         GHC.AnnOpenP-        markLocated a-        case mln of-          Nothing -> return ()-          Just (n,_) -> setContext (Set.singleton InfixOp) $ markLocated n-        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-          -- Nothing -> mark GHC.AnnFunId-          Nothing -> markListNoPrecedingSpace False pats-          Just (n,_) -> do-            setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n-            mapM_ markLocated pats-        -- markListNoPrecedingSpace 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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,-          Annotate name, Annotate body)-  => Annotate (GHC.GRHS name (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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.Sig name) where--  markAST _ (GHC.TypeSig lns typ _) = do-    setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi-    tellContext (Set.singleton FollowingLine)--  markAST _ (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do-    mark GHC.AnnPattern-    markLocated ln-    mark GHC.AnnDcolon--    -- Note: The 'forall' bndrs '.' may occur multiple times-    unless (null bndrs) $ do-      mark GHC.AnnForall-      mapM_ markLocated bndrs-      mark GHC.AnnDot--    when (GHC.getLoc ctx1 /= GHC.noSrcSpan) $ do-        setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx1-        markOffset GHC.AnnDarrow 0-    when (GHC.getLoc ctx2 /= GHC.noSrcSpan) $ do-        setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx2-        markOffset GHC.AnnDarrow 1-    markLocated typ-    markTrailingSemi--  markAST _ (GHC.GenericSig ns typ) = do-    mark GHC.AnnDefault-    -- markListIntercalate ns-    setContext (Set.singleton PrefixOp) $ markListIntercalate ns-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi--  markAST _ (GHC.IdSig _) =-    traceM "warning: Introduced after renaming"--  -- FixSig (FixitySig name)-  markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do-    let fixstr = case fdir of-         GHC.InfixL -> "infixl"-         GHC.InfixR -> "infixr"-         GHC.InfixN -> "infix"-    markWithString GHC.AnnInfix fixstr-    markWithString GHC.AnnVal (show v)-    setContext (Set.singleton InfixOp) $ markListIntercalate lns-    markTrailingSemi--  -- InlineSig (Located name) InlinePragma-  -- '{-# INLINE' activation qvar '#-}'-  markAST _ (GHC.InlineSig ln inl) = do-    markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE'-    markActivation (GHC.inl_act inl)-    setContext (Set.singleton PrefixOp) $ markLocated ln-    markWithString GHC.AnnClose "#-}" -- '#-}'-    markTrailingSemi--  markAST _ (GHC.SpecSig ln typs inl) = do-    markWithString GHC.AnnOpen (GHC.inl_src inl)-    markActivation (GHC.inl_act inl)-    markLocated ln-    mark GHC.AnnDcolon -- '::'-    markListIntercalate typs-    markWithString GHC.AnnClose "#-}" -- '#-}'-    markTrailingSemi---  -- '{-# SPECIALISE' 'instance' inst_type '#-}'-  markAST _ (GHC.SpecInstSig src typ) = do-    markWithString GHC.AnnOpen src-    mark GHC.AnnInstance-    markLocated typ-    markWithString GHC.AnnClose "#-}" -- '#-}'-    markTrailingSemi----  -- MinimalSig (BooleanFormula (Located name))-  markAST _l (GHC.MinimalSig src formula) = do-    markWithString GHC.AnnOpen src-    annotationsToCommentsBF formula [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar]-    markAST _l formula-    finalizeBF _l-    markWithString GHC.AnnClose "#-}"-    markTrailingSemi---- ------------------------------------------------------------------------ In practice, due to the way the BooleanFormula is constructed in the parser,--- we will get the following variants--- a | b : Or [a,b]--- a , b : And [a,b]--- ( a ) : a--- A bottom level Located RdrName is captured in a Var. This is the only part--- with a location in it.------ So the best strategy might be to convert all the annotations into comments,--- and then just print the names. DONE-instance  (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where-  -- markAST _ (GHC.Var x)  = markLocated x-  markAST _ (GHC.Var x)  = setContext (Set.singleton PrefixOp) $ markLocated x-  markAST l (GHC.Or ls)  = mapM_ (markAST l) ls-  markAST l (GHC.And ls) = mapM_ (markAST l) ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsTyVarBndr name) where-  markAST _l (GHC.UserTyVar n) = do-    markAST _l n--  markAST _ (GHC.KindedTyVar n ty) = do-    mark GHC.AnnOpenP  -- '('-    markLocated n-    mark GHC.AnnDcolon -- '::'-    markLocated ty-    mark GHC.AnnCloseP -- '('---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.HsType name) where-  markAST loc ty = do-    markType loc ty-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma-   where--    -- markType :: GHC.SrcSpan -> ast -> Annotated ()-    markType _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do-      unless (null tvs) $ do-        mark GHC.AnnForall-        mapM_ markLocated tvs-        mark GHC.AnnDot--      case mwc of-        Nothing -> when (lc /= GHC.noSrcSpan) $ markLocated ctx-        Just lwc -> do-         let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs)-         markLocated (GHC.L lc sorted)--      markLocated typ-      -- mark GHC.AnnCloseP -- ")"--    markType _l (GHC.HsTyVar name) = do-      if GHC.isDataOcc $ GHC.occName name-        then do-            mark GHC.AnnSimpleQuote-            markLocatedFromKw GHC.AnnName (GHC.L _l name)-        else unsetContext Intercalate  $ markAST _l 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--    markType _ (GHC.HsListTy t) = do-      mark GHC.AnnOpenS -- '['-      markLocated t-      mark GHC.AnnCloseS -- ']'--    markType _ (GHC.HsPArrTy t) = do-      markWithString GHC.AnnOpen "[:" -- '[:'-      markLocated t-      markWithString GHC.AnnClose ":]" -- ':]'--    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.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 (GHC.HsIPName n) t) = do-      markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n))-      mark GHC.AnnDcolon-      markLocated t--    markType _ (GHC.HsEqTy t1 t2) = do-      markLocated t1-      mark GHC.AnnTilde-      markLocated t2--    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-      mark GHC.AnnOpenPE-      markAST l s-      mark GHC.AnnCloseP--    markType _ (GHC.HsDocTy t ds) = do-      markLocated t-      markLocated ds--    markType _ (GHC.HsBangTy b t) = do-      case b of-        (GHC.HsSrcBang ms (Just True) _) -> do-          markWithString GHC.AnnOpen  (fromMaybe "{-# UNPACK" ms)-          markWithString GHC.AnnClose "#-}"-        (GHC.HsSrcBang ms (Just False) _) -> do-          markWithString GHC.AnnOpen  (fromMaybe "{-# NOUNPACK" ms)-          markWithString GHC.AnnClose "#-}"-        _ -> return ()-      mark GHC.AnnBang-      markLocated t--    markType _ (GHC.HsRecTy cons) = do-      mark GHC.AnnOpenC  -- '{'-      markListIntercalate cons-      mark GHC.AnnCloseC -- '}'--    -- HsCoreTy Type-    markType _ (GHC.HsCoreTy _t) =-      traceM "warning: HsCoreTy Introduced after renaming"--    markType _ (GHC.HsExplicitListTy _ ts) = do-      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--    -- HsTyLit HsTyLit-    markType l (GHC.HsTyLit lit) = do-      case lit of-        (GHC.HsNumTy s _) ->-          markExternal l GHC.AnnVal s-        (GHC.HsStrTy s _) ->-          markExternal l GHC.AnnVal s--    -- HsWrapTy HsTyAnnotated (HsType name)-    markType _ (GHC.HsWrapTy _ _) =-      traceM "warning: HsWrapTyy Introduced after renaming"--    markType l GHC.HsWildcardTy = do-      markExternal l GHC.AnnVal "_"-    markType l (GHC.HsNamedWildcardTy n) = do-      markExternal l GHC.AnnVal  (showGhc n)--    markType l (GHC.HsQuasiQuoteTy n) = do-      markAST l n---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsSplice name) where-  markAST _ c =-    case c of-      GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n))  -> do-        -- TODO: We do not seem to have any way to distinguish between which of-        -- the next two lines will emit output. If AnnThIdSplice is there, the-        markWithStringOptional GHC.AnnThIdSplice   ("$" ++ (GHC.occNameString (GHC.occName n)))-        markLocated b-      GHC.HsSplice _n b@(GHC.L _ (GHC.HsBracket _)) -> do-        markLocated b-      GHC.HsSplice _n b -> do-        markLocated b--instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsQuasiQuote name) where-  markAST l (GHC.HsQuasiQuote n _pos fs) = do-        markExternal l GHC.AnnVal-              ("[" ++ showGhc n ++ "|" ++ GHC.unpackFS fs ++ "|]")---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) =>-                             Annotate (GHC.ConDeclField name) where-  markAST _ (GHC.ConDeclField ns ty mdoc) = do-{--data ConDeclField name  -- Record fields have Haddoc docs on them-  = ConDeclField { cd_fld_names :: [LFieldOcc name],-                                   -- ^ See Note [ConDeclField names]-                   cd_fld_type :: LBangType name,-                   cd_fld_doc  :: Maybe LHsDocString }---}-    unsetContext Intercalate $ do-      markListIntercalate ns-      mark GHC.AnnDcolon-      markLocated ty-      markMaybe mdoc-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma---- -----------------------------------------------------------------------instance Annotate GHC.HsDocString where-  markAST l (GHC.HsDocString s) = do-    markExternal l GHC.AnnVal (GHC.unpackFS s)---- ----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.Pat name) 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 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.PArrPat ps _) = do-        markWithString GHC.AnnOpen "[:"-        mapM_ markLocated ps-        markWithString GHC.AnnClose ":]"--      markPat _ (GHC.ConPatIn n dets) = do-        markHsConPatDetails n dets--      markPat _ GHC.ConPatOut {} =-        traceM "warning: ConPatOut Introduced after renaming"--      -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type)-      markPat _ (GHC.ViewPat e pat _) = do-        markLocated e-        mark GHC.AnnRarrow-        markLocated pat--      -- SplicePat (HsSplice id)-      markPat l (GHC.SplicePat s) = do-        mark GHC.AnnOpenPE-        markAST l s-        mark GHC.AnnCloseP--      -- LitPat HsLit-      markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp)--      -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id)-      markPat _ (GHC.NPat ol mn _) = do-        -- markOptional GHC.AnnMinus-        when (isJust mn) $ mark GHC.AnnMinus-        markLocated ol--      -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id)-      markPat _ (GHC.NPlusKPat ln ol _ _) = do-        markLocated ln-        markWithString GHC.AnnVal "+"  -- "+"-        markLocated ol---      markPat _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do-        markLocated pat-        mark GHC.AnnDcolon-        markLocated ty--      markPat _ GHC.SigPatOut {} =-        traceM "warning: SigPatOut introduced after renaming"--      -- CoPat HsAnnotated (Pat id) Type-      markPat _ GHC.CoPat {} =-        traceM "warning: CoPat introduced after renaming"--      markPat l (GHC.QuasiQuotePat p) = markAST l p---- ----------------------------------------------------------------------hsLit2String :: GHC.HsLit -> GHC.SourceText-hsLit2String lit =-  case lit of-    GHC.HsChar       src _   -> src-    -- It should be included here-    -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471-    GHC.HsCharPrim   src _   -> src ++ "#"-    GHC.HsString     src _   -> src-    GHC.HsStringPrim src _   -> src-    GHC.HsInt        src _   -> src-    GHC.HsIntPrim    src _   -> src-    GHC.HsWordPrim   src _   -> src-    GHC.HsInt64Prim  src _   -> src-    GHC.HsWord64Prim src _   -> src-    GHC.HsInteger    src _ _ -> src-    GHC.HsRat        (GHC.FL src _) _ -> src-    GHC.HsFloatPrim  (GHC.FL src _)   -> src ++ "#"-    GHC.HsDoublePrim (GHC.FL src _)   -> src ++ "##"--markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                      => GHC.Located name -> GHC.HsConPatDetails name -> Annotated ()-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-      setContext (Set.singleton InfixOp) $ markLocated ln-      markLocated a2--markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                    => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated ()--markHsConDeclDetails isDeprecated inGadt lns dets = do-  case dets of-    GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args-    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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate [GHC.LConDeclField name] 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 (GHC.DataId name) => Annotate (GHC.HsOverLit name) where-  markAST l ol =-    let str = case GHC.ol_val ol of-                GHC.HsIntegral src _ -> src-                GHC.HsFractional l2  -> GHC.fl_text l2-                GHC.HsIsString src _ -> src-    in-    markExternal l GHC.AnnVal str---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate arg)-    => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where-  markAST _ (GHC.HsWB thing _ _ _) = do-    markLocated thing---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name-         ,GHC.HasOccName name,Annotate body)-  => Annotate (GHC.Stmt name (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.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 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---- ------------------------------------------------------------------------- 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  (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  =>  Annotate (GHC.ParStmtBlock name name) where-  markAST _ (GHC.ParStmtBlock stmts _ns _) = do-    markListIntercalate stmts---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsLocalBinds name) where-  markAST _ lb = markHsLocalBinds lb---- -----------------------------------------------------------------------markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                     => GHC.HsLocalBinds name -> Annotated ()-markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =-    applyListAnnotationsLayout-       (prepareListAnnotation (GHC.bagToList binds)-     ++ prepareListAnnotation sigs-       )-markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {})-   = traceM "warning: ValBindsOut introduced after renaming"--markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds)-markHsLocalBinds GHC.EmptyLocalBinds                   = return ()---- -----------------------------------------------------------------------markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,-                                               Annotate body)-                   => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body)-                   -> Annotated ()-markMatchGroup _ (GHC.MG matches _ _ _)-  = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,-                                               Annotate body)-  => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsExpr name) 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 l (GHC.HsVar n)           = unsetContext Intercalate $ markAST l n--      markExpr l (GHC.HsIPVar (GHC.HsIPName v))         =-        markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v)-      markExpr l (GHC.HsOverLit ov)     = markAST l ov-      markExpr l (GHC.HsLit lit)        = markAST l lit--      markExpr _ (GHC.HsLam (GHC.MG [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-        -- markLocated e1-        setContext (Set.singleton PrefixOp) $ markLocated e1-        -- markLocated e2-        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 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 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 es _) = do-        case cts of-          GHC.DoExpr  -> mark GHC.AnnDo-          GHC.MDoExpr -> mark GHC.AnnMdo-          _           -> return ()-        let (ostr,cstr) =-              if isListComp cts-                then case cts of-                       GHC.PArrComp -> ("[:",":]")-                       _            -> ("[",  "]")-                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.ExplicitPArr _ es)   = do-        markWithString GHC.AnnOpen "[:"-        markListIntercalate es-        markWithString GHC.AnnClose ":]"--      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 (GHC.HsRecFields fs _) _cons _ _) = do-        markLocated e-        mark GHC.AnnOpenC-        markListIntercalate fs-        mark GHC.AnnCloseC--      markExpr _ (GHC.ExprWithTySig e typ _) = do-        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e-        mark GHC.AnnDcolon-        markLocated typ--      markExpr _ (GHC.ExprWithTySigOut e typ) = do-        markLocated e-        mark GHC.AnnDcolon-        markLocated 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.PArrSeq _ seqInfo) = do-        markWithString GHC.AnnOpen "[:" -- '[:'-        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-        markWithString GHC.AnnClose ":]" -- ':]'--      markExpr _ (GHC.HsSCC src csFStr e) = do-        markWithString GHC.AnnOpen src -- "{-# SCC"-        markWithStringOptional GHC.AnnVal (GHC.unpackFS csFStr)-        markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"")-        markWithString GHC.AnnClose "#-}"-        markLocated e--      markExpr _ (GHC.HsCoreAnn src csFStr e) = do-        markWithString GHC.AnnOpen src -- "{-# CORE"-        markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS 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-        markWithString GHC.AnnClose "|]"-      -- Introduced after the renamer-      markExpr _ (GHC.HsBracket (GHC.DecBrG _)) =-        traceM "warning: DecBrG introduced after renamer"-      markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do-        -- This exists like this as the lexer collapses [e| and [| into the-        -- same construtor-        workOutString _l GHC.AnnOpen-          (\ss -> if spanLength ss == 2-                    then "[|"-                    else "[e|")-        markLocated e-        markWithString GHC.AnnClose "|]"-      markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do-        -- This exists like this as the lexer collapses [e|| and [|| into the-        -- same construtor-        workOutString _l GHC.AnnOpen-          (\ss -> if spanLength ss == 3-                    then "[||"-                    else "[e||")-        markLocated e-        markWithString GHC.AnnClose "||]"-      markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do-        markWithString GHC.AnnOpen "[t|"-        markLocated e-        markWithString GHC.AnnClose "|]"-      markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do-        markWithString GHC.AnnOpen  "[p|"-        markLocated e-        markWithString GHC.AnnClose "|]"--      markExpr _ (GHC.HsRnBracketOut _ _) =-        traceM "warning: HsRnBracketOut introduced after renamer"-      markExpr _ (GHC.HsTcBracketOut _ _) =-        traceM "warning: HsTcBracketOut introduced after renamer"--      markExpr _ (GHC.HsSpliceE isTyped e) = do-        case e of-          GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n))  -> do-            if isTyped-              then do-                mark GHC.AnnOpenPTE-                markWithStringOptional GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))-              else do-                mark GHC.AnnOpenPE-                markWithStringOptional GHC.AnnThIdSplice   ("$" ++ (GHC.occNameString (GHC.occName n)))-            markLocated b-            mark GHC.AnnCloseP-          GHC.HsSplice _n b -> do-            if isTyped-              then do-                markOptional GHC.AnnThIdSplice-                mark GHC.AnnOpenPTE-              else mark GHC.AnnOpenPE-            markLocated b-            mark GHC.AnnCloseP--      markExpr l (GHC.HsQuasiQuoteE e) = do-        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.AnnOpen "(|"-        markLocated e-        mapM_ markLocated cs-        markWithString GHC.AnnClose "|)"--      markExpr _ (GHC.HsTick _ _) = return ()-      markExpr _ (GHC.HsBinTick _ _ _) = return ()--      markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do-        -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'-        markWithString       GHC.AnnOpen  src-        markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING-        markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER-        markOffset GHC.AnnColon 0 -- ':'-        markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER-        mark   GHC.AnnMinus   -- '-'-        markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER-        markOffset GHC.AnnColon 1 -- ':'-        markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER-        markWithString   GHC.AnnClose  "#-}"-        markLocated e--      markExpr l GHC.EWildPat = do-        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.HsType ty) = markLocated ty--      markExpr _ (GHC.HsWrap _ _) =-        traceM "warning: HsWrap introduced after renaming"-      markExpr _ (GHC.HsUnboundVar _) =-        traceM "warning: HsUnboundVar introduced after renaming"----- -----------------------------------------------------------------------instance Annotate GHC.HsLit where-  markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)---- ------------------------------------------------------------------------- |Used for declarations that need to be aligned together, e.g. in a--- do or let .. in statement/expr-instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.ExprLStmt name] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsTupArg name) 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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsCmdTop name) where-  markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd--instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.HsCmd name) 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 _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--    -- TODO: This test assumes no auto-generated SrcSpans-    let isPrefixOp = case cs of-          [] -> True-          (GHC.L h _:_) -> GHC.getLoc e < h-    when isPrefixOp $ markWithString GHC.AnnOpen "(|"-    -- 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 $ markWithString GHC.AnnClose "|)"--  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 binds e) = do-    mark GHC.AnnLet-    markOptional GHC.AnnOpenC-    markLocalBindsWithLayout binds-    markOptional GHC.AnnCloseC-    mark GHC.AnnIn-    markLocated e--  markAST _ (GHC.HsCmdDo es _) = do-    mark GHC.AnnDo-    markOptional GHC.AnnOpenC-    markListWithLayout es-    markOptional GHC.AnnCloseC--  markAST _ GHC.HsCmdCast {} =-    traceM "warning: HsCmdCast introduced after renaming"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-     => Annotate (GHC.TyClDecl name) where--  markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi--  markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) 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 ln tyvars-    mark GHC.AnnEqual-    markLocated typ-    markTrailingSemi--  markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars)-                (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _) = do-    if nd == GHC.DataType-      then mark GHC.AnnData-      else mark GHC.AnnNewtype-    markMaybe mctyp-    when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow-    markLocated ctx-    markTyClass 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]) $ markMaybe mderivs-    markTrailingSemi--  -- -------------------------------------  markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds-                          sigs meths ats atdefs docs _) = do-    mark GHC.AnnClass-    markLocated ctx--    markTyClass 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---- -----------------------------------------------------------------------markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)-                => GHC.Located a -> [GHC.Located ast] -> Annotated ()-markTyClass ln tyVars = do-    markManyOptional GHC.AnnOpenP--    let-      parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2-      lnFun = do-        ifInContext (Set.singleton CtxMiddle)-                      (setContext (Set.singleton InfixOp) $ markLocated ln)-                      (markLocated ln)-      listFun b = do-        if parensNeeded-          then ifInContext (Set.singleton (CtxPos 0))-                      (markMany GHC.AnnOpenP)-                      (return ())-          else ifInContext (Set.singleton (CtxPos 0))-                      (markManyOptional GHC.AnnOpenP)-                      (return ())--        markLocated b--        if parensNeeded-          then ifInContext (Set.singleton (CtxPos 2))-                      (markMany GHC.AnnCloseP)-                      (return ())-          else ifInContext (Set.singleton (CtxPos 2))-                      (markManyOptional GHC.AnnCloseP)-                      (return ())--      prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls--    unsetContext CtxMiddle $-      applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp])-                                        (Set.singleton CtxMiddle) (Set.singleton CtxLast))-                               ([(GHC.getLoc ln,lnFun)]-                             ++ prepareListFun tyVars)-    markManyOptional GHC.AnnCloseP---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name)-   => Annotate (GHC.FamilyDecl name) where-  markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do-    case info of-      GHC.DataFamily -> mark GHC.AnnData-      _              -> mark GHC.AnnType--    mark GHC.AnnFamily--    markTyClass ln tyvars-    case mkind of-      Nothing -> return ()-      Just k -> do-        mark GHC.AnnDcolon-        markLocated k-    case info of-      GHC.ClosedTypeFamily eqns -> do-        mark GHC.AnnWhere-        markOptional GHC.AnnOpenC -- {-        markListWithLayout eqns-        markOptional GHC.AnnCloseC -- }-      _ -> return ()-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.TyFamInstEqn name) where-  markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do-    markTyClass ln pats-    -- let-    --   fun = ifInContext (Set.singleton (CtxPos 0))-    --             (setContext (Set.singleton PrefixOp) $ markLocated ln)-    --             (markLocated ln)-    -- markOptional GHC.AnnOpenP-    -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty)-    --                      ([(GHC.getLoc ln, fun)]-    --                      ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats)-    -- markOptional GHC.AnnCloseP-    mark GHC.AnnEqual-    markLocated typ---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.TyFamDefltEqn name) where-  markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do-    mark GHC.AnnType-    mark GHC.AnnInstance-    applyListAnnotations (prepareListAnnotation [ln]-                       ++ prepareListAnnotation bndrs-                         )-    mark GHC.AnnEqual-    markLocated typ---- ------------------------------------------------------------------------- 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 (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentPrev (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs-            (GHC.DocGroup _i (GHC.HsDocString fs))        -> GHC.unpackFS fs-    in-      markExternal l GHC.AnnVal str >> markTrailingSemi---- -----------------------------------------------------------------------markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated ()-markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do-  markLocated ctx-  markMaybe typ-  markMaybe _mk-  if isGadt cons-    then markListWithLayout cons-    else markListIntercalateWithFunLevel markLocated 2 cons-  case mderivs of-    Nothing -> return ()-    Just d -> setContext (Set.singleton Deriving) $ markLocated d---- ------------------------------------------------------------------------- Note: GHC.HsContext name aliases to here too-instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-     => Annotate [GHC.LHsType name] where-  markAST l ts = do-    inContext (Set.singleton Deriving) $ mark GHC.AnnDeriving-    -- Mote: A single item in parens in a deriving clause is parsed as a-    -- HsSigType, which is always a HsForAllTy. 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-          [_] -> markManyOptional pa-          _   -> markMany         pa--      parenIfNeeded'' pa =-        ifInContext (Set.singleton Parens)-          (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 (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-      => Annotate (GHC.ConDecl name) where-  markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx-                         dets res _ depc_syntax) = do-    case res of-      GHC.ResTyH98 -> do--        unless (null bndrs) $ do-          mark GHC.AnnForall-          mapM_ markLocated bndrs-          mark GHC.AnnDot--        unless (null $ GHC.unLoc ctx) $ do-          setContext (Set.fromList [NoDarrow]) $ markLocated ctx-          mark GHC.AnnDarrow-        case dets of-          GHC.InfixCon _ _ -> return ()-          _ -> setContext (Set.singleton PrefixOp) $ markListIntercalate lns--        markHsConDeclDetails False False lns dets--      GHC.ResTyGADT ls ty -> do-        -- only print names if not infix-        case dets of-          GHC.InfixCon _ _ -> return ()-          _ -> markListIntercalate lns--        if depc_syntax-          then do-            markHsConDeclDetails True False lns dets-            mark GHC.AnnCloseC-            mark GHC.AnnDcolon-            markManyOptional GHC.AnnOpenP--          else do-            mark GHC.AnnDcolon-            markLocated (GHC.L ls (ResTyGADTHook bndrs))-            markManyOptional GHC.AnnOpenP-            unless (null $ GHC.unLoc ctx) $ do-              markLocated ctx-            markHsConDeclDetails False True lns dets--        markLocated ty--        markManyOptional GHC.AnnCloseP---    case res of-      GHC.ResTyH98 -> inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar-      _  -> return ()-    markTrailingSemi---- ResTyGADT has a SrcSpan for the original sigtype, we need to create--- a type for exactPC and annotatePC-data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]-                   deriving (Typeable)-deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)-deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)--instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where-  ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs----- -----------------------------------------------------------------------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-      mark GHC.AnnDot---- -----------------------------------------------------------------------instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.HsRecField name (GHC.LPat name)) 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 name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) 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 (GHC.DataId name,Annotate name)-    => Annotate (GHC.FunDep (GHC.Located name)) 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-    case mh of-      Nothing -> return ()-      Just (GHC.Header h) ->-         markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"")-    markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"")-    markWithString GHC.AnnClose "#-}"---- ---------------------------------------------------------------------
− src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs 
@@ -1,2750 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook--- | '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 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.RdrName) 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => GHC.HsLocalBinds name -> 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.RdrName) 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 ls txt) lss) = do-    markExternal ls GHC.AnnOpen txt-    mark GHC.AnnOpenS-    markListIntercalate lss-    mark GHC.AnnCloseS-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do-    markExternal ls GHC.AnnOpen txt-    mark GHC.AnnOpenS-    markListIntercalate lss-    mark GHC.AnnCloseS-    markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance Annotate GHC.StringLiteral where-  markAST l (GHC.StringLiteral src _) = do-    markExternal l GHC.AnnVal src-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma---- -----------------------------------------------------------------------instance Annotate (GHC.SourceText,GHC.FastString) where-  markAST l (src,_fs) = do-    markExternal l GHC.AnnVal src---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.LIE name] 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 (GHC.DataId name,GHC.HasOccName name, Annotate name)-  => Annotate (GHC.IE name) where-  markAST _ ie = do--    case ie of-        (GHC.IEVar ln) -> do-          -- TODO: I am pretty sure this criterion is inadequate-          if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln-            then mark GHC.AnnPattern-            else markOptional GHC.AnnPattern-          setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln--        (GHC.IEThingAbs ln) -> do-          setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln--        (GHC.IEThingWith ln wc ns _lfs) -> do-          setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln-          mark GHC.AnnOpenP-          case wc of-            GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp,InIE])-                                 $ markListIntercalate ns-            GHC.IEWildcard n -> do-              setContext (Set.fromList [PrefixOp,Intercalate,InIE]) $ mapM_ markLocated (take n ns)-              mark GHC.AnnDotdot-              case drop n ns of-                [] -> return ()-                ns' -> do-                  mark GHC.AnnComma-                  setContext (Set.fromList [PrefixOp,InIE]) $ mapM_ markLocated ns'-          mark GHC.AnnCloseP--        (GHC.IEThingAll ln) -> do-          setContext (Set.fromList [PrefixOp,InIE]) $ 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 ()-    ifInContext (Set.fromList [Intercalate])-      (mark         GHC.AnnComma)-      (markOptional 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-      -- Horrible hack until GHC 8.2 with https://phabricator.haskell.org/D3016-      typeIESym = isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n)-                        && spanLength l - length str > 6 -- length of "type" + 2 parens-      canParen = isSym && rdrName2String n /= "$"-                       && (not typeIESym)-      doNormalRdrName = do-        let str' = case str of-              -- TODO: unicode support?-                        "forall" -> if spanLength l == 1 then "∀" else str-                        _ -> str-        -- when (isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n)) $ inContext (Set.singleton InIE) $ mark GHC.AnnType-        when (spanLength l - length str > 4) $ inContext (Set.singleton InIE) $ mark GHC.AnnType-        let str'' = if typeIESym then "(" ++ str' ++ ")"-                                 else 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--        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-                        else markExternal l GHC.AnnVal 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")---- ------------------------------------------------------------------------- TODO: What is this used for? Not in ExactPrint-instance Annotate GHC.Name where-  markAST l n = do-    markExternal l GHC.AnnVal (showGhc n)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.ImportDecl name) 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 "#-}"-   when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc)-             >> markWithString GHC.AnnClose "#-}")-   when safeflag (mark GHC.AnnSafe)-   when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)-   case mpkg of-    Nothing -> return ()-    Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg--   markLocated modname--   case GHC.ideclAs imp of-      Nothing -> return ()-      Just mn -> do-          mark GHC.AnnAs-          markWithString GHC.AnnVal (GHC.moduleNameString mn)--   case hiding of-     Nothing -> return ()-     Just (isHiding,lie) -> do-       if isHiding-         then setContext (Set.singleton HasHiding) $-                markLocated lie-         else markLocated lie-   markTrailingSemi---- -----------------------------------------------------------------------instance Annotate GHC.ModuleName where-   markAST l mname =-    markExternal l GHC.AnnVal (GHC.moduleNameString mname)---- -----------------------------------------------------------------------markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-            => GHC.LHsDecl name -> 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.VectD 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)--instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-            => Annotate (GHC.HsDecl name) where-  markAST l d = markLHsDecl (GHC.L l d)---- -----------------------------------------------------------------------instance (Annotate name)-   => Annotate (GHC.RoleAnnotDecl name) where-  markAST _ (GHC.RoleAnnotDecl ln mr) = do-    mark GHC.AnnType-    mark GHC.AnnRole-    markLocated ln-    mapM_ markLocated mr--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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.SpliceDecl name) where-  markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do-    setContext (Set.singleton InSpliceDecl) $ markLocated e-    markTrailingSemi-  markAST _ (GHC.SpliceDecl e flag) = do-    case flag of-      GHC.ExplicitSplice -> mark GHC.AnnOpenPE-      GHC.ImplicitSplice -> return ()--    setContext (Set.singleton InSpliceDecl) $ markLocated e--    case flag of-      GHC.ExplicitSplice -> mark GHC.AnnCloseP-      GHC.ImplicitSplice -> return ()--    markTrailingSemi--{--- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y)--                           ImplicitSplice   -- <=> f x y,  i.e. a naked--                           top level expression----}---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.VectDecl name) where-  markAST _ (GHC.HsVect src ln e) = do-    markWithString GHC.AnnOpen src -- "{-# VECTORISE"-    markLocated ln-    mark GHC.AnnEqual-    markLocated e-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsNoVect src ln) = do-    markWithString GHC.AnnOpen src -- "{-# NOVECTORISE"-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsVectTypeIn src _b ln mln) = do-    markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR"-    mark GHC.AnnType-    markLocated ln-    case mln of-      Nothing -> return ()-      Just lnn -> do-        mark GHC.AnnEqual-        markLocated lnn-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectTypeOut {} =-    traceM "warning: HsVectTypeOut appears after renaming"--  markAST _ (GHC.HsVectClassIn src ln) = do-    markWithString GHC.AnnOpen src -- "{-# VECTORISE"-    mark GHC.AnnClass-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectClassOut {} =-    traceM "warning: HsVecClassOut appears after renaming"-  markAST _ GHC.HsVectInstIn {}   =-    traceM "warning: HsVecInstsIn appears after renaming"-  markAST _ GHC.HsVectInstOut {}   =-    traceM "warning: HsVecInstOut appears after renaming"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.RuleDecls name) where-   markAST _ (GHC.HsRules src rules) = do-     markWithString GHC.AnnOpen src-     setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules-     markWithString GHC.AnnClose "#-}"-     markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.RuleDecl name) where-  markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do-    markLocated ln-    setContext (Set.singleton ExplicitNeverActive) $ markActivation 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---- -----------------------------------------------------------------------markActivation :: GHC.Activation -> Annotated ()-markActivation act = do-  case act of-    GHC.ActiveBefore src _ -> do-      mark GHC.AnnOpenS --  '['-      mark GHC.AnnTilde -- ~-      markWithString GHC.AnnVal src-      mark GHC.AnnCloseS -- ']'-    GHC.ActiveAfter src _ -> do-      mark GHC.AnnOpenS --  '['-      markWithString GHC.AnnVal src-      mark GHC.AnnCloseS -- ']'-    GHC.NeverActive -> do-      inContext (Set.singleton ExplicitNeverActive) $ do-        mark GHC.AnnOpenS --  '['-        mark GHC.AnnTilde -- ~-        mark GHC.AnnCloseS -- ']'-    _ -> return ()---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.RuleBndr name) 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 -- ")"---- -----------------------------------------------------------------------markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                 => GHC.LHsSigWcType name -> Annotated ()-markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do-    case mwc of-      Nothing -> markLocated ty-      Just lwc -> do-       applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")]-                          ++ prepareListAnnotation [ty]-                            )---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.AnnDecl name) where-   markAST _ (GHC.HsAnnotation src prov e) = do-     markWithString GHC.AnnOpen src-     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---- -----------------------------------------------------------------------instance Annotate name => Annotate (GHC.WarnDecls name) where-   markAST _ (GHC.Warnings src warns) = do-     markWithString GHC.AnnOpen src-     mapM_ markLocated warns-     markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance (Annotate name)-   => Annotate (GHC.WarnDecl name) 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 -- "]"--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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.ForeignDecl name) where-  markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _-               (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do-{--  = ForeignImport-      { fd_name   :: Located name          -- defines this name-      , fd_sig_ty :: LHsSigType name       -- sig_ty-      , fd_co     :: PostTc name Coercion  -- rep_ty ~ sig_ty-      , fd_fi     :: ForeignImport }---}-    mark GHC.AnnForeign-    mark GHC.AnnImport-    markLocated cconv-    unless (ll == GHC.noSrcSpan) $ markLocated safety-    if GHC.unLoc cconv == GHC.PrimCallConv-      then markExternal ls GHC.AnnVal src-#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1))-      else markExternal ls GHC.AnnVal src-#else-      else markExternal ls GHC.AnnVal (show src)-#endif-    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 (show src)-    setContext (Set.singleton PrefixOp) $ markLocated ln-    mark GHC.AnnDcolon-    markLocated typ----- -----------------------------------------------------------------------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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.DerivDecl name) where--  markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do-    mark GHC.AnnDeriving-    mark GHC.AnnInstance-    markMaybe mov-    markLocated typ-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.DefaultDecl name) where--  markAST _ (GHC.DefaultDecl typs) = do-    mark GHC.AnnDefault-    mark GHC.AnnOpenP -- '('-    markListIntercalate typs-    mark GHC.AnnCloseP -- ')'-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.InstDecl name) 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---- -----------------------------------------------------------------------instance Annotate GHC.OverlapMode where-  markAST _ (GHC.NoOverlap src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Overlappable src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Overlapping src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Overlaps src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"--  markAST _ (GHC.Incoherent src) = do-    markWithString GHC.AnnOpen src-    markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.ClsInstDecl name) where--  markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do-    mark GHC.AnnInstance-    markMaybe mov-    markLocated poly-    if null (GHC.bagToList binds) && null sigs && null tyfams && null datafams-      then markOptional GHC.AnnWhere-      else do-        mark GHC.AnnWhere-        markOptional GHC.AnnOpenC -- '{'-        markInside GHC.AnnSemi--        applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds)-                                 ++ prepareListAnnotation sigs-                                 ++ prepareListAnnotation tyfams-                                 ++ prepareListAnnotation datafams-                                   )--        markOptional GHC.AnnCloseC -- '}'-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.TyFamInstDecl name) where--  markAST _ (GHC.TyFamInstDecl eqn _) = do-    mark GHC.AnnType-    inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional-    markLocated eqn-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.DataFamInstDecl name) where--  markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats)-             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-    inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance--    markLocated ctx--    markTyClass 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 nd (GHC.noLoc []) typ _mk cons mderivs)-    markTrailingSemi---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsBind name) 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)) _typ _fvs _ticks) = do-    markLocated lhs-    case grhs of-      (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards-      _ -> return ()-    markListIntercalateWithFunLevel markLocated 2 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.VarBind _n rhse _) =-    -- Note: this bind is introduced by the typechecker-    markLocated rhse--  markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do-    mark GHC.AnnPattern-    case args of-      GHC.InfixPatSyn la lb -> do-        markLocated la-        setContext (Set.singleton InfixOp) $ markLocated ln-        markLocated lb-      GHC.PrefixPatSyn ns -> do-        markLocated ln-        mapM_ markLocated ns-      GHC.RecordPatSyn 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--  -- Introduced after renaming.-  markAST _ (GHC.AbsBinds _ _ _ _ _) =-    traceM "warning: AbsBinds introduced after renaming"--  -- Introduced after renaming.-  markAST _ GHC.AbsBindsSig{} =-    traceM "warning: AbsBindsSig introduced after renaming"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-    => Annotate (GHC.IPBind name) where-  markAST _ (GHC.IPBind en e) = do-    case en of-      Left n -> markLocated n-      Right _i -> return ()-    mark GHC.AnnEqual-    markLocated e-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate GHC.HsIPName where-  markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,-                                                  Annotate body)-  => Annotate (GHC.Match name (GHC.Located body)) where--  markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do-    let-      get_infix GHC.NonFunBindMatch    = False-      get_infix (GHC.FunBindMatch _ f) = f-      isFunBind GHC.NonFunBindMatch = False-      isFunBind GHC.FunBindMatch{}  = True-    case (get_infix mln,pats) of-      (True, a:b:xs) -> do-        if null xs-          then markOptional GHC.AnnOpenP-          else mark         GHC.AnnOpenP-        markLocated a-        case mln of-          GHC.NonFunBindMatch -> return ()-          GHC.FunBindMatch n _ -> setContext (Set.singleton InfixOp) $ markLocated n-        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.NonFunBindMatch  -> mark GHC.AnnFunId-          GHC.NonFunBindMatch  -> markListNoPrecedingSpace False pats-          GHC.FunBindMatch n _ -> do-            -- setContext (Set.singleton NoPrecedingSpace) $ markLocated n-            setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n-            mapM_ markLocated 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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,-          Annotate name, Annotate body)-  => Annotate (GHC.GRHS name (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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.Sig name) 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 ln (GHC.HsIB _ typ)) = do-    mark GHC.AnnPattern-    markLocated ln-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi--  markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ)) = do-    when isDefault $ mark GHC.AnnDefault-    -- markListIntercalate ns-    setContext (Set.singleton PrefixOp) $ markListIntercalate ns-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi--  markAST _ (GHC.IdSig _) =-    traceM "warning: Introduced after renaming"--  -- FixSig (FixitySig name)-  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-    markWithString GHC.AnnVal src-    setContext (Set.singleton InfixOp) $ markListIntercalate lns-    markTrailingSemi--  -- InlineSig (Located name) InlinePragma-  -- '{-# INLINE' activation qvar '#-}'-  markAST _ (GHC.InlineSig ln inl) = do-    markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE'-    markActivation (GHC.inl_act inl)-    setContext (Set.singleton PrefixOp) $ markLocated ln-    markWithString GHC.AnnClose "#-}" -- '#-}'-    markTrailingSemi--  markAST _ (GHC.SpecSig ln typs inl) = do-{--  | SpecSig     (Located name)     -- Specialise a function or datatype  ...-                [LHsSigType name]  -- ... to these types-                InlinePragma       -- The pragma on SPECIALISE_INLINE form.-                                   -- If it's just defaultInlinePragma, then we said-                                   --    SPECIALISE, not SPECIALISE_INLINE---}-    markWithString GHC.AnnOpen (GHC.inl_src inl)-    markActivation (GHC.inl_act inl)-    markLocated ln-    mark GHC.AnnDcolon -- '::'-    markListIntercalateWithFunLevel markLHsSigType 2 typs-    markWithString GHC.AnnClose "#-}" -- '#-}'-    markTrailingSemi---  -- '{-# SPECIALISE' 'instance' inst_type '#-}'-  markAST _ (GHC.SpecInstSig src typ) = do-    markWithString GHC.AnnOpen src-    mark GHC.AnnInstance-    markLHsSigType typ-    markWithString GHC.AnnClose "#-}" -- '#-}'-    markTrailingSemi----  -- MinimalSig (BooleanFormula (Located name))-  markAST _l (GHC.MinimalSig src formula) = do-    markWithString GHC.AnnOpen src-    markLocated formula-    markWithString GHC.AnnClose "#-}"-    markTrailingSemi---- ----------------------------------------------------------------------markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-               => GHC.LHsSigType name -> Annotated ()-markLHsSigType (GHC.HsIB _ typ) = markLocated typ--instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate [GHC.LHsSigType name] where-  markAST _ 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.-    case ls of-      []  -> markManyOptional GHC.AnnOpenP-      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnOpenP-      [_] -> markManyOptional GHC.AnnOpenP-      _   -> markMany         GHC.AnnOpenP-    markListIntercalateWithFun markLHsSigType ls-    case ls of-      []  -> markManyOptional GHC.AnnCloseP-      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnCloseP-      [_] -> markManyOptional GHC.AnnCloseP-      _   -> markMany         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 l (GHC.Or ls)  = mapM_ markLocated ls-  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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsTyVarBndr name) 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 -- '('---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.HsType name) where-  markAST loc ty = do-    markType loc ty-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma-   where--    -- markType :: GHC.SrcSpan -> ast -> Annotated ()-    markType _ (GHC.HsForAllTy tvs typ) = do-      mark GHC.AnnForall-      mapM_ markLocated tvs-      mark GHC.AnnDot-      markLocated typ--  {--    = HsForAllTy   -- See Note [HsType binders]-        { hst_bndrs :: [LHsTyVarBndr name]   -- Explicit, user-supplied 'forall a b c'-        , hst_body  :: LHsType name          -- body type-        }--  -}--    markType _ (GHC.HsQualTy cxt typ) = do-      markLocated cxt-      markLocated typ-  {--    | HsQualTy   -- See Note [HsType binders]-        { hst_ctxt :: LHsContext name       -- Context C => blah-        , hst_body :: LHsType name }-  -}--    markType _l (GHC.HsTyVar name) = do-      -- TODO: Should the isExactName test move into the RdrName Annotate instanced?-      if ((GHC.isDataOcc $ GHC.occName $ GHC.unLoc name) && ((not $ isExactName $ GHC.unLoc name)))-                   || (showGhc name == "()")-        then do-            mark GHC.AnnSimpleQuote-            markLocatedFromKw GHC.AnnName name-        else markLocated name--    markType _ (GHC.HsAppsTy ts) = do-      mapM_ markLocated ts--    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--    markType _ (GHC.HsListTy t) = do-      mark GHC.AnnOpenS -- '['-      markLocated t-      mark GHC.AnnCloseS -- ']'--    markType _ (GHC.HsPArrTy t) = do-      markWithString GHC.AnnOpen "[:" -- '[:'-      markLocated t-      markWithString GHC.AnnClose ":]" -- ':]'--    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.HsOpTy t1 lo t2) = do-    -- HsOpTy              (LHsType name) (Located name) (LHsType name)-      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 (GHC.HsIPName n) t) = do-      markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n))-      mark GHC.AnnDcolon-      markLocated t--    markType _ (GHC.HsEqTy t1 t2) = do-      markLocated t1-      mark GHC.AnnTilde-      markLocated t2--    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-        Nothing -> return ()-        Just 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-  {--    | HsBangTy    HsSrcBang (LHsType name)   -- Bang-style type annotations-  data HsSrcBang =-    HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes-              SrcUnpackedness-              SrcStrictness-  data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'-                     | SrcStrict -- ^ Strict, ie '!'-                     | NoSrcStrict -- ^ no strictness annotation--  data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified-                       | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified-                       | NoSrcUnpack -- ^ no unpack pragma--  -}--    markType _ (GHC.HsRecTy cons) = do-      mark GHC.AnnOpenC  -- '{'-      markListIntercalate cons-      mark GHC.AnnCloseC -- '}'--    -- HsCoreTy Type-    markType _ (GHC.HsCoreTy _t) =-      traceM "warning: HsCoreTy Introduced after renaming"--    markType _ (GHC.HsExplicitListTy _ ts) = do-      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--    -- HsTyLit HsTyLit-    markType l (GHC.HsTyLit lit) = do-      case lit of-        (GHC.HsNumTy s _) ->-          markExternal l GHC.AnnVal s-        (GHC.HsStrTy s _) ->-          markExternal l GHC.AnnVal s--    -- HsWrapTy HsTyAnnotated (HsType name)--    markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do-      markExternal l GHC.AnnVal "_"----- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsAppType name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsSplice name) where-  markAST l c =-    case c of-      GHC.HsQuasiQuote _ n _pos fs -> do-        markExternal l GHC.AnnVal-              ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")--      GHC.HsTypedSplice _n (GHC.L _ (GHC.HsVar (GHC.L _ n)))  -> do-        markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))-      GHC.HsTypedSplice _n b -> do-        mark GHC.AnnOpenPTE-        markLocated b-        mark GHC.AnnCloseP--      GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n)))  -> do-        ifInContext (Set.singleton InSpliceDecl)-          (return ())-          (mark GHC.AnnOpenPE)-        -- TODO: We do not seem to have any way to distinguish between which of-        -- the next two lines will emit output. If AnnThIdSplice is there, the-        -- markLocated b ends up with a negative offset so emits nothing.-        markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))-        markLocated b-        ifInContext (Set.singleton InSpliceDecl)-          (return ())-          (mark GHC.AnnCloseP)-      GHC.HsUntypedSplice _n b  -> do-        -- TODO: when is this not optional?-        markOptional GHC.AnnThIdSplice-        ifInContext (Set.singleton InSpliceDecl)-          (return ())-          (mark GHC.AnnOpenPE)-        markLocated b-        ifInContext (Set.singleton InSpliceDecl)-          (return ())-          (mark GHC.AnnCloseP)-#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1))-      GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC"-#endif---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) =>-                             Annotate (GHC.ConDeclField name) where-  markAST _ (GHC.ConDeclField ns ty mdoc) = do-{--data ConDeclField name  -- Record fields have Haddoc docs on them-  = ConDeclField { cd_fld_names :: [LFieldOcc name],-                                   -- ^ See Note [ConDeclField names]-                   cd_fld_type :: LBangType name,-                   cd_fld_doc  :: Maybe LHsDocString }---}-    unsetContext Intercalate $ do-      markListIntercalate ns-      mark GHC.AnnDcolon-      markLocated ty-      markMaybe mdoc-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma---- -----------------------------------------------------------------------instance (GHC.DataId name)-      => Annotate (GHC.FieldOcc name) where-  markAST _ (GHC.FieldOcc rn _) = do-    markLocated rn-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma---- -----------------------------------------------------------------------instance Annotate GHC.HsDocString where-  markAST l (GHC.HsDocString s) = do-    markExternal l GHC.AnnVal (GHC.unpackFS s)---- ----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.Pat name) 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.PArrPat ps _) = do-        markWithString GHC.AnnOpen "[:"-        mapM_ markLocated ps-        markWithString GHC.AnnClose ":]"--      markPat _ (GHC.ConPatIn n dets) = do-        markHsConPatDetails n dets--      markPat _ GHC.ConPatOut {} =-        traceM "warning: ConPatOut Introduced after renaming"--      -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type)-      markPat _ (GHC.ViewPat e pat _) = do-        markLocated e-        mark GHC.AnnRarrow-        markLocated pat--      -- SplicePat (HsSplice id)-      markPat l (GHC.SplicePat s) = do-        markAST l s--      -- LitPat HsLit-      markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp)--      -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id)-      markPat _ (GHC.NPat ol mn _ _) = do-        -- markOptional GHC.AnnMinus-        when (isJust mn) $ mark GHC.AnnMinus-        markLocated ol--      -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id)-      markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do-        markLocated ln-        markWithString GHC.AnnVal "+"  -- "+"-        markLocated ol---      markPat _ (GHC.SigPatIn pat ty) = do-        markLocated pat-        mark GHC.AnnDcolon-        markLHsSigWcType ty--      markPat _ GHC.SigPatOut {} =-        traceM "warning: SigPatOut introduced after renaming"--      -- CoPat HsAnnotated (Pat id) Type-      markPat _ GHC.CoPat {} =-        traceM "warning: CoPat introduced after renaming"---- ----------------------------------------------------------------------hsLit2String :: GHC.HsLit -> GHC.SourceText-hsLit2String lit =-  case lit of-    GHC.HsChar       src _   -> src-    -- It should be included here-    -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471-    GHC.HsCharPrim   src _   -> src ++ "#"-    GHC.HsString     src _   -> src-    GHC.HsStringPrim src _   -> src-    GHC.HsInt        src _   -> src-    GHC.HsIntPrim    src _   -> src-    GHC.HsWordPrim   src _   -> src-    GHC.HsInt64Prim  src _   -> src-    GHC.HsWord64Prim src _   -> src-    GHC.HsInteger    src _ _ -> src-    GHC.HsRat        (GHC.FL src _) _ -> src-    GHC.HsFloatPrim  (GHC.FL src _)   -> src ++ "#"-    GHC.HsDoublePrim (GHC.FL src _)   -> src ++ "##"--markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                      => GHC.Located name -> GHC.HsConPatDetails name -> Annotated ()-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-      setContext (Set.singleton InfixOp) $ markLocated ln-      markLocated a2--markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                    => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated ()--markHsConDeclDetails isDeprecated inGadt lns dets = do-  case dets of-    GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args-    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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate [GHC.LConDeclField name] 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 (GHC.DataId name) => Annotate (GHC.HsOverLit name) where-  markAST l ol =-    let str = case GHC.ol_val ol of-                GHC.HsIntegral src _ -> src-                GHC.HsFractional l2  -> GHC.fl_text l2-                GHC.HsIsString src _ -> src-    in-    markExternal l GHC.AnnVal str---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate arg)-    => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where-  markAST _ (GHC.HsIB _ thing) = do-    markLocated thing---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name-         ,GHC.HasOccName name,Annotate body)-  => Annotate (GHC.Stmt name (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---- ------------------------------------------------------------------------- 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  (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  =>  Annotate (GHC.ParStmtBlock name name) where-  markAST _ (GHC.ParStmtBlock stmts _ns _) = do-    markListIntercalate stmts---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsLocalBinds name) where-  markAST _ lb = markHsLocalBinds lb---- -----------------------------------------------------------------------markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-                     => GHC.HsLocalBinds name -> Annotated ()-markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =-    applyListAnnotationsLayout-       (prepareListAnnotation (GHC.bagToList binds)-     ++ prepareListAnnotation sigs-       )-markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {})-   = traceM "warning: ValBindsOut introduced after renaming"--markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds)-markHsLocalBinds GHC.EmptyLocalBinds                   = return ()---- -----------------------------------------------------------------------markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,-                                               Annotate body)-                   => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body)-                   -> Annotated ()-markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _)-  = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,-                                               Annotate body)-  => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsExpr name) 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 (GHC.HsIPName v))         =-        markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v)-      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-        -- markLocated e1-        setContext (Set.singleton PrefixOp) $ markLocated e1-        -- markLocated e2-        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 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 case cts of-                       GHC.PArrComp -> ("[:",":]")-                       _            -> ("[",  "]")-                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.ExplicitPArr _ es)   = do-        markWithString GHC.AnnOpen "[:"-        markListIntercalate es-        markWithString GHC.AnnClose ":]"--      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 _cons _ _ _) = do-        markLocated e-        mark GHC.AnnOpenC-        markListIntercalate fs-        mark GHC.AnnCloseC--      markExpr _ (GHC.ExprWithTySig e typ) = do-        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e-        mark GHC.AnnDcolon-        markLHsSigWcType typ--      markExpr _ (GHC.ExprWithTySigOut e typ) = do-        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.PArrSeq _ seqInfo) = do-        markWithString GHC.AnnOpen "[:" -- '[:'-        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-        markWithString GHC.AnnClose ":]" -- ':]'--      markExpr _ (GHC.HsSCC src csFStr e) = do-        markWithString GHC.AnnOpen src -- "{-# SCC"-        markWithStringOptional GHC.AnnVal (GHC.sl_st csFStr)-        markWithString GHC.AnnValStr (GHC.sl_st csFStr)-        markWithString GHC.AnnClose "#-}"-        markLocated e--      markExpr _ (GHC.HsCoreAnn src csFStr e) = do-        markWithString GHC.AnnOpen src -- "{-# CORE"-        markWithString GHC.AnnVal (GHC.sl_st 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-        markWithString GHC.AnnClose "|]"-      -- Introduced after the renamer-      markExpr _ (GHC.HsBracket (GHC.DecBrG _)) =-        traceM "warning: DecBrG introduced after renamer"-      markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do-        markWithString GHC.AnnOpen "[|"-        markOptional GHC.AnnOpenE  -- "[e|"-        markLocated e-        markWithString GHC.AnnClose "|]"-      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-        markWithString GHC.AnnClose "|]"-      markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do-        markWithString GHC.AnnOpen  "[p|"-        markLocated e-        markWithString GHC.AnnClose "|]"--      markExpr _ (GHC.HsRnBracketOut _ _) =-        traceM "warning: HsRnBracketOut introduced after renamer"-      markExpr _ (GHC.HsTcBracketOut _ _) =-        traceM "warning: HsTcBracketOut introduced after renamer"--      -- ----------------------------------      -- markExpr l (GHC.HsSpliceE e@(GHC.HsUntypedSplice _ (GHC.L _ (GHC.HsSpliceE{})))) = do-      --   mark GHC.AnnOpenPE-      --   markAST l e-      --   mark GHC.AnnCloseP-      markExpr l (GHC.HsSpliceE e) = do-        markOptional GHC.AnnOpenPE-        markAST l e-        markOptional GHC.AnnCloseP--      -- ----------------------------------      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.AnnOpen "(|"-        markLocated e-        mapM_ markLocated cs-        markWithString GHC.AnnClose "|)"--      markExpr _ (GHC.HsTick _ _) = return ()-      markExpr _ (GHC.HsBinTick _ _ _) = return ()--      markExpr _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do-        -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'-        markWithString       GHC.AnnOpen  src-        markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING-        markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER-        markOffset GHC.AnnColon 0 -- ':'-        markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER-        mark   GHC.AnnMinus   -- '-'-        markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER-        markOffset GHC.AnnColon 1 -- ':'-        markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER-        markWithString   GHC.AnnClose  "#-}"-        markLocated e--      markExpr l GHC.EWildPat = do-        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 e ty) = do-        markLocated e-        markInstead GHC.AnnAt AnnTypeApp-        markLHsWcType ty-      markExpr _ (GHC.HsAppTypeOut _ _) =-        traceM "warning: HsAppTypeOut introduced after renaming"--      markExpr _ (GHC.HsWrap _ _) =-        traceM "warning: HsWrap introduced after renaming"-      markExpr _ (GHC.HsUnboundVar _) =-        traceM "warning: HsUnboundVar introduced after renaming"----- -----------------------------------------------------------------------markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-              => GHC.LHsWcType name -> Annotated ()-markLHsWcType (GHC.HsWC _ mwc ty) = do-  case mwc of-    Nothing -> markLocated ty-    Just lwc -> do-     -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty])-     -- markLocated (GHC.L lc sorted)-     applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")]-                        ++ prepareListAnnotation [ty]-                          )---- -----------------------------------------------------------------------instance Annotate GHC.HsLit where-  markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsRecUpdField name) 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-{--type HsRecUpdField id     = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)---- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',------ For details on above see note [Api annotations] in ApiAnnotation-data HsRecField' id arg = HsRecField {-        hsRecFieldLbl :: Located id,-        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning-        hsRecPun      :: Bool           -- ^ Note [Punning]-  } deriving (Data, Typeable)---}--instance (GHC.DataId name)-  => Annotate (GHC.AmbiguousFieldOcc name) where-  markAST _ (GHC.Unambiguous n _) = markLocated n-  markAST _ (GHC.Ambiguous   n _) = markLocated n---- ------------------------------------------------------------------------- |Used for declarations that need to be aligned together, e.g. in a--- do or let .. in statement/expr-instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.ExprLStmt name] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsTupArg name) 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---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsCmdTop name) where-  markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd--instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-   => Annotate (GHC.HsCmd name) 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 _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--    -- TODO: This test assumes no auto-generated SrcSpans-    let isPrefixOp = case cs of-          [] -> True-          (GHC.L h _:_) -> GHC.getLoc e < h-    when isPrefixOp $ markWithString GHC.AnnOpen "(|"-    -- 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 $ markWithString GHC.AnnClose "|)"--  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"-{--  | HsCmdWrap   HsWrapper-                (HsCmd id)     -- If   cmd :: arg1 --> res-                               --      wrap :: arg1 "->" arg2-                               -- Then (HsCmdWrap wrap cmd) :: arg2 --> res--}---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-     => Annotate (GHC.TyClDecl name) where--  markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi--  markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) 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 ln tyvars-    mark GHC.AnnEqual-    markLocated typ-    markTrailingSemi--  markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _)-                (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _ _) = do-    if nd == GHC.DataType-      then mark GHC.AnnData-      else mark GHC.AnnNewtype-    markMaybe mctyp-    when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow-    markLocated ctx-    markTyClass 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]) $ markMaybe mderivs-    markTrailingSemi--  -- -------------------------------------  markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds-                          sigs meths ats atdefs docs _) = do-    mark GHC.AnnClass-    markLocated ctx--    markTyClass 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---- -----------------------------------------------------------------------markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)-                => GHC.Located a -> [GHC.Located ast] -> Annotated ()-markTyClass ln tyVars = do-    markManyOptional GHC.AnnOpenP--    let-      parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2-      lnFun = do-        ifInContext (Set.singleton CtxMiddle)-                      (setContext (Set.singleton InfixOp) $ markLocated ln)-                      (markLocated ln)-      listFun b = do-        if parensNeeded-          then ifInContext (Set.singleton (CtxPos 0))-                      (markMany GHC.AnnOpenP)-                      (return ())-          else ifInContext (Set.singleton (CtxPos 0))-                      (markManyOptional GHC.AnnOpenP)-                      (return ())--        markLocated b--        if parensNeeded-          then ifInContext (Set.singleton (CtxPos 2))-                      (markMany GHC.AnnCloseP)-                      (return ())-          else ifInContext (Set.singleton (CtxPos 2))-                      (markManyOptional GHC.AnnCloseP)-                      (return ())--      prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls--    unsetContext CtxMiddle $-      applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp])-                                        (Set.singleton CtxMiddle) (Set.singleton CtxLast))-                               ([(GHC.getLoc ln,lnFun)]-                             ++ prepareListFun tyVars)-    markManyOptional GHC.AnnCloseP---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name)-   => Annotate (GHC.FamilyDecl name) where-  markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do-{--data FamilyDecl name = FamilyDecl-  { fdInfo           :: FamilyInfo name              -- type/data, closed/open-  , fdLName          :: Located name                 -- type constructor-  , fdTyVars         :: LHsQTyVars name              -- type variables-  , fdResultSig      :: LFamilyResultSig name        -- result signature-  , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann-  }--}-    case info of-      GHC.DataFamily -> mark GHC.AnnData-      _              -> mark GHC.AnnType--    -- ifInContext (Set.singleton InClassDecl) (return ()) (mark GHC.AnnFamily)-    mark GHC.AnnFamily--    markTyClass 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-    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---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.FamilyResultSig name) where-  markAST _ (GHC.NoSig)        = return ()-  markAST _ (GHC.KindSig k)    = markLocated k-  markAST _ (GHC.TyVarSig ltv) = markLocated ltv---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name)-  => Annotate (GHC.InjectivityAnn name) where-  markAST _ (GHC.InjectivityAnn ln lns) = do-    markLocated ln-    mark GHC.AnnRarrow-    mapM_ markLocated lns---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.TyFamInstEqn name) where-  markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do-    markTyClass ln pats-    -- let-    --   fun = ifInContext (Set.singleton (CtxPos 0))-    --             (setContext (Set.singleton PrefixOp) $ markLocated ln)-    --             (markLocated ln)-    -- markOptional GHC.AnnOpenP-    -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty)-    --                      ([(GHC.getLoc ln, fun)]-    --                      ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats)-    -- markOptional GHC.AnnCloseP-    mark GHC.AnnEqual-    markLocated typ---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.TyFamDefltEqn name) where-  markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do-    mark GHC.AnnType-    mark GHC.AnnInstance-    applyListAnnotations (prepareListAnnotation [ln]-                       ++ prepareListAnnotation bndrs-                         )-    mark GHC.AnnEqual-    markLocated typ---- ------------------------------------------------------------------------- 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 (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentPrev (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs-            (GHC.DocGroup _i (GHC.HsDocString fs))        -> GHC.unpackFS fs-    in-      markExternal l GHC.AnnVal str >> markTrailingSemi---- -----------------------------------------------------------------------markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated ()-markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do-  markLocated ctx-  markMaybe typ-  if isGadt cons-    then markListWithLayout cons-    else markListIntercalateWithFunLevel markLocated 2 cons-  case mderivs of-    Nothing -> return ()-    Just d -> setContext (Set.singleton Deriving) $ markLocated d---- ------------------------------------------------------------------------- Note: GHC.HsContext name aliases to here too-instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-     => Annotate [GHC.LHsType name] where-  markAST l ts = do-    -- Mote: A single item in parens in a deriving clause is parsed as a-    -- HsSigType, which is always a HsForAllTy. 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-          [_] -> markManyOptional pa-          _   -> markMany         pa--      parenIfNeeded'' pa =-        ifInContext (Set.singleton Parens)-          (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 (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)-      => Annotate (GHC.ConDecl name) where-  markAST _ (GHC.ConDeclH98 ln mqtvs mctx-                         dets _ ) = do-{--  | ConDeclH98-      { con_name    :: Located name--      , con_qvars     :: Maybe (LHsQTyVars name)-        -- User-written forall (if any), and its implicit-        -- kind variables-        -- Non-Nothing needs -XExistentialQuantification-        --               e.g. data T a = forall b. MkT b (b->a)-        --               con_qvars = {b}--      , con_cxt       :: Maybe (LHsContext name)-        -- ^ User-written context (if any)--      , con_details   :: HsConDeclDetails name-          -- ^ Arguments--      , con_doc       :: Maybe LHsDocString-          -- ^ A possible Haddock comment.---}-    case mqtvs of-      Nothing -> return ()-      Just (GHC.HsQTvs _ns 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-  markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do-    setContext (Set.singleton PrefixOp) $ markListIntercalate lns-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi---- ResTyGADT has a SrcSpan for the original sigtype, we need to create--- a type for exactPC and annotatePC-data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]-                   deriving (Typeable)-deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)-deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)--instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where-  ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (ResTyGADTHook name) where-  markAST _ (ResTyGADTHook bndrs) = do-    unless (null bndrs) $ do-      mark GHC.AnnForall-      mapM_ markLocated bndrs-      mark GHC.AnnDot---- -----------------------------------------------------------------------instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.HsRecField name (GHC.LPat name)) 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 name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)-  => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) 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 (GHC.DataId name,Annotate name)-    => Annotate (GHC.FunDep (GHC.Located name)) 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-    case mh of-      Nothing -> return ()-      Just (GHC.Header srcH _h) ->-         markWithString GHC.AnnHeader srcH-    markWithString GHC.AnnVal (fst f)-    markWithString GHC.AnnClose "#-}"---- ---------------------------------------------------------------------
− src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs 
@@ -1,2662 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook--- | '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 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.RdrName) 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.RdrName -> 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.RdrName) 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-    -- markExternal ls GHC.AnnOpen txt-    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 (GHC.DataId name,GHC.HasOccName name,Annotate name)-  => Annotate [GHC.LIE name] 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 (GHC.DataId name,GHC.HasOccName name, Annotate name)-  => Annotate (GHC.IE name) 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-                  setContext (Set.singleton PrefixOp) $ mapM_ markLocated 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 ()-    ifInContext (Set.fromList [Intercalate])-      (mark         GHC.AnnComma)-      (markOptional GHC.AnnComma)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.HasOccName name, Annotate name)-  => Annotate (GHC.IEWrappedName name) 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-{--data IEWrappedName name-  = IEName    (Located name)  -- ^ no extra-  | IEPattern (Located name)  -- ^ pattern X-  | IEType    (Located name)  -- ^ type (:+:)-  deriving (Eq,Data)---}--- ----------------------------------------------------------------------{---- For details on above see note [Api annotations] in ApiAnnotation-data RdrName-  = Unqual OccName-        -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.-        -- Create such a 'RdrName' with 'mkRdrUnqual'--  | Qual ModuleName OccName-        -- ^ A qualified name written by the user in-        -- /source/ code.  The module isn't necessarily-        -- the module where the thing is defined;-        -- just the one from which it is imported.-        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.-        -- Create such a 'RdrName' with 'mkRdrQual'--  | Orig Module OccName-        -- ^ An original name; the module is the /defining/ module.-        -- This is used when GHC generates code that will be fed-        -- into the renamer (e.g. from deriving clauses), but where-        -- we want to say \"Use Prelude.map dammit\". One of these-        -- can be created with 'mkOrig'--  | Exact Name-        -- ^ We know exactly the 'Name'. This is used:-        ---        --  (1) When the parser parses built-in syntax like @[]@-        --      and @(,)@, but wants a 'RdrName' from it-        ---        --  (2) By Template Haskell, when TH has generated a unique name-        ---        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'-  deriving (Data, Typeable)--}--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 && rdrName2String n /= "$"-      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--        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-                        else markExternal l GHC.AnnVal 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")---- ------------------------------------------------------------------------- TODO: What is this used for? Not in ExactPrint-instance Annotate GHC.Name where-  markAST l n = do-    markExternal l GHC.AnnVal (showGhc n)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.ImportDecl name) 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---- -----------------------------------------------------------------------instance Annotate GHC.ModuleName where-   markAST l mname =-    markExternal l GHC.AnnVal (GHC.moduleNameString mname)---- -----------------------------------------------------------------------markLHsDecl :: GHC.LHsDecl GHC.RdrName -> 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.VectD 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)--instance Annotate (GHC.HsDecl GHC.RdrName) where-  markAST l d = markLHsDecl (GHC.L l d)---- -----------------------------------------------------------------------instance (Annotate name)-   => Annotate (GHC.RoleAnnotDecl name) where-  markAST _ (GHC.RoleAnnotDecl ln mr) = do-    mark GHC.AnnType-    mark GHC.AnnRole-    markLocated ln-    mapM_ markLocated mr--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.RdrName) where-  markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do-    markLocated e-    markTrailingSemi-  markAST _ (GHC.SpliceDecl e _flag) = do-    markLocated e-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate (GHC.VectDecl GHC.RdrName) where-  markAST _ (GHC.HsVect src ln e) = do-    markAnnOpen src "{-# VECTORISE"-    markLocated ln-    mark GHC.AnnEqual-    markLocated e-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsNoVect src ln) = do-    markAnnOpen src "{-# NOVECTORISE"-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsVectTypeIn src _b ln mln) = do-    markAnnOpen src  "{-# VECTORISE"  -- or "{-# VECTORISE SCALAR"-    mark GHC.AnnType-    markLocated ln-    case mln of-      Nothing -> return ()-      Just lnn -> do-        mark GHC.AnnEqual-        markLocated lnn-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectTypeOut {} =-    traceM "warning: HsVectTypeOut appears after renaming"--  markAST _ (GHC.HsVectClassIn src ln) = do-    markAnnOpen src "{-# VECTORISE"-    mark GHC.AnnClass-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectClassOut {} =-    traceM "warning: HsVecClassOut appears after renaming"-  markAST _ GHC.HsVectInstIn {}   =-    traceM "warning: HsVecInstsIn appears after renaming"-  markAST _ GHC.HsVectInstOut {}   =-    traceM "warning: HsVecInstOut appears after renaming"---- -----------------------------------------------------------------------instance Annotate (GHC.RuleDecls GHC.RdrName) where-   markAST _ (GHC.HsRules src rules) = do-     markAnnOpen src "{-# RULES"-     setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules-     markWithString GHC.AnnClose "#-}"-     markTrailingSemi---- -----------------------------------------------------------------------instance Annotate (GHC.RuleDecl GHC.RdrName) 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---- -----------------------------------------------------------------------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.RdrName) 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 -- ")"---- -----------------------------------------------------------------------markLHsSigWcType :: GHC.LHsSigWcType GHC.RdrName -> Annotated ()-markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do-  markLocated ty---- -----------------------------------------------------------------------instance Annotate (GHC.AnnDecl GHC.RdrName) 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---- -----------------------------------------------------------------------instance Annotate name => Annotate (GHC.WarnDecls name) where-   markAST _ (GHC.Warnings src warns) = do-     markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED-     mapM_ markLocated warns-     markWithString GHC.AnnClose "#-}"---- -----------------------------------------------------------------------instance (Annotate name)-   => Annotate (GHC.WarnDecl name) 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 -- "]"--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.RdrName) 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----- -----------------------------------------------------------------------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.RdrName) where--  markAST _ (GHC.DerivDecl typ ms mov) = do-    mark GHC.AnnDeriving-    markMaybe ms-    mark GHC.AnnInstance-    markMaybe mov-    markLHsSigType typ-    markTrailingSemi-{--stand_alone_deriving :: { LDerivDecl RdrName }-  : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type-                {% do { let { err = text "in the stand-alone deriving instance"-                                    <> colon <+> quotes (ppr $5) }-                      ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))-                            [mj AnnDeriving $1, mj AnnInstance $3] } }--data DerivDecl name = DerivDecl-        { deriv_type         :: LHsSigType name-        , deriv_strategy     :: Maybe (Located DerivStrategy)-        , deriv_overlap_mode :: Maybe (Located OverlapMode)-         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',-         --        'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',-         --        'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',-         --        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'--  -- For details on above see note [Api annotations] in ApiAnnotation-        }--}---- -----------------------------------------------------------------------instance Annotate GHC.DerivStrategy where--  markAST _ GHC.StockStrategy    = mark GHC.AnnStock-  markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass-  markAST _ GHC.NewtypeStrategy  = mark GHC.AnnNewtype---- -----------------------------------------------------------------------instance Annotate (GHC.DefaultDecl GHC.RdrName) where--  markAST _ (GHC.DefaultDecl typs) = do-    mark GHC.AnnDefault-    mark GHC.AnnOpenP -- '('-    markListIntercalate typs-    mark GHC.AnnCloseP -- ')'-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate (GHC.InstDecl GHC.RdrName) 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---- -----------------------------------------------------------------------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.RdrName) 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---- -----------------------------------------------------------------------instance Annotate (GHC.TyFamInstDecl GHC.RdrName) where--  markAST _ (GHC.TyFamInstDecl eqn _) = do-    mark GHC.AnnType-    inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional-    markLocated eqn-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate (GHC.DataFamInstDecl GHC.RdrName) where--  markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ 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-    inContext (Set.singleton TopLevel) $ 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 nd (GHC.noLoc []) typ _mk cons mderivs)-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate (GHC.HsBind GHC.RdrName) 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)) _typ _fvs _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--  markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do-    mark GHC.AnnPattern-    case args of-      GHC.InfixPatSyn la lb -> do-        markLocated la-        setContext (Set.singleton InfixOp) $ markLocated ln-        markLocated lb-      GHC.PrefixPatSyn ns -> do-        markLocated ln-        mapM_ markLocated ns-      GHC.RecordPatSyn 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--  -- Introduced after renaming.-  markAST _ (GHC.AbsBinds _ _ _ _ _) =-    traceM "warning: AbsBinds introduced after renaming"--  -- Introduced after renaming.-  markAST _ GHC.AbsBindsSig{} =-    traceM "warning: AbsBindsSig introduced after renaming"---- -----------------------------------------------------------------------instance Annotate (GHC.IPBind GHC.RdrName) where-  markAST _ (GHC.IPBind en e) = do-    case en of-      Left n   -> markLocated n-      Right _i -> return ()-    mark GHC.AnnEqual-    markLocated e-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate GHC.HsIPName where-  markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)---- -----------------------------------------------------------------------instance (Annotate body)-  => Annotate (GHC.Match GHC.RdrName (GHC.Located body)) where--  markAST _ (GHC.Match mln pats _typ (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---- -----------------------------------------------------------------------instance (Annotate body)-  => Annotate (GHC.GRHS GHC.RdrName (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---- -----------------------------------------------------------------------instance Annotate (GHC.Sig GHC.RdrName) 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---- ----------------------------------------------------------------------markLHsSigType :: GHC.LHsSigType GHC.RdrName -> Annotated ()-markLHsSigType (GHC.HsIB _ typ _) = markLocated typ--instance Annotate [GHC.LHsSigType GHC.RdrName] 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.-    case ls of-      []  -> markManyOptional GHC.AnnOpenP-      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnOpenP-      [_] -> markManyOptional GHC.AnnOpenP-      _   -> markMany         GHC.AnnOpenP-    markListIntercalateWithFun markLHsSigType ls-    case ls of-      []  -> markManyOptional GHC.AnnCloseP-      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnCloseP-      [_] -> markManyOptional GHC.AnnCloseP-      _   -> markMany         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.RdrName) 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 -- '('---- -----------------------------------------------------------------------instance Annotate (GHC.HsType GHC.RdrName) where-  markAST loc ty = do-    markType loc ty-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma-   where--    -- markType :: GHC.SrcSpan -> ast -> 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-      markLocated name--    markType _ (GHC.HsAppsTy ts) = do-      mapM_ markLocated ts-      inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar--    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--    markType _ (GHC.HsListTy t) = do-      mark GHC.AnnOpenS -- '['-      markLocated t-      mark GHC.AnnCloseS -- ']'--    markType _ (GHC.HsPArrTy t) = do-      markWithString GHC.AnnOpen "[:" -- '[:'-      markLocated t-      markWithString GHC.AnnClose ":]" -- ':]'--    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 _ (GHC.HsEqTy t1 t2) = do-      markLocated t1-      mark GHC.AnnTilde-      markLocated t2--    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.HsCoreTy _t) =-      traceM "warning: HsCoreTy Introduced after renaming"--    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 (GHC.AnonWildCard _)) = do-      markExternal l GHC.AnnVal "_"----- -----------------------------------------------------------------------instance Annotate (GHC.HsAppType GHC.RdrName) 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.RdrName) 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"---- -----------------------------------------------------------------------instance Annotate (GHC.ConDeclField GHC.RdrName) 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---- -----------------------------------------------------------------------instance (GHC.DataId name)-      => Annotate (GHC.FieldOcc name) where-  markAST _ (GHC.FieldOcc rn _) = do-    markLocated rn-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma---- -----------------------------------------------------------------------instance Annotate GHC.HsDocString where-  markAST l (GHC.HsDocString s) = do-    markExternal l GHC.AnnVal (GHC.unpackFS s)---- -----------------------------------------------------------------------instance Annotate (GHC.Pat GHC.RdrName) 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.PArrPat ps _) = do-        markWithString GHC.AnnOpen "[:"-        mapM_ markLocated ps-        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.SigPatIn pat ty) = do-        markLocated pat-        mark GHC.AnnDcolon-        markLHsSigWcType ty--      markPat _ GHC.SigPatOut {} =-        traceM "warning: SigPatOut introduced after renaming"--      markPat _ GHC.CoPat {} =-        traceM "warning: CoPat introduced after renaming"---- -----------------------------------------------------------------------hsLit2String :: GHC.HsLit -> 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        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 _) _ -> src-    GHC.HsFloatPrim  (GHC.FL src _)   -> src ++ "#"-    GHC.HsDoublePrim (GHC.FL src _)   -> src ++ "##"--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.RdrName -> 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.RdrName -> Annotated ()--markHsConDeclDetails isDeprecated inGadt lns dets = do-  case dets of-    GHC.PrefixCon args ->-      setContext (Set.singleton PrefixOp) $ mapM_ markLocated args-    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.RdrName] 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 (GHC.DataId name) => Annotate (GHC.HsOverLit name) where-  markAST l ol =-    let str = case GHC.ol_val ol of-                GHC.HsIntegral src _ -> src-                GHC.HsFractional l2  -> GHC.SourceText $ GHC.fl_text l2-                GHC.HsIsString src _ -> src-    in-    markExternalSourceText l str ""---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate arg)-    => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where-  markAST _ (GHC.HsIB _ thing _) = do-    markLocated thing---- -----------------------------------------------------------------------instance (Annotate body) => Annotate (GHC.Stmt GHC.RdrName (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---- ------------------------------------------------------------------------- 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.RdrName GHC.RdrName) where-  markAST _ (GHC.ParStmtBlock stmts _ns _) = do-    markListIntercalate stmts---- -----------------------------------------------------------------------instance Annotate (GHC.HsLocalBinds GHC.RdrName) where-  markAST _ lb = markHsLocalBinds lb---- -----------------------------------------------------------------------markHsLocalBinds :: GHC.HsLocalBinds GHC.RdrName -> Annotated ()-markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =-    applyListAnnotationsLayout-       (prepareListAnnotation (GHC.bagToList binds)-     ++ prepareListAnnotation sigs-       )-markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {})-   = traceM "warning: ValBindsOut introduced after renaming"--markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout binds-markHsLocalBinds GHC.EmptyLocalBinds                   = return ()---- -----------------------------------------------------------------------markMatchGroup :: (Annotate body)-                   => GHC.SrcSpan -> GHC.MatchGroup GHC.RdrName (GHC.Located body)-                   -> Annotated ()-markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _)-  = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches---- -----------------------------------------------------------------------instance (Annotate body)-  => Annotate [GHC.Located (GHC.Match GHC.RdrName (GHC.Located body))] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance Annotate (GHC.HsExpr GHC.RdrName) 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 case cts of-                       GHC.PArrComp -> ("[:",":]")-                       _            -> ("[",  "]")-                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.ExplicitPArr _ es)   = do-        markWithString GHC.AnnOpen "[:"-        markListIntercalateWithFunLevel markLocated 2 es-        markWithString GHC.AnnClose ":]"--      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 _cons _ _ _) = do-        markLocated e-        mark GHC.AnnOpenC-        markListIntercalate fs-        mark GHC.AnnCloseC--      markExpr _ (GHC.ExprWithTySig e typ) = do-        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e-        mark GHC.AnnDcolon-        markLHsSigWcType typ--      markExpr _ (GHC.ExprWithTySigOut _e _typ)-        = error "ExprWithTySigOut only occurs after renamer"--      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.PArrSeq _ seqInfo) = do-        markWithString GHC.AnnOpen "[:" -- '[:'-        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-        markWithString GHC.AnnClose ":]" -- ':]'--      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.AnnOpen "(|"-        markLocated e-        mapM_ markLocated cs-        markWithString GHC.AnnClose "|)"--      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 e ty) = do-        markLocated e-        markInstead GHC.AnnAt AnnTypeApp-        markLHsWcType ty-      markExpr _ (GHC.HsAppTypeOut _ _) =-        traceM "warning: HsAppTypeOut introduced after renaming"--      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"----- -----------------------------------------------------------------------markLHsWcType :: GHC.LHsWcType GHC.RdrName -> Annotated ()-markLHsWcType (GHC.HsWC _ ty) = do-  markLocated ty---- -----------------------------------------------------------------------instance Annotate GHC.HsLit where-  markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)---- -----------------------------------------------------------------------instance Annotate (GHC.HsRecUpdField GHC.RdrName) 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 (GHC.DataId name)-  => Annotate (GHC.AmbiguousFieldOcc name) where-  markAST _ (GHC.Unambiguous n _) = markLocated n-  markAST _ (GHC.Ambiguous   n _) = markLocated n---- ------------------------------------------------------------------------- |Used for declarations that need to be aligned together, e.g. in a--- do or let .. in statement/expr-instance Annotate [GHC.ExprLStmt GHC.RdrName] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance Annotate (GHC.HsTupArg GHC.RdrName) 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---- -----------------------------------------------------------------------instance Annotate (GHC.HsCmdTop GHC.RdrName) where-  markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd--instance Annotate (GHC.HsCmd GHC.RdrName) 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"---- -----------------------------------------------------------------------instance Annotate [GHC.Located (GHC.StmtLR GHC.RdrName GHC.RdrName (GHC.LHsCmd GHC.RdrName))] where-  markAST _ ls = mapM_ markLocated ls---- -----------------------------------------------------------------------instance Annotate (GHC.TyClDecl GHC.RdrName) 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 _ns 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 _ns 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---- -----------------------------------------------------------------------markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)-                => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated ()-markTyClass fixity ln tyVars = do-    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 $ 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.RdrName] where-  markAST _ ds = mapM_ markLocated ds---- -----------------------------------------------------------------------instance Annotate (GHC.HsDerivingClause GHC.RdrName) where-  markAST _ (GHC.HsDerivingClause mstrategy (GHC.L _ typs)) = do-    let needsParens = case typs of-          [(GHC.HsIB _ (GHC.L _ (GHC.HsTyVar _ _)) _)] -> False-          _                           -> True-    mark GHC.AnnDeriving-    markMaybe mstrategy-    if needsParens then mark         GHC.AnnOpenP-                   else markOptional GHC.AnnOpenP-    markListIntercalateWithFunLevel markLHsSigType 2 typs-    if needsParens then mark         GHC.AnnCloseP-                   else markOptional GHC.AnnCloseP---- -----------------------------------------------------------------------instance Annotate (GHC.FamilyDecl GHC.RdrName) 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-    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---- -----------------------------------------------------------------------instance Annotate (GHC.FamilyResultSig GHC.RdrName) where-  markAST _ (GHC.NoSig)        = return ()-  markAST _ (GHC.KindSig k)    = markLocated k-  markAST _ (GHC.TyVarSig ltv) = markLocated ltv---- -----------------------------------------------------------------------instance (GHC.DataId name,Annotate name)-  => Annotate (GHC.InjectivityAnn name) where-  markAST _ (GHC.InjectivityAnn ln lns) = do-    markLocated ln-    mark GHC.AnnRarrow-    mapM_ markLocated lns---- -----------------------------------------------------------------------instance Annotate (GHC.TyFamInstEqn GHC.RdrName) where-  markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats _) fixity typ) = do-    markTyClass fixity ln pats-    mark GHC.AnnEqual-    markLocated typ---- -----------------------------------------------------------------------instance Annotate (GHC.TyFamDefltEqn GHC.RdrName) where-  markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) fixity typ) = do-    mark GHC.AnnType-    mark GHC.AnnInstance-    markTyClass fixity ln bndrs-    mark GHC.AnnEqual-    markLocated typ---- ------------------------------------------------------------------------- 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 (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentPrev (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs-            (GHC.DocGroup _i (GHC.HsDocString fs))        -> GHC.unpackFS fs-    in-      markExternal l GHC.AnnVal str >> markTrailingSemi---- -----------------------------------------------------------------------markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.RdrName -> 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---- ------------------------------------------------------------------------- Note: GHC.HsContext name aliases to here too-instance Annotate [GHC.LHsType GHC.RdrName] where-  markAST l ts = do-    -- Mote: A single item in parens in a deriving clause is parsed as a-    -- HsSigType, which is always a HsForAllTy. 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-          [_] -> markManyOptional pa-          _   -> markMany         pa--      parenIfNeeded'' pa =-        ifInContext (Set.singleton Parens)-          (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.RdrName) where-  markAST _ (GHC.ConDeclH98 ln mqtvs mctx-                         dets _ ) = do-    case mqtvs of-      Nothing -> return ()-      Just (GHC.HsQTvs _ns 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-  markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ _) _) = do-    setContext (Set.singleton PrefixOp) $ markListIntercalate lns-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi---- ResTyGADT has a SrcSpan for the original sigtype, we need to create--- a type for exactPC and annotatePC-data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]-                   deriving (Typeable)-deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)-deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)--instance (GHC.OutputableBndrId name) => GHC.Outputable (ResTyGADTHook name) where-  ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" 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 GHC.RdrName) where-  markAST _ (ResTyGADTHook bndrs) = do-    unless (null bndrs) $ do-      mark GHC.AnnForall-      mapM_ markLocated bndrs-      mark GHC.AnnDot---- -----------------------------------------------------------------------instance Annotate (GHC.HsRecField GHC.RdrName (GHC.LPat GHC.RdrName)) 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.RdrName (GHC.LHsExpr GHC.RdrName)) 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 (GHC.DataId name,Annotate name)-    => Annotate (GHC.FunDep (GHC.Located name)) 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
− src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs 
@@ -1,2607 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook--- | '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 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 ()-    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--        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-                        else markExternal l GHC.AnnVal 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---- -----------------------------------------------------------------------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.VectD 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)--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--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---- -----------------------------------------------------------------------instance Annotate (GHC.VectDecl GHC.GhcPs) where-  markAST _ (GHC.HsVect src ln e) = do-    markAnnOpen src "{-# VECTORISE"-    markLocated ln-    mark GHC.AnnEqual-    markLocated e-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsNoVect src ln) = do-    markAnnOpen src "{-# NOVECTORISE"-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ (GHC.HsVectTypeIn src _b ln mln) = do-    markAnnOpen src  "{-# VECTORISE"  -- or "{-# VECTORISE SCALAR"-    mark GHC.AnnType-    markLocated ln-    case mln of-      Nothing -> return ()-      Just lnn -> do-        mark GHC.AnnEqual-        markLocated lnn-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectTypeOut {} =-    traceM "warning: HsVectTypeOut appears after renaming"--  markAST _ (GHC.HsVectClassIn src ln) = do-    markAnnOpen src "{-# VECTORISE"-    mark GHC.AnnClass-    markLocated ln-    markWithString GHC.AnnClose "#-}" -- "#-}"--  markAST _ GHC.HsVectClassOut {} =-    traceM "warning: HsVecClassOut appears after renaming"-  markAST _ GHC.HsVectInstIn {}   =-    traceM "warning: HsVecInstsIn appears after renaming"-  markAST _ GHC.HsVectInstOut {}   =-    traceM "warning: HsVecInstOut appears after renaming"---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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 -- ")"---- -----------------------------------------------------------------------markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated ()-markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do-  markLocated ty---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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 "#-}"---- -----------------------------------------------------------------------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 -- "]"--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----- -----------------------------------------------------------------------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 typ ms mov) = do-    mark GHC.AnnDeriving-    markMaybe ms-    mark GHC.AnnInstance-    markMaybe mov-    markLHsSigType typ-    markTrailingSemi---- -----------------------------------------------------------------------instance Annotate GHC.DerivStrategy where--  markAST _ GHC.StockStrategy    = mark GHC.AnnStock-  markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass-  markAST _ GHC.NewtypeStrategy  = mark GHC.AnnNewtype---- -----------------------------------------------------------------------instance Annotate (GHC.DefaultDecl GHC.GhcPs) where--  markAST _ (GHC.DefaultDecl typs) = do-    mark GHC.AnnDefault-    mark GHC.AnnOpenP -- '('-    markListIntercalate typs-    mark GHC.AnnCloseP -- ')'-    markTrailingSemi---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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 nd (GHC.noLoc []) typ _mk cons mderivs)-    markTrailingSemi---- -----------------------------------------------------------------------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)) _typ _fvs _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 _fvs 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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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---- ----------------------------------------------------------------------markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated ()-markLHsSigType (GHC.HsIB _ typ _) = markLocated typ--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.-    case ls of-      []  -> markManyOptional GHC.AnnOpenP-      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnOpenP-      [_] -> markManyOptional GHC.AnnOpenP-      _   -> markMany         GHC.AnnOpenP-    markListIntercalateWithFun markLHsSigType ls-    case ls of-      []  -> markManyOptional GHC.AnnCloseP-      [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnCloseP-      [_] -> markManyOptional GHC.AnnCloseP-      _   -> markMany         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 -- '('---- -----------------------------------------------------------------------instance Annotate (GHC.HsType GHC.GhcPs) where-  markAST loc ty = do-    markType loc ty-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma-   where--    -- markType :: GHC.SrcSpan -> ast -> 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-      markLocated name--    markType _ (GHC.HsAppsTy ts) = do-      mapM_ markLocated ts-      inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar--    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--    markType _ (GHC.HsListTy t) = do-      mark GHC.AnnOpenS -- '['-      markLocated t-      mark GHC.AnnCloseS -- ']'--    markType _ (GHC.HsPArrTy t) = do-      markWithString GHC.AnnOpen "[:" -- '[:'-      markLocated t-      markWithString GHC.AnnClose ":]" -- ':]'--    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 _ (GHC.HsEqTy t1 t2) = do-      markLocated t1-      mark GHC.AnnTilde-      markLocated t2--    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.HsCoreTy _t) =-      traceM "warning: HsCoreTy Introduced after renaming"--    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 (GHC.AnonWildCard _)) = do-      markExternal l GHC.AnnVal "_"----- -----------------------------------------------------------------------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"---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------instance (GHC.DataId name)-      => Annotate (GHC.FieldOcc name) where-  markAST _ (GHC.FieldOcc rn _) = do-    markLocated rn-    inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma---- -----------------------------------------------------------------------instance Annotate GHC.HsDocString where-  markAST l (GHC.HsDocString s) = do-    markExternal l GHC.AnnVal (GHC.unpackFS 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.PArrPat ps _) = do-        markWithString GHC.AnnOpen "[:"-        mapM_ markLocated ps-        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.SigPatIn pat ty) = do-        markLocated pat-        mark GHC.AnnDcolon-        markLHsSigWcType ty--      markPat _ GHC.SigPatOut {} =-        traceM "warning: SigPatOut introduced after renaming"--      markPat _ GHC.CoPat {} =-        traceM "warning: CoPat introduced after renaming"---- -----------------------------------------------------------------------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 "##"--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 -> 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 (GHC.DataId name,Annotate arg)-    => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where-  markAST _ (GHC.HsIB _ thing _) = do-    markLocated thing---- -----------------------------------------------------------------------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---- ------------------------------------------------------------------------- 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---- -----------------------------------------------------------------------instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where-  markAST _ lb = markHsLocalBinds lb---- -----------------------------------------------------------------------markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated ()-markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =-    applyListAnnotationsLayout-       (prepareListAnnotation (GHC.bagToList binds)-     ++ prepareListAnnotation sigs-       )-markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {})-   = traceM "warning: ValBindsOut introduced after renaming"--markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout binds-markHsLocalBinds GHC.EmptyLocalBinds                   = return ()---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------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 case cts of-                       GHC.PArrComp -> ("[:",":]")-                       _            -> ("[",  "]")-                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.ExplicitPArr _ es)   = do-        markWithString GHC.AnnOpen "[:"-        markListIntercalateWithFunLevel markLocated 2 es-        markWithString GHC.AnnClose ":]"--      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 _cons _ _ _) = do-        markLocated e-        mark GHC.AnnOpenC-        markListIntercalate fs-        mark GHC.AnnCloseC--      markExpr _ (GHC.ExprWithTySig e typ) = do-        setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e-        mark GHC.AnnDcolon-        markLHsSigWcType typ--      markExpr _ (GHC.ExprWithTySigOut _e _typ)-        = error "ExprWithTySigOut only occurs after renamer"--      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.PArrSeq _ seqInfo) = do-        markWithString GHC.AnnOpen "[:" -- '[:'-        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-        markWithString GHC.AnnClose ":]" -- ':]'--      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 e ty) = do-        markLocated e-        markInstead GHC.AnnAt AnnTypeApp-        markLHsWcType ty-      markExpr _ (GHC.HsAppTypeOut _ _) =-        traceM "warning: HsAppTypeOut introduced after renaming"--      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"----- -----------------------------------------------------------------------markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated ()-markLHsWcType (GHC.HsWC _ ty) = do-  markLocated ty---- -----------------------------------------------------------------------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 (GHC.DataId name)-  => Annotate (GHC.AmbiguousFieldOcc name) where-  markAST _ (GHC.Unambiguous n _) = markLocated n-  markAST _ (GHC.Ambiguous   n _) = markLocated n---- ------------------------------------------------------------------------- |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---- -----------------------------------------------------------------------instance Annotate (GHC.HsCmdTop GHC.GhcPs) where-  markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd--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"---- -----------------------------------------------------------------------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 _ns 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 _ns 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---- -----------------------------------------------------------------------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 (GHC.L _ typs)) = do-    let needsParens = case typs of-          [(GHC.HsIB _ (GHC.L _ (GHC.HsTyVar _ _)) _)] -> False-          _                           -> True-    mark GHC.AnnDeriving-    markMaybe mstrategy-    if needsParens then mark         GHC.AnnOpenP-                   else markOptional GHC.AnnOpenP-    markListIntercalateWithFunLevel markLHsSigType 2 typs-    if needsParens then mark         GHC.AnnCloseP-                   else markOptional GHC.AnnCloseP---- -----------------------------------------------------------------------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-    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---- -----------------------------------------------------------------------instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where-  markAST _ (GHC.NoSig)        = return ()-  markAST _ (GHC.KindSig k)    = markLocated k-  markAST _ (GHC.TyVarSig ltv) = markLocated ltv---- -----------------------------------------------------------------------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---- -----------------------------------------------------------------------instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where--  markAST _ (GHC.FamEqn ln (GHC.HsQTvs _ns bndrs _) fixity typ) = do-    mark GHC.AnnType-    mark GHC.AnnInstance-    markTyClass fixity ln bndrs-    mark GHC.AnnEqual-    markLocated typ---- ------------------------------------------------------------------------- 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 (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentPrev (GHC.HsDocString fs))     -> GHC.unpackFS fs-            (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs-            (GHC.DocGroup _i (GHC.HsDocString fs))        -> GHC.unpackFS fs-    in-      markExternal l GHC.AnnVal str >> markTrailingSemi---- -----------------------------------------------------------------------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---- ------------------------------------------------------------------------- Note: GHC.HsContext name aliases to here too-instance Annotate [GHC.LHsType GHC.GhcPs] where-  markAST l ts = do-    -- Mote: A single item in parens in a deriving clause is parsed as a-    -- HsSigType, which is always a HsForAllTy. 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-          [_] -> markManyOptional pa-          _   -> markMany         pa--      parenIfNeeded'' pa =-        ifInContext (Set.singleton Parens)-          (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 mqtvs mctx-                         dets _ ) = do-    case mqtvs of-      Nothing -> return ()-      Just (GHC.HsQTvs _ns 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-  markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ _) _) = do-    setContext (Set.singleton PrefixOp) $ markListIntercalate lns-    mark GHC.AnnDcolon-    markLocated typ-    markTrailingSemi---- ResTyGADT has a SrcSpan for the original sigtype, we need to create--- a type for exactPC and annotatePC-data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]-                   deriving (Typeable)-deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)-deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)--instance GHC.Outputable (ResTyGADTHook GHC.GhcPs) where-  ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" 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 GHC.GhcPs) where-  markAST _ (ResTyGADTHook bndrs) = do-    unless (null bndrs) $ do-      mark GHC.AnnForall-      mapM_ markLocated bndrs-      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
− src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs 
@@ -1,2800 +0,0 @@-{-# 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
src/Language/Haskell/GHC/ExactPrint.hs view
@@ -1,14 +1,8 @@-{-# LANGUAGE LambdaCase #-} -- | @ghc-exactprint@ is a library to manage manipulating Haskell -- source files. There are four components. module Language.Haskell.GHC.ExactPrint-        ( -- * Relativising-          relativiseApiAnns-        , relativiseApiAnnsWithComments-        , Anns-        , Comment-        , Annotation(..)-        , AnnKey(..)+        ( -- * Types+          Comment          -- * Parsing         , parseModule@@ -16,17 +10,15 @@         -- * Transformation         , module Language.Haskell.GHC.ExactPrint.Transform -        -- * Adding default annotations-        , addAnnotationsForPretty-         -- * Printing+        , ExactPrint(..)         , exactPrint +        -- * Relativising+        , makeDeltaAst         ) where -import Language.Haskell.GHC.ExactPrint.Delta-import Language.Haskell.GHC.ExactPrint.Pretty-import Language.Haskell.GHC.ExactPrint.Print+import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers
− src/Language/Haskell/GHC/ExactPrint/Annotate.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook--- | '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.Annotate-       (-         annotate-       , AnnotationF(..)-       , Annotated-       , Annotate(..)-       , withSortKeyContextsHelper--       ) where---import Language.Haskell.GHC.ExactPrint.Annotater
− src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs 
@@ -1,364 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook--- | '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.AnnotateTypes-       -- (-       --   AnnotationF(..)-       -- , Annotated-       -- , Annotate(..)--       -- )-      where--#if __GLASGOW_HASKELL__ <= 710-import Data.Ord ( comparing )-import Data.List ( sortBy )-#endif--import Language.Haskell.GHC.ExactPrint.Types--#if __GLASGOW_HASKELL__ > 800-import qualified BasicTypes     as GHC-#endif-import qualified GHC            as GHC-#if __GLASGOW_HASKELL__ <= 710-import qualified BooleanFormula as GHC-import qualified Outputable     as GHC-#endif--import Control.Monad.Trans.Free-import Control.Monad.Free.TH (makeFreeCon)-import Control.Monad.Identity-import Data.Data--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" #-}--- ------------------------------------------------------------------------- | ['MarkPrim'] The main constructor. Marks that a specific AnnKeywordId could--- appear with an optional String which is used when printing.--- ['MarkPPOptional'] Used to flag elements, such as optional braces, that are---   not used in the pretty printer. This functions identically to 'MarkPrim'---   for the other interpreters.--- ['MarkEOF']---    Special constructor which marks the end of file marker.--- ['MarkExternal'] TODO--- ['MarkOutside']  A @AnnKeywordId@ which is precisely located but not inside the---    current context. This is usually used to reassociated located---    @RdrName@ which are more naturally associated with their parent than---    in their own annotation.--- ['MarkInside']---    The dual of MarkOutside. If we wish to mark a non-separating comma---    or semi-colon then we must use this constructor.--- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks--- without reflection in the AST. This construction greedily takes all of--- the specified @AnnKeywordId@.--- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are---  seperated by different @AnnKeywordId@. Thus using MarkMany is---  unsuitable and instead we provide an index to specify which specific---  instance to choose each time.--- ['WithAST'] TODO--- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the---  only way to tell what the concrete source was is to count a certain---  kind of @AnnKeywordId@.--- ['WithSortKey'] There are many places where the syntactic ordering of elements is--- thrown away by the AST. This constructor captures the original--- ordering and reflects any changes in ordered as specified by the--- @annSortKey@ field in @Annotation@.--- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This---  constructor wraps a computation to indicate that LayoutRules apply to---  the corresponding construct.--- ['StoreOriginalSrcSpan'] TODO--- ['GetSrcSpanFromKw'] TODO--- ['StoreString'] TODO--- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other--- option but to convert a fragment of source code into a comment. This--- means it is impossible to edit such a fragment but means that--- processing files with such fragments is still possible.-data AnnotationF next where-  MarkPrim         :: GHC.AnnKeywordId -> Maybe String                     -> next -> AnnotationF next-  MarkPPOptional   :: GHC.AnnKeywordId -> Maybe String                     -> next -> AnnotationF next-  MarkEOF          ::                                                         next -> AnnotationF next-  MarkExternal     :: GHC.SrcSpan -> GHC.AnnKeywordId -> String            -> next -> AnnotationF next-#if __GLASGOW_HASKELL__ >= 800-  MarkInstead      :: GHC.AnnKeywordId -> KeywordId                        -> next -> AnnotationF next-#endif-  MarkOutside      :: GHC.AnnKeywordId -> KeywordId                        -> next -> AnnotationF next-  MarkInside       :: GHC.AnnKeywordId                                     -> next -> AnnotationF next-  MarkMany         :: GHC.AnnKeywordId                                     -> next -> AnnotationF next-  MarkManyOptional :: GHC.AnnKeywordId                                     -> next -> AnnotationF next-  MarkOffsetPrim   :: GHC.AnnKeywordId -> Int -> Maybe String              -> next -> AnnotationF next-  MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String        -> next -> AnnotationF next-  WithAST          :: Data a => GHC.Located a-                             -> Annotated b                                -> next -> AnnotationF next-  CountAnns        :: GHC.AnnKeywordId                        -> (Int     -> next) -> AnnotationF next-  WithSortKey      :: [(GHC.SrcSpan, Annotated ())]                        -> next -> AnnotationF next--  SetLayoutFlag    ::  Rigidity -> Annotated ()                            -> next -> AnnotationF next-  MarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId                 -> next -> AnnotationF next--  -- Required to work around deficiencies in the GHC AST-  StoreOriginalSrcSpan :: GHC.SrcSpan -> AnnKey         -> (AnnKey -> next) -> AnnotationF next-  GetSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next-#if __GLASGOW_HASKELL__ <= 710-  StoreString :: String -> GHC.SrcSpan                  -> next -> AnnotationF next-#endif-  AnnotationsToComments :: [GHC.AnnKeywordId]           -> next -> AnnotationF next-#if __GLASGOW_HASKELL__ <= 710-  AnnotationsToCommentsBF :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> next -> AnnotationF next-  FinalizeBF :: GHC.SrcSpan -> next -> AnnotationF next-#endif--  -- AZ experimenting with pretty printing-  -- Set the context for child element-  SetContextLevel :: Set.Set AstContext -> Int -> Annotated () -> next -> AnnotationF next-  UnsetContext    ::         AstContext        -> Annotated () -> next -> AnnotationF next-  -- Query the context while in a child element-  IfInContext  :: Set.Set AstContext -> Annotated () -> Annotated ()   -> next -> AnnotationF next-  WithSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next-  ---  TellContext :: Set.Set AstContext -> next -> AnnotationF next--deriving instance Functor AnnotationF--type Annotated = FreeT AnnotationF Identity----- -----------------------------------------------------------------------makeFreeCon  'MarkEOF-makeFreeCon  'MarkPrim-makeFreeCon  'MarkPPOptional-#if __GLASGOW_HASKELL__ >= 800-makeFreeCon  'MarkInstead-#endif-makeFreeCon  'MarkOutside-makeFreeCon  'MarkInside-makeFreeCon  'MarkExternal-makeFreeCon  'MarkMany-makeFreeCon  'MarkManyOptional-makeFreeCon  'MarkOffsetPrim-makeFreeCon  'MarkOffsetPrimOptional-makeFreeCon  'CountAnns-makeFreeCon  'StoreOriginalSrcSpan-makeFreeCon  'GetSrcSpanForKw-#if __GLASGOW_HASKELL__ <= 710-makeFreeCon  'StoreString-#endif-makeFreeCon  'AnnotationsToComments-#if __GLASGOW_HASKELL__ <= 710-makeFreeCon  'AnnotationsToCommentsBF-makeFreeCon  'FinalizeBF-#endif-makeFreeCon  'WithSortKey-makeFreeCon  'SetContextLevel-makeFreeCon  'UnsetContext-makeFreeCon  'IfInContext-makeFreeCon  'WithSortKeyContexts-makeFreeCon  'TellContext-makeFreeCon  'MarkAnnBeforeAnn---- -----------------------------------------------------------------------setContext :: Set.Set AstContext -> Annotated () -> Annotated ()-setContext ctxt action = liftF (SetContextLevel ctxt 3 action ())--setLayoutFlag :: Annotated () -> Annotated ()-setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ())--setRigidFlag :: Annotated () -> Annotated ()-setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ())--inContext :: Set.Set AstContext -> Annotated () -> Annotated ()-inContext ctxt action = liftF (IfInContext ctxt action (return ()) ())---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710-workOutString :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated ()-workOutString l kw f = do-  ss <- getSrcSpanForKw l kw-  storeString (f ss) ss-#endif---- ------------------------------------------------------------------------- |Main driver point for annotations.-withAST :: Data a => GHC.Located a -> Annotated () -> Annotated ()-withAST lss action = liftF (WithAST lss action ())---- ------------------------------------------------------------------------ Additional smart constructors--mark :: GHC.AnnKeywordId -> Annotated ()-mark kwid = markPrim kwid Nothing--markOptional :: GHC.AnnKeywordId -> Annotated ()-markOptional kwid = markPPOptional kwid Nothing--markWithString :: GHC.AnnKeywordId -> String -> Annotated ()-markWithString kwid s = markPrim kwid (Just s)--markWithStringOptional :: GHC.AnnKeywordId -> String -> Annotated ()-markWithStringOptional kwid s = markPPOptional kwid (Just s)--markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated ()-markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s)--markOffset :: GHC.AnnKeywordId -> Int -> Annotated ()-markOffset kwid n = markOffsetPrim kwid n Nothing--markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated ()-markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing--markTrailingSemi :: Annotated ()-markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep---- -----------------------------------------------------------------------withLocated :: Data a-            => GHC.Located a-            -> (GHC.SrcSpan -> a -> Annotated ())-            -> Annotated ()-withLocated a@(GHC.L l ast) action =-  withAST a (action l ast)---- ------------------------------------------------------------------------markListIntercalateWithFun :: (t -> Annotated ()) -> [t] -> Annotated ()-markListIntercalateWithFun f ls = markListIntercalateWithFunLevel f 2 ls--markListIntercalateWithFunLevel :: (t -> Annotated ()) -> Int -> [t] -> Annotated ()-markListIntercalateWithFunLevel f level ls = markListIntercalateWithFunLevelCtx f level Intercalate ls--markListIntercalateWithFunLevelCtx :: (t -> Annotated ()) -> Int -> AstContext -> [t] -> Annotated ()-markListIntercalateWithFunLevelCtx f level ctx ls = go ls-  where-    go []  = return ()-    go [x] = f x-    go (x:xs) = do-      setContextLevel (Set.singleton ctx) level $ f x-      go xs---- -----------------------------------------------------------------------markListWithContextsFunction ::-                         ListContexts-                      -> (t -> Annotated ())-                      -> [t] -> Annotated ()-markListWithContextsFunction (LC ctxOnly ctxInitial ctxMiddle ctxLast) f ls =-  case ls of-    [] -> return ()-    [x] -> setContextLevel ctxOnly level $ f x-    (x:xs) -> do-      setContextLevel ctxInitial level $ f x-      go xs-  where-    level = 2-    go []  = return ()-    go [x] = setContextLevel ctxLast level $ f x-    go (x:xs) = do-      setContextLevel ctxMiddle level $ f x-      go xs---- -------------------------------------------------------------------------- Expects the kws to be ordered already-withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(GHC.SrcSpan, Annotated ())] -> m ()-withSortKeyContextsHelper interpret (LC ctxOnly ctxInitial ctxMiddle ctxLast) kws = do-  case kws of-    [] -> return ()-    [x] -> interpret (setContextLevel (Set.insert (CtxPos 0) ctxOnly) level $ snd x)-    (x:xs) -> do-      interpret (setContextLevel (Set.insert (CtxPos 0) ctxInitial) level $ snd x)-      go 1 xs-  where-    level = 2-    go _ []  = return ()-    go n [x] = interpret (setContextLevel (Set.insert (CtxPos n) ctxLast) level $ snd x)-    go n (x:xs) = do-      interpret (setContextLevel (Set.insert (CtxPos n) ctxMiddle) level $ snd x)-      go (n+1) xs---- ------------------------------------------------------------------------ Managing lists which have been separated, e.g. Sigs and Binds---applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated ()-applyListAnnotations ls = withSortKey ls--applyListAnnotationsContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Annotated ()-applyListAnnotationsContexts ctxt ls = withSortKeyContexts ctxt ls--#if __GLASGOW_HASKELL__ <= 710-lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a]-lexicalSortLocated = sortBy (comparing GHC.getLoc)-#endif--applyListAnnotationsLayout :: [(GHC.SrcSpan, Annotated ())] -> Annotated ()-applyListAnnotationsLayout ls = setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace)-                                              $ withSortKeyContexts listContexts ls--listContexts :: ListContexts-listContexts = LC (Set.fromList [CtxOnly,ListStart])-                  (Set.fromList [CtxFirst,ListStart,Intercalate])-                  (Set.fromList [CtxMiddle,ListItem,Intercalate])-                  (Set.fromList [CtxLast,ListItem])--listContexts' :: ListContexts-listContexts' = LC (Set.fromList [CtxOnly,  ListStart])-                   (Set.fromList [CtxFirst, ListStart])-                   (Set.fromList [CtxMiddle,ListItem])-                   (Set.fromList [CtxLast,  ListItem])---- ------------------------------------------------------------------------#if __GLASGOW_HASKELL__ > 800-markAnnOpen :: GHC.SourceText -> String -> Annotated ()-markAnnOpen GHC.NoSourceText txt   =  markWithString GHC.AnnOpen txt-markAnnOpen (GHC.SourceText txt) _ =  markWithString GHC.AnnOpen txt--markSourceText :: GHC.SourceText -> String -> Annotated ()-markSourceText GHC.NoSourceText txt   =  markWithString GHC.AnnVal txt-markSourceText (GHC.SourceText txt) _ =  markWithString GHC.AnnVal txt--markExternalSourceText :: GHC.SrcSpan -> GHC.SourceText -> String -> Annotated ()-markExternalSourceText l GHC.NoSourceText txt   =  markExternal l GHC.AnnVal txt-markExternalSourceText l (GHC.SourceText txt) _ =  markExternal l GHC.AnnVal txt--sourceTextToString :: GHC.SourceText -> String -> String-sourceTextToString GHC.NoSourceText alt   = alt-sourceTextToString (GHC.SourceText txt) _ = txt-#endif---- ---------------------------------------------------------------------
− src/Language/Haskell/GHC/ExactPrint/Delta.hs 
@@ -1,845 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NamedFieldPuns #-}--- |  This module converts 'GHC.ApiAnns' into 'Anns' by traversing a--- structure created by the "Annotate" module.------ == Structure of an Annotation------ As a rule of thumb, every located element in the GHC AST will have--- a corresponding entry in 'Anns'. An 'Annotation' contains 6 fields which--- can be modifed to change how the AST is printed.------ == Layout Calculation------ In order to properly place syntax nodes and comments properly after--- refactoring them (in such a way that the indentation level changes), their--- position (encoded in the 'addEntryDelta' field) is not expressed as absolute--- but relative to their context. As further motivation, consider the simple--- let-into-where-block refactoring, from:------ @--- foo = do---   let bar = do---         x---         -- comment---         y---   bar--- @------ to------ @--- foo = do---   bar---  where---   bar = do---     x---     -- comment---     y--- @------ Notice how the column of @x@, @y@ and the comment change due to this--- refactoring but certain relative positions (e.g. the comment starting at the--- same column as @x@) remain unchanged.------ Now, what does "context" mean exactly? Here we reference the--- "indentation level" as used in the haskell report (see chapter 2.7:--- <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-210002.7>):--- 'addEntryDelta' is mostly relative to the current (inner-most) indentation--- level. But in order to get better results, for the purpose of defining--- relative positions a the offside-rule is modified slightly: Normally it--- fires (only) at the first elements after where/let/do/of, introducing a new--- indentation level. In addition, the rule here fires also at the "@let@"--- keyword (when it is part of a "@let-in@" construct) and at the "@if@" keyword.------ The effect of this additional applications of the offside-rule is that any--- elements (more or less directly) following the "@let@" ("@if@"")--- keyword have a position relative to the "@let@" ("@if@")--- keyword position, even when the regular offside-rule does apply not yet/not--- anymore. This affects two concrete things: Comments directly following--- "@let@"/"@if@", and the respective follow-up keywords: "@in@" or--- "@then@"/"@else@".------ Due to this additional indentation level, it is possible to observe/obtain--- negative delta-positions; consider:------ @--- foo = let x = 1---   in x--- @------ Here, the @in@ keyword has an 'annEntryDelta' of @DP (1, -4)@ as it appears--- one line below the previous elements and 4 columns /left/ relative to the--- start of the @let@ keyword.------ In general, the element that defines such an indentation level (i.e. the--- first element after a where/let/do/of) will have an 'annEntryDelta' relative--- to the previous inner-most indentation level; in other words: a new--- indentation level becomes relevant only after the construct introducing the--- element received its 'annEntryDelta' position. (Otherwise these elements--- always would have a zero horizontal position - relative to itself.)------ (This affects comments, too: A comment preceding the first element of a--- layout block will have a position relative to the outer block, not of the--- newly introduced layout block.)------ For example, in the following expression the statement corresponding to--- @baz@ will be given a 'annEntryDelta' of @DP (1, 2)@ as it appears--- 1 line and 2 columns after the @do@ keyword. On the other hand, @bar@--- will be given a 'annEntryDelta' of @DP (1,0)@ as it appears 1 line--- further than @baz@ but in the same column as the start of the layout--- block.------ @--- foo = do---   baz---   bar--- @------ A useful way to think of these rules is that the 'DeltaPos' is relative--- to the further left an expression could have been placed. In the--- previous example, we could have placed @baz@ anywhere on the line as its--- position determines where the other statements must be. @bar@ could have--- not been placed any further left without resulting in a syntax error--- which is why the relative column is 0.------ === annTrueEntryDelta--- A very useful function is 'annTrueEntryDelta' which calculates the--- offset from the last syntactic element (ignoring comments). This is--- different to 'annEntryDelta' which does not ignore comments.----------module Language.Haskell.GHC.ExactPrint.Delta-  ( relativiseApiAnns-  , relativiseApiAnnsWithComments-  , relativiseApiAnnsWithOptions--  -- * Configuration-  , DeltaOptions(drRigidity)-  , deltaOptions-  , normalLayout-  ) where---- import Control.Exception-import Control.Monad.RWS-import Control.Monad.Trans.Free--import Data.Data (Data)-import Data.List (sort, nub, partition, sortBy)--import Data.Ord--import Language.Haskell.GHC.ExactPrint.Utils-#if __GLASGOW_HASKELL__ <= 710-import Language.Haskell.GHC.ExactPrint.Lookup-#endif-import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Annotate--import qualified GHC--import qualified Data.Map as Map-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" #-}---- ------------------------------------------------------------------------ | Transform concrete annotations into relative annotations which are--- more useful when transforming an AST.-relativiseApiAnns :: Annotate ast-                  => GHC.Located ast-                  -> GHC.ApiAnns-                  -> Anns-relativiseApiAnns = relativiseApiAnnsWithComments []---- | Exactly the same as 'relativiseApiAnns' but with the possibilty to--- inject comments. This is typically used if the source has been preprocessed--- by e.g. CPP, and the parts stripped out of the original source are re-added--- as comments so they are not lost for round tripping.-relativiseApiAnnsWithComments ::-                     Annotate ast-                  => [Comment]-                  -> GHC.Located ast-                  -> GHC.ApiAnns-                  -> Anns-relativiseApiAnnsWithComments =-    relativiseApiAnnsWithOptions normalLayout--relativiseApiAnnsWithOptions ::-                     Annotate ast-                  => DeltaOptions-                  -> [Comment]-                  -> GHC.Located ast-                  -> GHC.ApiAnns-                  -> Anns-relativiseApiAnnsWithOptions opts cs modu ghcAnns-   = runDeltaWithComments-      opts cs (annotate modu) ghcAnns-      (ss2pos $ GHC.getLoc modu)---- --------------------------------------------------------------------------- | Type used in the Delta Monad.-type Delta a = RWS DeltaOptions DeltaWriter DeltaState a--runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns-runDeltaWithComments opts cs action ga priorEnd =-  mkAnns . snd-  . (\next -> execRWS next opts (defaultDeltaState cs priorEnd ga))-  . deltaInterpret $ action-  where-    mkAnns :: DeltaWriter -> Anns-    mkAnns = f . dwAnns-    f :: Monoid a => Endo a -> a-    f = ($ mempty) . appEndo---- ------------------------------------------------------------------------- TODO: rename this, it is the R part of the RWS-data DeltaOptions = DeltaOptions-       {-         -- | Current `SrcSpan, part of current AnnKey`-         curSrcSpan :: !GHC.SrcSpan--         -- | Constuctor of current AST element, part of current AnnKey-       , annConName :: !AnnConName--        -- | Whether to use rigid or normal layout rules-       , drRigidity :: !Rigidity--       -- | Current higher level context. e.g. whether a Match is part of a-       -- LambdaExpr or a FunBind-       , drContext :: !AstContextSet-       }--data DeltaWriter = DeltaWriter-       { -- | Final list of annotations, and sort keys-         dwAnns :: Endo (Map.Map AnnKey Annotation)--         -- | Used locally to pass Keywords, delta pairs relevant to a specific-         -- subtree to the parent.-       , annKds         :: ![(KeywordId, DeltaPos)]-       , sortKeys       :: !(Maybe [GHC.SrcSpan])-       , dwCapturedSpan :: !(First AnnKey)-       }--data DeltaState = DeltaState-       { -- | Position reached when processing the last element-         priorEndPosition    :: !Pos--         -- | Ordered list of comments still to be allocated-       , apComments :: ![Comment]--         -- | The original GHC Delta Annotations-       , apAnns :: !GHC.ApiAnns--       , apMarkLayout :: Bool-       , apLayoutStart :: LayoutStartCol--       }---- -----------------------------------------------------------------------deltaOptions :: Rigidity -> DeltaOptions-deltaOptions ridigity =-  DeltaOptions-    { curSrcSpan = GHC.noSrcSpan-    , annConName = annGetConstr ()-    , drRigidity = ridigity-    , drContext  = defaultACS-    }--normalLayout :: DeltaOptions-normalLayout = deltaOptions NormalLayout--defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState-defaultDeltaState injectedComments priorEnd ga =-    DeltaState-      { priorEndPosition    = priorEnd-      , apComments = cs ++ injectedComments-      , apAnns     = ga-      , apLayoutStart = 1-      , apMarkLayout = False-      }-  where-    cs :: [Comment]-    cs = extractComments ga----- Writer helpers--tellFinalAnn :: (AnnKey, Annotation) -> Delta ()-tellFinalAnn (k, v) =-  -- tell (mempty { dwAnns = Endo (Map.insertWith (<>) k v) })-  tell (mempty { dwAnns = Endo (Map.insert k v) })--tellSortKey :: [GHC.SrcSpan] -> Delta ()-tellSortKey xs = tell (mempty { sortKeys = Just xs } )--tellCapturedSpan :: AnnKey -> Delta ()-tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key })--tellKd :: (KeywordId, DeltaPos) -> Delta ()-tellKd kd = tell (mempty { annKds = [kd] })--#if __GLASGOW_HASKELL__ >= 804-instance Semigroup DeltaWriter where-  (<>) = mappend-#endif--instance Monoid DeltaWriter where-  mempty = DeltaWriter mempty mempty mempty mempty-  (DeltaWriter a b e g) `mappend` (DeltaWriter c d f h)-    = DeltaWriter (a <> c) (b <> d) (e <> f) (g <> h)---------------------------------------- Free Monad Interpretation code--deltaInterpret :: Annotated a -> Delta a-deltaInterpret = iterTM go-  where-    go :: AnnotationF (Delta a) -> Delta a-    go (MarkEOF next)                   = addEofAnnotation >> next-    go (MarkPrim kwid _ next)           = addDeltaAnnotation kwid >> next-    go (MarkPPOptional kwid _ next)     = addDeltaAnnotation kwid >> next-#if __GLASGOW_HASKELL__ >= 800-    go (MarkInstead akwid kwid next)    = addDeltaAnnotationInstead akwid kwid >> next-#endif-    go (MarkOutside akwid kwid next)    = addDeltaAnnotationsOutside akwid kwid >> next-    go (MarkInside akwid next)          = addDeltaAnnotationsInside akwid >> next-    go (MarkMany akwid next)            = addDeltaAnnotations akwid >> next-    go (MarkManyOptional akwid next)    = addDeltaAnnotations akwid >> next-    go (MarkOffsetPrim akwid n _ next)  = addDeltaAnnotationLs akwid n >> next-    go (MarkOffsetPrimOptional akwid n _ next) = addDeltaAnnotationLs akwid n >> next-    go (WithAST lss prog next)          = withAST lss (deltaInterpret prog) >> next-    go (CountAnns kwid next)            = countAnnsDelta kwid >>= next-    go (SetLayoutFlag r action next)    = do-      rigidity <- asks drRigidity-      (if r <= rigidity then setLayoutFlag else id) (deltaInterpret action)-      next-    go (MarkAnnBeforeAnn ann1 ann2 next) = deltaMarkAnnBeforeAnn ann1 ann2 >> next-    go (MarkExternal ss akwid _ next)    = addDeltaAnnotationExt ss akwid >> next-    go (StoreOriginalSrcSpan _ key next) = storeOriginalSrcSpanDelta key >>= next-    go (GetSrcSpanForKw ss kw next)      = getSrcSpanForKw ss kw >>= next-#if __GLASGOW_HASKELL__ <= 710-    go (StoreString s ss next)           = storeString s ss >> next-#endif-    go (AnnotationsToComments     kws next) = annotationsToCommentsDelta kws >> next-#if __GLASGOW_HASKELL__ <= 710-    go (AnnotationsToCommentsBF _ kws next) = annotationsToCommentsDelta kws >> next-    go (FinalizeBF _ next)                  = next-#endif-    go (WithSortKey             kws next) = withSortKey kws >> next-    go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next--    go (SetContextLevel ctxt lvl action next) = setContextDelta ctxt lvl (deltaInterpret action) >> next-    go (UnsetContext   _ctxt action next) = deltaInterpret action >> next-    go (IfInContext    ctxt ifAction elseAction next) = ifInContextDelta ctxt ifAction elseAction >> next-    go (TellContext _ next)                  = next--withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta ()-withSortKey kws =-  let order = sortBy (comparing fst) kws-  in do-    tellSortKey (map fst order)-    mapM_ (deltaInterpret . snd) order---withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Delta ()-withSortKeyContexts ctxts kws = do-  tellSortKey (map fst order)-  withSortKeyContextsHelper deltaInterpret ctxts order-  where-    order = sortBy (comparing fst) kws---setLayoutFlag :: Delta () -> Delta ()-setLayoutFlag action = do-  oldLay <- gets apLayoutStart-  modify (\s -> s { apMarkLayout = True } )-  let reset = do-                modify (\s -> s { apMarkLayout = False-                                , apLayoutStart = oldLay })-  action <* reset---- -----------------------------------------------------------------------setContextDelta :: Set.Set AstContext -> Int -> Delta () -> Delta ()-setContextDelta ctxt lvl =-  local (\s -> s { drContext = setAcsWithLevel ctxt lvl (drContext s) } )--ifInContextDelta :: Set.Set AstContext -> Annotated () -> Annotated () -> Delta ()-ifInContextDelta ctxt ifAction elseAction = do-  cur <- asks drContext-  let inContext = inAcs ctxt cur-  if inContext-    then deltaInterpret ifAction-    else deltaInterpret elseAction---- -----------------------------------------------------------------------storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey-storeOriginalSrcSpanDelta key = do-  tellCapturedSpan key-  return key--#if __GLASGOW_HASKELL__ <= 710-storeString :: String -> GHC.SrcSpan -> Delta ()-storeString s ss = addAnnotationWorker (AnnString s) ss-#endif---- ------------------------------------------------------------------------- |In order to interleave annotations into the stream, we turn them into--- comments.-annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta ()-annotationsToCommentsDelta kws = do-  ss <- getSrcSpan-  cs <- gets apComments-  let-    doOne :: GHC.AnnKeywordId -> Delta [Comment]-    doOne kw = do-      (spans,_) <- getAndRemoveAnnotationDelta ss kw-      return $ map (mkKWComment kw) spans-    -- TODO:AZ make sure these are sorted/merged properly when the invariant for-    -- allocateComments is re-established.-  newComments <- mapM doOne kws-  putUnallocatedComments (cs ++ concat newComments)---- ------------------------------------------------------------------------- | This function exists to overcome a shortcoming in the GHC AST for 7.10.1-getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta GHC.SrcSpan-getSrcSpanForKw _ kw = do-    ga <- gets apAnns-    ss <- getSrcSpan-    case GHC.getAnnotation ga ss kw of-      []     -> return GHC.noSrcSpan-      (sp:_) -> return sp---- -----------------------------------------------------------------------getSrcSpan :: Delta GHC.SrcSpan-getSrcSpan = asks curSrcSpan--withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b-withSrcSpanDelta (GHC.L l a) =-  local (\s -> s { curSrcSpan = l-                 , annConName = annGetConstr a-                 , drContext = pushAcs (drContext s)-                    `debug` ("withSrcSpanDelta: (l,annConName,drContext)=" ++ showGhc (l,annGetConstr a, pushAcs (drContext s)))-                 })---getUnallocatedComments :: Delta [Comment]-getUnallocatedComments = gets apComments--putUnallocatedComments :: [Comment] -> Delta ()-putUnallocatedComments cs = modify (\s -> s { apComments = cs } )---- -----------------------------------------------------------------------adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos-adjustDeltaForOffsetM dp = do-  colOffset <- gets apLayoutStart-  return (adjustDeltaForOffset colOffset dp)--adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos-adjustDeltaForOffset _colOffset              dp@(DP (0,_)) = dp -- same line-adjustDeltaForOffset (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset)---- -----------------------------------------------------------------------getPriorEnd :: Delta Pos-getPriorEnd = gets priorEndPosition--setPriorEnd :: Pos -> Delta ()-setPriorEnd pe =-  modify (\s -> s { priorEndPosition = pe })--setPriorEndAST :: GHC.SrcSpan -> Delta ()-setPriorEndAST pe = do-  setLayoutStart (snd (ss2pos pe))-  modify (\s -> s { priorEndPosition    = ss2posEnd pe } )--setLayoutStart :: Int -> Delta ()-setLayoutStart p = do-  DeltaState{apMarkLayout} <- get-  when apMarkLayout (-                      modify (\s -> s { apMarkLayout = False-                                     , apLayoutStart = LayoutStartCol p}))----- ---------------------------------------peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]-peekAnnotationDelta an = do-    ga <- gets apAnns-    ss <- getSrcSpan-#if __GLASGOW_HASKELL__ <= 710-    return $ GHC.getAnnotation ga ss an-#else-    let unicodeAnns = case unicodeEquivalent an of-          [] -> []-          [kw] -> GHC.getAnnotation ga ss kw-          (kw:_) -> GHC.getAnnotation ga ss kw -- Keep exhaustiveness checker happy-    return $ unicodeAnns ++ GHC.getAnnotation ga ss an-#endif--getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)-getAnnotationDelta an = do-    ss <- getSrcSpan-    getAndRemoveAnnotationDelta ss an--getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)-getAndRemoveAnnotationDelta sp an = do-    ga <- gets apAnns-#if __GLASGOW_HASKELL__ <= 710-    let (r,ga') = GHC.getAndRemoveAnnotation ga sp an-        kw = an-#else-    let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga sp an of-                    ([],_) -> (ss,g,k)-                      where-                        k = GHC.unicodeAnn an-                        (ss,g) = GHC.getAndRemoveAnnotation ga sp k-                    (ss,g)  -> (ss,g,an)-#endif-    modify (\s -> s { apAnns = ga' })-    return (r,kw)--getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)-getOneAnnotationDelta an = do-    ss <- getSrcSpan-    getAndRemoveOneAnnotationDelta ss an--getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)-getAndRemoveOneAnnotationDelta sp an = do-    (anns,cs) <- gets apAnns-#if __GLASGOW_HASKELL__ <= 710-    let (r,ga',kw) = case Map.lookup (sp,an) anns of-                    Nothing -> ([],(anns,cs),an)-                    Just []     -> ([], (Map.delete (sp,an)    anns,cs),an)-                    Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an)-#else-    let getKw kw =-          case Map.lookup (sp,kw) anns of-            Nothing -> ([],(anns,cs),kw)-            Just []     -> ([], (Map.delete (sp,kw)    anns,cs),kw)-            Just (s:ss) -> ([s],(Map.insert (sp,kw) ss anns,cs),kw)--    let (r,ga',kw) =-          case getKw an of-            ([],_,_) -> getKw (GHC.unicodeAnn an)-            v        -> v-#endif-    modify (\s -> s { apAnns = ga' })-    return (r,kw)---- ------------------------------------------------------------------------- |Add some annotation to the currently active SrcSpan-addAnnotationsDelta :: Annotation -> Delta ()-addAnnotationsDelta ann = do-    l <- ask-    tellFinalAnn (getAnnKey l,ann)--getAnnKey :: DeltaOptions -> AnnKey-getAnnKey DeltaOptions {curSrcSpan, annConName}-  = AnnKey curSrcSpan annConName---- ---------------------------------------addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta ()-addAnnDeltaPos kw dp = tellKd (kw, dp)---- ----------------------------------------- | Enter a new AST element. Maintain SrcSpan stack-withAST :: Data a-        => GHC.Located a-        -> Delta b -> Delta b-withAST lss@(GHC.L ss _) action = do-  -- Calculate offset required to get to the start of the SrcSPan-  off <- gets apLayoutStart-  (resetAnns .  withSrcSpanDelta lss) (do--    let maskWriter s = s { annKds = []-                         , sortKeys = Nothing-                         , dwCapturedSpan = mempty }--    -- make sure all kds are relative to the start of the SrcSpan-    let spanStart = ss2pos ss--    cs <- do-      priorEndBeforeComments <- getPriorEnd-      if GHC.isGoodSrcSpan ss && priorEndBeforeComments < ss2pos ss-        then-          commentAllocation (priorComment spanStart) return-        else-          return []-    priorEndAfterComments <- getPriorEnd-    let edp = adjustDeltaForOffset-                -- Use the propagated offset if one is set-                -- Note that we need to use the new offset if it has-                -- changed.-                off (ss2delta priorEndAfterComments ss)-    -- Preparation complete, perform the action-    when (GHC.isGoodSrcSpan ss && priorEndAfterComments < ss2pos ss) (do-      modify (\s -> s { priorEndPosition    = ss2pos ss } ))-    (res, w) <- censor maskWriter (listen action)--    let kds = annKds w-        an = Ann-               { annEntryDelta        = edp-               , annPriorComments     = cs-               , annFollowingComments = [] -- only used in Transform and Print-               , annsDP               = kds-               , annSortKey           = sortKeys w-               , annCapturedSpan      = getFirst $ dwCapturedSpan w }--    addAnnotationsDelta an-     `debug` ("leaveAST:(annkey,an)=" ++ show (mkAnnKey lss,an))-    return res)--resetAnns :: Delta a -> Delta a-resetAnns action = do-  ans <- gets apAnns-  action <* modify (\s -> s { apAnns = ans })----- ------------------------------------------------------------------------ |Split the ordered list of comments into ones that occur prior to--- the give SrcSpan and the rest-priorComment :: Pos -> Comment -> Bool-priorComment start c = (ss2pos . commentIdentifier $ c) < start---- TODO:AZ: We scan the entire comment list here. It may be better to impose an--- invariant that the comments are sorted, and consume them as the pos--- advances. It then becomes a process of using `takeWhile p` rather than a full--- partition.-allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])-allocateComments = partition---- -----------------------------------------------------------------------addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta ()-addAnnotationWorker ann pa =-  -- Zero-width source spans are injected by the GHC Lexer when it puts virtual-  -- '{', ';' and '}' tokens in for layout-  unless (isPointSrcSpan pa) $-    do-      pe <- getPriorEnd-      ss <- getSrcSpan-      let p = ss2delta pe pa-      case (ann,isGoodDelta p) of-        (G GHC.AnnComma,False) -> return ()-        (G GHC.AnnSemi, False) -> return ()-        (G GHC.AnnOpen, False) -> return ()-        (G GHC.AnnClose,False) -> return ()-        _ -> do-          p' <- adjustDeltaForOffsetM p-          commentAllocation (priorComment (ss2pos pa)) (mapM_ (uncurry addDeltaComment))-#if __GLASGOW_HASKELL__ <= 710-          addAnnDeltaPos (checkUnicode ann pa) p'-#else-          addAnnDeltaPos ann p'-#endif-          setPriorEndAST pa-              `debug` ("addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" ++ show (showGhc ss,showGhc ss,pe,showGhc pa,p,p',ann))--#if __GLASGOW_HASKELL__ <= 710-checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId-checkUnicode gkw@(G kw) ss =-  if kw `Set.member` unicodeSyntax-    then-      let s = keywordToString gkw in-      if length s /= spanLength ss-        then AnnUnicode kw-        else gkw-  else-    gkw-  where-    unicodeSyntax = Set.fromList-      [ GHC.AnnDcolon-      , GHC.AnnDarrow-      , GHC.AnnForall-      , GHC.AnnRarrow-      , GHC.AnnLarrow-      , GHC.Annlarrowtail-      , GHC.Annrarrowtail-      , GHC.AnnLarrowtail-      , GHC.AnnRarrowtail]-checkUnicode kwid _ = kwid-#else--unicodeEquivalent :: GHC.AnnKeywordId -> [GHC.AnnKeywordId]-unicodeEquivalent kw =-  case Map.lookup kw unicodeSyntax of-    Nothing -> []-    Just kwu -> [kwu]-  where-    unicodeSyntax = Map.fromList-      [ (GHC.AnnDcolon,     GHC.AnnDcolonU)-      , (GHC.AnnDarrow,     GHC.AnnDarrowU)-      , (GHC.AnnForall,     GHC.AnnForallU)-      , (GHC.AnnRarrow,     GHC.AnnRarrowU)-      , (GHC.AnnLarrow,     GHC.AnnLarrowU)-      , (GHC.Annlarrowtail, GHC.AnnlarrowtailU)-      , (GHC.Annrarrowtail, GHC.AnnrarrowtailU)-      , (GHC.AnnLarrowtail, GHC.AnnLarrowtailU)-      , (GHC.AnnRarrowtail, GHC.AnnRarrowtailU)-#if __GLASGOW_HASKELL__ > 801-      , (GHC.AnnCloseB,     GHC.AnnCloseBU)-      , (GHC.AnnCloseQ,     GHC.AnnCloseQU)-      , (GHC.AnnOpenB,      GHC.AnnOpenBU)-      , (GHC.AnnOpenEQ,     GHC.AnnOpenEQU)-#endif-      ]-#endif----- -----------------------------------------------------------------------commentAllocation :: (Comment -> Bool)-                  -> ([(Comment, DeltaPos)] -> Delta a)-                  -> Delta a-commentAllocation p k = do-  cs <- getUnallocatedComments-  let (allocated,cs') = allocateComments p cs-  putUnallocatedComments cs'-  k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)---makeDeltaComment :: Comment -> Delta (Comment, DeltaPos)-makeDeltaComment c = do-  let pa = commentIdentifier c-  pe <- getPriorEnd-  let p = ss2delta pe pa-  p' <- adjustDeltaForOffsetM p-  setPriorEnd (ss2posEnd pa)-  return (c, p')--addDeltaComment :: Comment -> DeltaPos -> Delta ()-addDeltaComment d p = do-  addAnnDeltaPos (AnnComment d) p---- ------------------------------------------------------------------------- |If the first annotation has a smaller SrcSpan than the second, then mark it.-deltaMarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> Delta ()-deltaMarkAnnBeforeAnn annBefore annAfter = do-  ss <- getSrcSpan-  mb <- peekAnnotationDelta annBefore-  ma <- peekAnnotationDelta annAfter-  let-    before = sort $ filter (\s -> GHC.isSubspanOf s ss) mb-    after  = sort $ filter (\s -> GHC.isSubspanOf s ss) ma-  case (before,after) of-    (b:_, a:_) -> when (b < a) $ addDeltaAnnotation annBefore-    _ -> return ()---- ------------------------------------------------------------------------- | Look up and add a Delta annotation at the current position, and--- advance the position to the end of the annotation-addDeltaAnnotation :: GHC.AnnKeywordId -> Delta ()-addDeltaAnnotation ann' = do-  ss <- getSrcSpan-  (ma,ann) <- getOneAnnotationDelta ann'-  case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier-    []     -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann))-    [pa]   -> addAnnotationWorker (G ann) pa-    (pa:_) -> addAnnotationWorker (G ann) pa `warn` ("addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma))---- | Look up and add a Delta annotation at the current position, and--- advance the position to the end of the annotation-addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> Delta ()-addDeltaAnnotationLs ann off = do-  ss <- getSrcSpan-  ma <- peekAnnotationDelta ann-  let ma' = filter (\s -> GHC.isSubspanOf s ss) ma-  case drop off ma' of-    [] -> return ()-        `debug` ("addDeltaAnnotationLs:missed:(off,ann,ma)=" ++ showGhc (off,ss,ann))-    (pa:_) -> addAnnotationWorker (G ann) pa---- | Look up and add possibly multiple Delta annotation at the current--- position, and advance the position to the end of the annotations-addDeltaAnnotations :: GHC.AnnKeywordId -> Delta ()-addDeltaAnnotations ann = do-  (ma,kw) <- getAnnotationDelta ann-  let do_one ap' = addAnnotationWorker (G kw) ap'-                    `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))-  mapM_ do_one (sort ma)---- | Look up and add possibly multiple Delta annotations enclosed by--- the current SrcSpan at the current position, and advance the--- position to the end of the annotations-addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta ()-addDeltaAnnotationsInside ann = do-  ss <- getSrcSpan-  ma <- peekAnnotationDelta ann-  let do_one ap' = addAnnotationWorker (G ann) ap'-                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))-  let filtered = sort $ filter (\s -> GHC.isSubspanOf s ss) ma-  mapM_ do_one filtered---- ----------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 800-addDeltaAnnotationInstead :: GHC.AnnKeywordId  -> KeywordId -> Delta ()-addDeltaAnnotationInstead ann' kw = do-  ss <- getSrcSpan-  (ma,ann) <- getOneAnnotationDelta ann'-  case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier-    []     -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann))-    [pa]   -> addAnnotationWorker kw pa-    (pa:_) -> addAnnotationWorker kw pa `warn` ("addDeltaAnnotationInstead:(ss,ann,kw,ma)=" ++ showGhc (ss,ann,kw,ma))-#endif--- ------------------------------------------------------------------------- | Look up and add possibly multiple Delta annotations not enclosed by--- the current SrcSpan at the current position, and advance the--- position to the end of the annotations--- The first argument (gann) is the one to look up in the GHC annotations, the--- second is the one to apply in the ghc-exactprint ones. These are different--- for GHC.AnnSemi mapping to AnnSemiSep, to ensure that it reflects the ';'--- outside the current span.-addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta ()-addDeltaAnnotationsOutside gann ann = do-  ss <- getSrcSpan-  (ma,kw) <- getAndRemoveAnnotationDelta ss gann-  let do_one ap' = if ann == AnnSemiSep-                     then addAnnotationWorker ann    ap'-                     else addAnnotationWorker (G kw) ap'-  mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma)---- | Add a Delta annotation at the current position, and advance the--- position to the end of the annotation-addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ()-addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s--addEofAnnotation :: Delta ()-addEofAnnotation = do-  pe <- getPriorEnd-  (ma,_kw) <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)-  case ma of-    [] -> return ()-    (pa:pss) -> do-      commentAllocation (const True) (mapM_ (uncurry addDeltaComment))-      let DP (r,c) = ss2delta pe pa-      addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1))-      setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss)---- -----------------------------------------------------------------------countAnnsDelta :: GHC.AnnKeywordId -> Delta Int-countAnnsDelta ann = do-  ma <- peekAnnotationDelta ann-  return (length ma)-
+ src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs view
@@ -0,0 +1,5135 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE BlockArguments       #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf           #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+{-# LANGUAGE UndecidableInstances  #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-}++module Language.Haskell.GHC.ExactPrint.ExactPrint+  (+    ExactPrint(..)+  , exactPrint+  , exactPrintWithOptions+  , makeDeltaAst++  -- * Configuration+  , EPOptions(epTokenPrint, epWhitespacePrint)+  , stringOptions+  , epOptions+  , deltaOptions++  -- * Utility+  , setAnchorAn+  ) where++import GHC+import GHC.Base (NonEmpty(..))+import GHC.Core.Coercion.Axiom (Role(..))+import qualified GHC.Data.BooleanFormula as BF+import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict+import GHC.TypeLits+import GHC.Types.Basic hiding (EP)+import GHC.Types.Fixity+import GHC.Types.ForeignCall+import GHC.Types.Name.Reader+import GHC.Types.PkgQual+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import GHC.Types.Var+import GHC.Unit.Module.Warnings+import GHC.Utils.Misc+import GHC.Utils.Outputable hiding ( (<>) )+import GHC.Utils.Panic++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import Control.Monad (forM, when, unless)+import Control.Monad.Identity (Identity(..))+import qualified Control.Monad.Reader as Reader+import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask)+import Control.Monad.Trans (lift)+import Data.Data ( Data )+import Data.Dynamic+import Data.Foldable+import Data.Functor.Const+import Data.Typeable+import Data.List ( partition, sort, sortBy)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import Data.Maybe ( isJust, mapMaybe )+import Data.Void++import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Types++-- ---------------------------------------------------------------------++exactPrint :: ExactPrint ast => ast -> String+exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast))++-- | The additional option to specify the printing configuration.+exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m)+                      => EPOptions m b+                      -> ast+                      -> m (ast, b)+exactPrintWithOptions r ast =+    runEP r (markAnnotated ast)++-- | Transform concrete annotations into relative annotations.+-- This should be unnecessary from GHC 9.10+makeDeltaAst :: ExactPrint ast => ast -> ast+makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast))++------------------------------------------------------++type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a++runEP :: (Monad m)+      => EPOptions m w+      -> EP w m a -> m (a, w)+runEP epReader action = do+  (ast, w) <- evalRWST action epReader defaultEPState+  return (ast, output w)++-- ---------------------------------------------------------------------++defaultEPState :: EPState+defaultEPState = EPState+             { uAnchorSpan = badRealSrcSpan+             , uExtraDP = Nothing+             , uExtraDPReturn = Nothing+             , pAcceptSpan = False++             , epPos       = (1,1)+             , pMarkLayout = False+             , pLHS = LayoutStartCol 1++             , dPriorEndPosition = (1,1)+             , dMarkLayout = False+             , dLHS        = LayoutStartCol 1++             , epComments = []+             , epCommentsApplied = []+             , epEof = Nothing+             }+++-- ---------------------------------------------------------------------+-- The EP monad and basic combinators++-- | The R part of RWS. The environment. Updated via 'local' as we+-- enter a new AST element, having a different anchor point.+data EPOptions m a = EPOptions+            { epTokenPrint :: String -> m a+            , epWhitespacePrint :: String -> m a+            }++-- | Helper to create a 'EPOptions'+epOptions :: (String -> m a)+          -> (String -> m a)+          -> EPOptions m a+epOptions tokenPrint wsPrint = EPOptions+             { epWhitespacePrint = wsPrint+             , epTokenPrint = tokenPrint+             }++-- | Options which can be used to print as a normal String.+stringOptions :: EPOptions Identity String+stringOptions = epOptions return return++-- | Options which can be used to simply update the AST to be in delta+-- form, without generating output+deltaOptions :: EPOptions Identity ()+deltaOptions = epOptions (\_ -> return ()) (\_ -> return ())++data EPWriter a = EPWriter+              { output :: !a }++instance Monoid w => Semigroup (EPWriter w) where+  (EPWriter a) <> (EPWriter b) = EPWriter (a <> b)++instance Monoid w => Monoid (EPWriter w) where+  mempty = EPWriter mempty++data EPState = EPState+             { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST+                                          -- reference frame, from+                                          -- Annotation+             , uExtraDP :: !(Maybe EpaLocation) -- ^ Used to anchor a+                                                -- list+             , uExtraDPReturn :: !(Maybe (SrcSpan, DeltaPos))+                  -- ^ Used to return Delta version of uExtraDP+             , pAcceptSpan :: Bool -- ^ When we have processed an+                                   -- entry of EpaDelta, accept the+                                   -- next `EpaSpan` start as the+                                   -- current output position. i.e. do+                                   -- not advance epPos. Achieved by+                                   -- setting dPriorEndPosition to the+                                   -- end of the span.++             -- Print phase+             , epPos        :: !Pos -- ^ Current output position+             , pMarkLayout  :: !Bool+             , pLHS   :: !LayoutStartCol++             -- Delta phase+             , dPriorEndPosition :: !Pos -- ^ End of Position reached+                                         -- when processing the+                                         -- preceding element+             , dMarkLayout :: !Bool+             , dLHS        :: !LayoutStartCol++             -- Shared+             , epComments :: ![Comment]+             , epCommentsApplied :: ![[Comment]]+             , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan))+             }++-- ---------------------------------------------------------------------++-- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry+class HasEntry ast where+  fromAnn :: ast -> Entry++class HasTrailing a where+  trailing :: a -> [TrailingAnn]+  setTrailing :: a -> [TrailingAnn] -> a++setAnchorEpa :: (HasTrailing an)+             => EpAnn an -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn an+setAnchorEpa (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing an ts)          cs++setAnchorHsModule :: HsModule GhcPs -> EpaLocation -> EpAnnComments -> HsModule GhcPs+setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }+  where+    anc' = anc+    an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' [] cs++setAnchorAn :: (HasTrailing an)+             => LocatedAn an a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> LocatedAn an a+setAnchorAn (L (EpAnn _ an _) a) anc ts cs = (L (EpAnn anc (setTrailing an ts) cs) a)+     -- `debug` ("setAnchorAn: anc=" ++ showAst anc)++setAnchorEpaL :: EpAnn (AnnList l) -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn (AnnList l)+setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = Nothing}) ts) cs++-- ---------------------------------------------------------------------++-- | Key entry point.  Switches to an independent AST element with its+-- own annotation, calculating new offsets, etc+markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a+markAnnotated a = enterAnn (getAnnotationEntry a) a++-- | For HsModule, because we do not have a proper SrcSpan, we must+-- indicate to flush trailing comments when done.+data FlushComments = FlushComments+                   | NoFlushComments+                   deriving (Eq, Show)++-- | For GenLocated SrcSpan, we construct an entry location but cannot update it.+data CanUpdateAnchor = CanUpdateAnchor+                     | CanUpdateAnchorOnly+                     | NoCanUpdateAnchor+                   deriving (Eq, Show, Data)++data Entry = Entry EpaLocation [TrailingAnn] EpAnnComments FlushComments CanUpdateAnchor+           | NoEntryVal++-- | For flagging whether to capture comments in an EpaDelta or not+data CaptureComments = CaptureComments+                     | NoCaptureComments++mkEntry :: EpaLocation -> [TrailingAnn] -> EpAnnComments -> Entry+mkEntry anc ts cs = Entry anc ts cs NoFlushComments CanUpdateAnchor++instance (HasTrailing a) => HasEntry (EpAnn a) where+  fromAnn (EpAnn anc a cs) = mkEntry anc (trailing a) cs++-- ---------------------------------------------------------------------++instance HasTrailing NoEpAnns where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing EpaLocation where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing EpAnnSumPat where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing (AnnList a) where+  trailing a = al_trailing a+  setTrailing a ts = a { al_trailing = ts }++instance HasTrailing AnnListItem where+  trailing a = lann_trailing a+  setTrailing a ts = a { lann_trailing = ts }++instance HasTrailing AnnPragma where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnContext where+  trailing (AnnContext ma _opens _closes)+    = case ma of+      Just r -> [AddDarrowAnn r]+      _ -> []++  setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just r}+  setTrailing a [] = a{ac_darrow = Nothing}+  setTrailing a ts = error $ "Cannot setTrailing " ++ showAst ts ++ " for " ++ showAst a+++instance HasTrailing AnnParen where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnsIf where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing EpAnnHsCase where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnFieldLabel where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnProjection where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnExplicitSum where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing GrhsAnn where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnSig where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing HsRuleBndrsAnn where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing EpAnnImportDecl where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing AnnsModule where+  -- Report none, as all are used internally+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing NameAnn where+  trailing a = nann_trailing a+  setTrailing a ts = a { nann_trailing = ts }++instance HasTrailing Bool where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing (TokForall, TokRarrow) where+  trailing _ = []+  setTrailing a _ = a++instance HasTrailing (TokForall, EpToken ".") where+  trailing _ = []+  setTrailing a _ = a++-- ---------------------------------------------------------------------++fromAnn' :: (HasEntry a) => a -> Entry+fromAnn' an = case fromAnn an of+  NoEntryVal -> NoEntryVal+  Entry a ts c _ u -> Entry a ts c FlushComments u++-- ---------------------------------------------------------------------++astId :: (Typeable a) => a -> String+astId a = show (typeOf a)++cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a]+cua CanUpdateAnchor f = f+cua CanUpdateAnchorOnly _ = return []+cua NoCanUpdateAnchor _ = return []++-- | "Enter" an annotation, by using the associated 'anchor' field as+-- the new reference point for calculating all DeltaPos positions.+-- This is the heart of the exact printing process.+--+-- This is combination of the ghc=exactprint Delta.withAST and+-- Print.exactPC functions and effectively does the delta processing+-- immediately followed by the print processing.  JIT ghc-exactprint.+enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a+enterAnn NoEntryVal a = do+  p <- getPosP+  debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a)+  r <- exact a+  debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)+  return r+enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do+  acceptSpan <- getAcceptSpan+  setAcceptSpan False+  case anchor' of+    EpaDelta _ _ _ -> setAcceptSpan True+    _              -> return ()+  p <- getPosP+  pe0 <- getPriorEndD+  debugM $ "enterAnn:starting:(anchor',p,pe,a) =" ++ show (showAst anchor', p, pe0, astId a)+  prevAnchor <- getAnchorU+  let curAnchor = case anchor' of+        EpaSpan (RealSrcSpan r _) -> r+        _ -> prevAnchor+  debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)+  case canUpdateAnchor of+    CanUpdateAnchor -> pushAppliedComments+    _ -> return ()+  case anchor' of+    EpaDelta _ _ dcs -> do+      debugM $ "enterAnn:Delta:Flushing comments"+      flushComments []+      debugM $ "enterAnn:Delta:Printing prior comments:" ++ showGhc (priorComments cs)+      mapM_ printOneComment (concatMap tokComment $ priorComments cs)+      debugM $ "enterAnn:Delta:Printing EpaDelta comments:" ++ showGhc dcs+      mapM_ printOneComment (concatMap tokComment dcs)+    _ -> do+      debugM $ "enterAnn:Adding comments:" ++ showGhc (priorComments cs)+      addCommentsA (priorComments cs)+  debugM $ "enterAnn:Added comments"+  printCommentsBefore curAnchor+  priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop+  -- -------------------------+  case anchor' of+    EpaDelta _ dp _ -> do+      debugM $ "enterAnn: EpaDelta:" ++ show dp+      -- Set the original anchor as prior end, so the rest of this AST+      -- fragment has a reference+      setPriorEndNoLayoutD (ss2pos curAnchor)+    _ -> do+      if acceptSpan+        then setPriorEndNoLayoutD (ss2pos curAnchor)+        else return ()++  -- -------------------------+  if ((fst $ fst $ rs2range curAnchor) >= 0)+    then+      setAnchorU curAnchor+    else+      debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor)+  -- -------------------------------------------------------------------+  -- Make sure the running dPriorEndPosition gets updated according to+  -- the change in the current anchor.++  -- Compute the distance from dPriorEndPosition to the start of the new span.++  -- While processing in the context of the prior anchor, we choose to+  -- enter a new Anchor, which has a defined position relative to the+  -- prior anchor, even if we do not actively output anything at that+  -- point.+  -- Is this edp?++  -- -------------------------------------------------------------------+  -- The first part corresponds to the delta phase, so should only use+  -- delta phase variables -----------------------------------+  -- Calculate offset required to get to the start of the SrcSPan+  !off <- getLayoutOffsetD+  priorEndAfterComments <- getPriorEndD+  let edp' = adjustDeltaForOffset+               -- Use the propagated offset if one is set+               -- Note that we need to use the new offset if it has+               -- changed.+               off (ss2delta priorEndAfterComments curAnchor)+  debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor)+  let edp'' = case anchor' of+        EpaDelta _ dp _ -> dp+        _ -> edp'+  -- ---------------------------------------------+  med <- getExtraDP+  setExtraDP Nothing+  let (edp, medr) = case med of+        Nothing -> (edp'', Nothing)+        Just (EpaDelta _ dp _) -> (dp, Nothing)+                   -- Replace original with desired one. Allows all+                   -- list entry values to be DP (1,0)+        Just (EpaSpan ss@(RealSrcSpan r _)) -> (dp, Just (ss, dp))+          where+            dp = adjustDeltaForOffset+                   off (ss2delta priorEndAfterComments r)+        Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r+  when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp)+  when (isJust medr) $ setExtraDPReturn medr+  -- ---------------------------------------------+  -- Preparation complete, perform the action+  let spanStart = ss2pos curAnchor+  when (priorEndAfterComments < spanStart) (do+    debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart+    modify (\s -> s { dPriorEndPosition    = spanStart } ))++  debugM $ "enterAnn: (anchor', curAnchor):" ++ show (anchor', rs2range curAnchor)+  -- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)+  p0 <- getPosP+  d <- getPriorEndD+  debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d)++  -- end of delta phase processing+  -- -------------------------------------------------------------------+  -- start of print phase processing++  advance edp+  debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor')+  a' <- exact a+  debugM $ "enterAnn:exact a done:" ++ show (showAst anchor')++  -- Core recursive exactprint done, start end of Entry processing++  when (flush == FlushComments) $ do+    debugM $ "flushing comments in enterAnn:" ++ showAst (cs, getFollowingComments cs)+    flushComments (getFollowingComments cs)+    debugM $ "flushing comments in enterAnn done"++  !eof <- getEofPos+  case eof of+    Nothing -> return ()+    Just (pos, prior) -> do+       let dp = if pos == prior+             then (DifferentLine 1 0)+             else adjustDeltaForOffset off (origDelta pos prior)+       debugM $ "EOF:(pos,posend,prior,off,dp) =" ++ show (ss2pos pos, ss2posEnd pos, ss2pos prior, off, dp)+       printStringAtLsDelta dp ""+       setEofPos Nothing -- Only do this once++  -- Deal with exit from the current anchor+  when (flush == NoFlushComments) $ do+    printCommentsIn curAnchor -- Make sure all comments in the span are printed++  p1 <- getPosP+  pe1 <- getPriorEndD+  debugM $ "enterAnn:done:(anchor,p,pe,a) =" ++ show (showAst anchor', p1, pe1, astId a')++  case anchor' of+    EpaDelta _ _ _ -> return ()+    EpaSpan (RealSrcSpan rss _) -> do+      setAcceptSpan False+      setPriorEndD (snd $ rs2range rss)+    EpaSpan _ -> return ()++  -- Outside the anchor, mark any trailing+  postCs <- cua canUpdateAnchor takeAppliedCommentsPop+  following <- if (flush == NoFlushComments)+          then do+              let (before, after) = splitAfterTrailingAnns trailing_anns+                                                           (getFollowingComments cs)+              addCommentsA before+              return after+           else return []+  !trailing' <- markTrailing trailing_anns+  addCommentsA following++  -- Update original anchor, comments based on the printing process+  -- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan+  let newAnchor = case anchor' of+          EpaSpan s -> EpaDelta s         edp []+          _         -> EpaDelta noSrcSpan edp []+  let r = case canUpdateAnchor of+            CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)+            CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments+            NoCanUpdateAnchor -> a'+  return r++-- ---------------------------------------------------------------------++-- | Split the span following comments into ones that occur prior to+-- the last trailing ann, and ones after.+splitAfterTrailingAnns :: [TrailingAnn] -> [LEpaComment] -> ([LEpaComment], [LEpaComment])+splitAfterTrailingAnns [] cs = ([], cs)+splitAfterTrailingAnns tas cs = (before, after)+  where+    trailing_loc ta = case ta_location ta of+        EpaSpan (RealSrcSpan s _) -> [s]+        _ -> []+    (before, after) = case reverse (concatMap trailing_loc tas) of+        [] -> ([],cs)+        (s:_) -> (b,a)+          where+            s_pos = ss2pos s+            (b,a) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > s_pos)+                          cs++-- ---------------------------------------------------------------------++addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()+addCommentsA csNew = addComments False (concatMap tokComment csNew)++{-+TODO: When we addComments, some may have an anchor that is no longer+valid, as it has been moved and has an anchor_op.++Does an Anchor even make sense for a comment, perhaps it should be an+EpaLocation?++How do we sort them? do we assign a location based on when we add them+to the list, based on the current output pos?  Except the offset is a+delta compared to a reference location.  Need to nail the concept of+the reference location.++By definition it is the current anchor, so work against that. And that+also means that the first entry comment that has moved should not have+a line offset.+-}+addComments :: (Monad m, Monoid w) => Bool -> [Comment] -> EP w m ()+addComments sortNeeded csNew = do+  debugM $ "addComments:csNew" ++ show csNew+  cs <- getUnallocatedComments+  debugM $ "addComments:cs" ++ show cs+  -- We can only sort the comments if we are in the first phase,+  -- where all comments have locations. If any have EpaDelta the+  -- sort will fail, so we do not try.+  if sortNeeded && all noDelta (csNew ++ cs)+    then putUnallocatedComments (sort (cs ++ csNew))+    else putUnallocatedComments (cs ++ csNew)++noDelta :: Comment -> Bool+noDelta c = case commentLoc c of+    EpaSpan _ -> True+    _ -> False++-- ---------------------------------------------------------------------++-- | Just before we print out the EOF comments, flush the remaining+-- ones in the state.+flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()+flushComments !trailing_anns = do+  debugM $ "flushComments entered: " ++ showAst trailing_anns+  addCommentsA trailing_anns+  debugM $ "flushComments after addCommentsA"+  cs <- getUnallocatedComments+  debugM $ "flushComments: got cs"+  debugM $ "flushing comments starting: cs" ++ showAst cs+  mapM_ printOneComment cs+  putUnallocatedComments []+  debugM $ "flushing comments done"++-- ---------------------------------------------------------------------++epTokensToComments :: (Monad m, Monoid w)+  => String -> [EpToken tok] -> EP w m ()+epTokensToComments kw toks+  = addComments True (concatMap (\tok ->+                                   case tok of+                                     EpTok ss -> [mkKWComment kw (epaToNoCommentsLocation ss)]+                                     NoEpTok -> []) toks)++-- ---------------------------------------------------------------------++-- Temporary function to simply reproduce the "normal" pretty printer output+withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a+withPpr a = do+  ss <- getAnchorU+  debugM $ "withPpr: ss=" ++ show ss+  printStringAtRs' ss (showPprUnsafe a)+  return a++-- ---------------------------------------------------------------------++-- | An AST fragment with an annotation must be able to return the+-- requirements for nesting another one, captured in an 'Entry', and+-- to be able to use the rest of the exactprint machinery to print the+-- element.  In the analogy to Outputable, 'exact' plays the role of+-- 'ppr'.+class (Typeable a) => ExactPrint a where+  getAnnotationEntry :: a -> Entry+  setAnnotationAnchor :: a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> a+  exact :: (Monad m, Monoid w) => a -> EP w m a++-- ---------------------------------------------------------------------+-- Start of utility functions+-- ---------------------------------------------------------------------++printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m ()+printSourceText (NoSourceText) txt   =  printStringAdvance txt >> return ()+printSourceText (SourceText   txt) _ =  printStringAdvance (unpackFS txt) >> return ()++printSourceTextAA :: (Monad m, Monoid w) => SourceText -> String -> EP w m ()+printSourceTextAA (NoSourceText) txt   = printStringAdvanceA  txt >> return ()+printSourceTextAA (SourceText   txt) _ = printStringAdvanceA  (unpackFS txt) >> return ()++-- ---------------------------------------------------------------------++printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation+printStringAtRs pa str = printStringAtRsC CaptureComments pa str++printStringAtRsC :: (Monad m, Monoid w)+  => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation+printStringAtRsC capture pa str = do+  debugM $ "printStringAtRsC: pa=" ++ showAst pa+  printCommentsBefore pa+  pe <- getPriorEndD+  debugM $ "printStringAtRsC:pe=" ++ show pe+  let p = ss2delta pe pa+  p' <- adjustDeltaForOffsetM p+  debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p')+  printStringAtLsDelta p' str+  setPriorEndASTD pa+  cs' <- case capture of+    CaptureComments -> takeAppliedComments+    NoCaptureComments -> return []+  debugM $ "printStringAtRsC:cs'=" ++ show cs'+  debugM $ "printStringAtRsC:p'=" ++ showAst p'+  debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta noSrcSpan p' NoComments)+  debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta noSrcSpan p' (map comment2LEpaComment cs'))+  return (EpaDelta (RealSrcSpan pa Strict.Nothing) p' (map comment2LEpaComment cs'))++printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m ()+printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return ()++-- ---------------------------------------------------------------------++printStringAtMLoc' :: (Monad m, Monoid w)+  => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation)+printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s+printStringAtMLoc' Nothing s = do+  printStringAtLsDelta (SameLine 1) s+  return (Just (EpaDelta noSrcSpan (SameLine 1) []))++printStringAtMLocL :: (Monad m, Monoid w)+  => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a)+printStringAtMLocL (EpAnn anc an cs) l s = do+  r <- go (view l an) s+  return (EpAnn anc (set l r an) cs)+  where+    go (Just aa) str = Just <$> printStringAtAA aa str+    go Nothing str = do+      printStringAtLsDelta (SameLine 1) str+      return (Just (EpaDelta noSrcSpan (SameLine 1) []))++printStringAdvanceA :: (Monad m, Monoid w) => String -> EP w m ()+printStringAdvanceA str = printStringAtAA (EpaDelta noSrcSpan (SameLine 0) []) str >> return ()++printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation+printStringAtAA el str = printStringAtAAC CaptureComments el str++printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation+printStringAtNC el str = do+  el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str+  return (epaToNoCommentsLocation el')++printStringAtAAC :: (Monad m, Monoid w)+  => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation+printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s+printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss+printStringAtAAC capture (EpaDelta ss d cs) s = do+  mapM_ printOneComment $ concatMap tokComment cs+  pe1 <- getPriorEndD+  p1 <- getPosP+  printStringAtLsDelta d s+  p2 <- getPosP+  pe2 <- getPriorEndD+  debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2)+  setPriorEndASTPD (pe1,pe2)+  cs' <- case capture of+    CaptureComments -> takeAppliedComments+    NoCaptureComments -> return []+  debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs')+  return (EpaDelta ss d (map comment2LEpaComment cs'))++-- ---------------------------------------------------------------------++markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation+markExternalSourceTextE l NoSourceText txt   = printStringAtAA l txt+markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt)++-- ---------------------------------------------------------------------++markLensBracketsO :: (Monad m, Monoid w)+  => EpAnn a -> Lens a AnnListBrackets -> EP w m (EpAnn a)+markLensBracketsO epann l = markLensBracketsO' epann (lepa . l)++markLensBracketsO' :: (Monad m, Monoid w)+  => a -> Lens a AnnListBrackets -> EP w m a+markLensBracketsO' a l =+  case view l a of+    ListParens o c -> do+      o' <- markEpToken o+      return (set l (ListParens o' c) a)+    ListBraces o c -> do+      o' <- markEpToken o+      return (set l (ListBraces o' c) a)+    ListSquare o c -> do+      o' <- markEpToken o+      return (set l (ListSquare o' c) a)+    ListBanana o c -> do+      o' <- markEpUniToken o+      return (set l (ListBanana o' c) a)+    ListNone -> return (set l ListNone a)++markLensBracketsC :: (Monad m, Monoid w)+  => EpAnn a -> Lens a AnnListBrackets -> EP w m (EpAnn a)+markLensBracketsC epann l = markLensBracketsC' epann (lepa . l)++markLensBracketsC' :: (Monad m, Monoid w)+  => a -> Lens a AnnListBrackets -> EP w m a+markLensBracketsC' a l =+  case view l a of+    ListParens o c -> do+      c' <- markEpToken c+      return (set l (ListParens o c') a)+    ListBraces o c -> do+      c' <- markEpToken c+      return (set l (ListBraces o c') a)+    ListSquare o c -> do+      c' <- markEpToken c+      return (set l (ListSquare o c') a)+    ListBanana o c -> do+      c' <- markEpUniToken c+      return (set l (ListBanana o c') a)+    ListNone -> return (set l ListNone a)++-- -------------------------------------++markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)+  => EpToken tok -> EP w m (EpToken tok)+markEpToken NoEpTok = return NoEpTok+markEpToken (EpTok aa) = do+  aa' <- printStringAtAA aa (symbolVal (Proxy @tok))+  return (EpTok aa')++markEpToken1 :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)+  => [EpToken tok] -> EP w m [EpToken tok]+markEpToken1 [] = return []+markEpToken1 (h:t) = do+  h' <- markEpToken h+  return (h':t)++markEpUniToken :: forall m w tok utok . (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok)+  => EpUniToken tok utok -> EP w m (EpUniToken tok utok)+markEpUniToken NoEpUniTok = return NoEpUniTok+markEpUniToken (EpUniTok aa isUnicode)  = do+  aa' <- case isUnicode of+    NormalSyntax  -> printStringAtAA aa (symbolVal (Proxy @tok))+    UnicodeSyntax -> printStringAtAA aa (symbolVal (Proxy @utok))+  return (EpUniTok aa' isUnicode)++-- ---------------------------------------------------------------------++markAnnOpen' :: (Monad m, Monoid w)+  => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation)+markAnnOpen' ms NoSourceText txt   = printStringAtMLoc' ms txt+markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt++markAnnOpen'' :: (Monad m, Monoid w)+  => EpaLocation -> SourceText -> String -> EP w m EpaLocation+markAnnOpen'' el NoSourceText txt   = printStringAtAA el txt+markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt++-- ---------------------------------------------------------------------++markOpeningParen, markClosingParen :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen+markOpeningParen an = markParenO an+markClosingParen an = markParenC an++markParenO :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen+markParenO (AnnParens o c) = do+  o' <- markEpToken o+  return (AnnParens o' c)+markParenO (AnnParensHash o c) = do+  o' <- markEpToken o+  return (AnnParensHash o' c)+markParenO (AnnParensSquare o c) = do+  o' <- markEpToken o+  return (AnnParensSquare o' c)++markParenC :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen+markParenC (AnnParens o c) = do+  c' <- markEpToken c+  return (AnnParens o c')+markParenC (AnnParensHash o c) = do+  c' <- markEpToken c+  return (AnnParensHash o c')+markParenC (AnnParensSquare o c) = do+  c' <- markEpToken c+  return (AnnParensSquare o c')++-- ---------------------------------------------------------------------+-- Bare bones Optics+-- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html++type Lens    a b = forall f . Functor f => (b -> f        b) -> (a -> f        a)+type Getting a b =                         (b -> Const  b b) -> (a -> Const b  a)+type ASetter a b =                         (b -> Identity b) -> (a -> Identity a)++view :: MonadReader s m => Getting s a -> m a+view l = Reader.asks (getConst . l Const)+{-# INLINE view #-}++over :: ASetter a b -> (b -> b) -> (a -> a)+over l f = runIdentity . l (Identity . f)+{-# INLINE over #-}++set  :: Lens a b -> b -> a -> a+set lens b = over lens (\_ -> b)+{-# INLINE set #-}++{-+Question: How do I combine lenses?++Answer: You compose them, using function composition (Yes, really!)++You can think of the function composition operator as having this type:++(.) :: Lens' a b -> Lens' b c -> Lens' a c+-}++-- ---------------------------------------------------------------------+-- Lenses++-- data EpAnn ann+--   = EpAnn { entry   :: !Anchor+--            , anns     :: !ann+--            , comments :: !EpAnnComments+--            }++lepa :: Lens (EpAnn a) a+lepa k epAnn = fmap (\newAnns -> epAnn { anns = newAnns })+                    (k (anns epAnn))++-- data AnnsModule+--   = AnnsModule {+--     am_sig :: Maybe (EpToken "signature"),+--     am_mod :: Maybe (EpToken "module"),+--     am_where :: Maybe (EpToken "where"),+--     am_decls :: [TrailingAnn],+--     am_cs    :: [LEpaComment],+--     am_eof   :: Maybe (RealSrcSpan, RealSrcSpan)+--     } deriving (Data, Eq)++lam_mod :: Lens AnnsModule (EpToken "module")+lam_mod k annsModule = fmap (\newAnns -> annsModule { am_mod = newAnns })+                            (k (am_mod annsModule))++lam_where :: Lens AnnsModule (EpToken "where")+lam_where k annsModule = fmap (\newAnns -> annsModule { am_where = newAnns })+                              (k (am_where annsModule))++-- lam_decls :: Lens AnnsModule AnnList+-- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns })+--                               (k (am_decls annsModule))+++-- data EpAnnImportDecl = EpAnnImportDecl+--   { importDeclAnnImport    :: EpToken "import" -- ^ The location of the @import@ keyword+--   , importDeclAnnPragma    :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively+--   , importDeclAnnSafe      :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword+--   , importDeclAnnLevel     :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword+--   , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword+--   , importDeclAnnPackage   :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@)+--   , importDeclAnnAs        :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword+--   } deriving (Data)++limportDeclAnnImport :: Lens EpAnnImportDecl (EpToken "import")+limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new })+                                     (k (importDeclAnnImport annImp))++-- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation))+-- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new })+--                                      (k (importDeclAnnPragma annImp))++limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe (EpToken "safe"))+limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new })+                                     (k (importDeclAnnSafe annImp))++limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel)+limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new })+                                     (k (importDeclAnnLevel annImp))++limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified"))+limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new })+                                     (k (importDeclAnnQualified annImp))++limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation)+limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new })+                                     (k (importDeclAnnPackage annImp))++-- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation)+-- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new })+--                                      (k (importDeclAnnAs annImp))++-- -------------------------------------++-- data AnnList+--   = AnnList {+--       al_anchor    :: Maybe Anchor, -- ^ start point of a list having layout+--       al_brackets  :: !AnnListBrackets,+--       al_semis     :: [EpToken ";"], -- decls+--       al_rest      :: !a,+--       al_trailing  :: [TrailingAnn] -- ^ items appearing after the+--                                     -- list, such as '=>' for a+--                                     -- context+--       } deriving (Data,Eq)++lal_brackets :: Lens (AnnList l) AnnListBrackets+lal_brackets k parent = fmap (\new -> parent { al_brackets = new })+                           (k (al_brackets parent))++lal_semis :: Lens (AnnList l) [EpToken ";"]+lal_semis k parent = fmap (\new -> parent { al_semis = new })+                           (k (al_semis parent))++lal_rest :: Lens (AnnList l) l+lal_rest k parent = fmap (\new -> parent { al_rest = new })+                           (k (al_rest parent))++-- -------------------------------------++lfst :: Lens (a,b) a+lfst k parent = fmap (\new -> (new, snd parent))+                     (k (fst parent))++lsnd :: Lens (b,a) a+lsnd k parent = fmap (\new -> (fst parent, new))+                     (k (snd parent))++-- -------------------------------------+-- data AnnExplicitSum+--   = AnnExplicitSum {+--       aesOpen       :: EpaLocation,+--       aesBarsBefore :: [EpToken "|"],+--       aesBarsAfter  :: [EpToken "|"],+--       aesClose      :: EpaLocation+--       } deriving Data++laesOpen :: Lens AnnExplicitSum EpaLocation+laesOpen k parent = fmap (\new -> parent { aesOpen = new })+                         (k (aesOpen parent))++laesBarsBefore :: Lens AnnExplicitSum [EpToken "|"]+laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new })+                               (k (aesBarsBefore parent))++laesBarsAfter :: Lens AnnExplicitSum [EpToken "|"]+laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new })+                               (k (aesBarsAfter parent))++laesClose :: Lens AnnExplicitSum EpaLocation+laesClose k parent = fmap (\new -> parent { aesClose = new })+                               (k (aesClose parent))++-- -------------------------------------+-- data AnnFieldLabel+--   = AnnFieldLabel {+--       afDot :: Maybe (EpToken ".")+--       } deriving Data++lafDot :: Lens AnnFieldLabel (Maybe (EpToken "."))+lafDot k parent = fmap (\new -> parent { afDot = new })+                         (k (afDot parent))++-- -------------------------------------+-- data AnnProjection+--   = AnnProjection {+--       apOpen  :: EpToken "(",+--       apClose :: EpToken ")"+--       } deriving Data++lapOpen :: Lens AnnProjection (EpToken "(")+lapOpen k parent = fmap (\new -> parent { apOpen = new })+                         (k (apOpen parent))++lapClose :: Lens AnnProjection (EpToken ")")+lapClose k parent = fmap (\new -> parent { apClose = new })+                         (k (apClose parent))++-- -------------------------------------+-- data AnnsIf+--   = AnnsIf {+--       aiIf       :: EpToken "if",+--       aiThen     :: EpToken "then",+--       aiElse     :: EpToken "else",+--       aiThenSemi :: Maybe (EpToken ";"),+--       aiElseSemi :: Maybe (EpToken ";")+--       } deriving Data++laiIf :: Lens AnnsIf (EpToken "if")+laiIf k parent = fmap (\new -> parent { aiIf = new })+                      (k (aiIf parent))++laiThen :: Lens AnnsIf (EpToken "then")+laiThen k parent = fmap (\new -> parent { aiThen = new })+                        (k (aiThen parent))++laiElse :: Lens AnnsIf (EpToken "else")+laiElse k parent = fmap (\new -> parent { aiElse = new })+                        (k (aiElse parent))++laiThenSemi :: Lens AnnsIf (Maybe (EpToken ";"))+laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new })+                            (k (aiThenSemi parent))++laiElseSemi :: Lens AnnsIf (Maybe (EpToken ";"))+laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new })+                            (k (aiElseSemi parent))++-- -------------------------------------++-- data AnnParen+--   = AnnParen {+--       ap_adornment :: ParenType,+--       ap_open      :: EpaLocation,+--       ap_close     :: EpaLocation+--       } deriving (Data)++-- lap_open :: Lens AnnParen EpaLocation+-- lap_open k parent = fmap (\new -> parent { ap_open = new })+--                          (k (ap_open parent))++-- lap_close :: Lens AnnParen EpaLocation+-- lap_close k parent = fmap (\new -> parent { ap_close = new })+--                           (k (ap_close parent))++-- -------------------------------------+-- data EpAnnHsCase = EpAnnHsCase+--       { hsCaseAnnCase :: EpToken "case"+--       , hsCaseAnnOf   :: EpToken "of"+--       } deriving Data++lhsCaseAnnCase :: Lens EpAnnHsCase (EpToken "case")+lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new })+                               (k (hsCaseAnnCase parent))++lhsCaseAnnOf :: Lens EpAnnHsCase (EpToken "of")+lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new })+                               (k (hsCaseAnnOf parent))++-- ---------------------------------------------------------------------++-- data HsRuleBndrsAnn+--   = HsRuleBndrsAnn+--        { rb_tyanns :: Maybe (TokForall, EpToken ".")+--        , rb_tmanns :: Maybe (TokForall, EpToken ".")+--        }++lrb_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))+lrb_tyanns k parent = fmap (\new -> parent { rb_tyanns = new })+                               (k (rb_tyanns parent))++ff :: Maybe (a,b) -> (Maybe a,Maybe b)+ff Nothing = (Nothing, Nothing)+ff (Just (a,b)) = (Just a, Just b)+++gg :: (Maybe a,Maybe b) -> Maybe (a,b)+gg (Nothing, Nothing) = Nothing+gg (Just a, Just b) = Just (a,b)+gg _ = error "gg:expecting two Nothing or two Just"++lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b)+lff k parent = fmap (\new -> gg new)+                    (k (ff parent))++-- (.) :: Lens' a b -> Lens' b c -> Lens' a c+lrb_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)+lrb_tyanns_fst = lrb_tyanns . lff . lfst++lrb_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))+lrb_tyanns_snd = lrb_tyanns . lff . lsnd++lrb_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))+lrb_tmanns k parent = fmap (\new -> parent { rb_tmanns = new })+                               (k (rb_tmanns parent))++lrb_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)+lrb_tmanns_fst = lrb_tmanns . lff . lfst++lrb_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))+lrb_tmanns_snd = lrb_tmanns . lff . lsnd++-- ---------------------------------------------------------------------+-- data GrhsAnn+--   = GrhsAnn {+--       ga_vbar :: Maybe (EpToken "|"),+--       ga_sep  :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->`+--       } deriving (Data)++lga_vbar :: Lens GrhsAnn (Maybe (EpToken "|"))+lga_vbar k parent = fmap (\new -> parent { ga_vbar = new })+                                (k (ga_vbar parent))++lga_sep :: Lens GrhsAnn (Either (EpToken "=") TokRarrow)+lga_sep k parent = fmap (\new -> parent { ga_sep = new })+                                (k (ga_sep parent))++-- ---------------------------------------------------------------------+-- data EpAnnSumPat = EpAnnSumPat+--       { sumPatParens      :: (EpaLocation, EpaLocation)+--       , sumPatVbarsBefore :: [EpToken "|"]+--       , sumPatVbarsAfter  :: [EpToken "|"]+--       } deriving Data++lsumPatParens :: Lens EpAnnSumPat (EpaLocation, EpaLocation)+lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new })+                              (k (sumPatParens parent))++lsumPatVbarsBefore :: Lens EpAnnSumPat [EpToken "|"]+lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new })+                              (k (sumPatVbarsBefore parent))++lsumPatVbarsAfter :: Lens EpAnnSumPat [EpToken "|"]+lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new })+                              (k (sumPatVbarsAfter parent))++-- ---------------------------------------------------------------------+-- data EpAnnLam = EpAnnLam+--       { epl_lambda :: EpToken "\\"      -- ^ Location of '\' keyword+--       , epl_case   :: Maybe EpaLocation -- ^ Location of 'case' or+--                                         -- 'cases' keyword, depending+--                                         -- on related 'HsLamVariant'.+--       } deriving Data++lepl_lambda :: Lens EpAnnLam (EpToken "\\")+lepl_lambda k parent = fmap (\new -> parent { epl_lambda = new })+                            (k (epl_lambda parent))++lepl_case :: Lens EpAnnLam (Maybe EpaLocation)+lepl_case k parent = fmap (\new -> parent { epl_case = new })+                          (k (epl_case parent))+++-- End of lenses+-- ---------------------------------------------------------------------++-- markLensKw' :: (Monad m, Monoid w)+--   => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a)+-- markLensKw' (EpAnn anc a cs) l kw = do+--   loc <- markKwA kw (view l a)+--   return (EpAnn anc (set l loc a) cs)++-- markLensKw :: (Monad m, Monoid w)+--   => a -> Lens a EpaLocation -> AnnKeywordId -> EP w m a+-- markLensKw a l kw = do+--   loc <- markKwA kw (view l a)+--   return (set l loc a)+++-- markLensKwM :: (Monad m, Monoid w)+--   => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a)+-- markLensKwM (EpAnn anc a cs) l kw = do+--   new <- go (view l a)+--   return (EpAnn anc (set l new a) cs)+--   where+--     go Nothing = return Nothing+--     go (Just s) = Just <$> markKwA kw s++-- markLensKwM' :: (Monad m, Monoid w)+--   => a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m a+-- markLensKwM' a l kw = do+--   loc <- mapM (markKwA kw) (view l a)+--   return (set l loc a)++markLensTok :: (Monad m, Monoid w, KnownSymbol sym)+  => EpAnn a -> Lens a (EpToken sym) -> EP w m (EpAnn a)+markLensTok (EpAnn anc a cs) l = do+  new <- markEpToken (view l a)+  return (EpAnn anc (set l new a) cs)++-- ---------------------------------------------------------------------++markLensFun' :: (Monad m, Monoid w)+  => EpAnn ann -> Lens ann t -> (t -> EP w m t) -> EP w m (EpAnn ann)+markLensFun' epann l f = markLensFun epann (lepa . l) f++markLensFun :: (Monad m, Monoid w)+  => ann -> Lens ann t -> (t -> EP w m t) -> EP w m ann+markLensFun a l f = do+  t' <- f (view l a)+  return (set l t' a)++-- -------------------------------------++markEpAnnAllLT :: (Monad m, Monoid w, KnownSymbol tok)+  => EpAnn ann -> Lens ann [EpToken tok] -> EP w m (EpAnn ann)+markEpAnnAllLT (EpAnn anc a cs) l = do+  anns <- mapM markEpToken (view l a)+  return (EpAnn anc (set l anns a) cs)++markEpAnnAllLT' :: (Monad m, Monoid w, KnownSymbol tok)+  => ann -> Lens ann [EpToken tok] -> EP w m ann+markEpAnnAllLT' a l = do+  anns <- mapM markEpToken (view l a)+  return (set l anns a)++markEpaLocationAll :: (Monad m, Monoid w)+  => [EpaLocation] -> String -> EP w m [EpaLocation]+markEpaLocationAll locs str = mapM (\l -> printStringAtAA l str) locs++-- | Print a keyword encoded in a 'TrailingAnn'+markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn+markKwT (AddSemiAnn tok)    = AddSemiAnn    <$> markEpToken tok+markKwT (AddCommaAnn tok)   = AddCommaAnn   <$> markEpToken tok+markKwT (AddVbarAnn tok)    = AddVbarAnn    <$> markEpToken tok+markKwT (AddDarrowAnn tok)  = AddDarrowAnn  <$> markEpUniToken tok++-- ---------------------------------------------------------------------++markAnnList :: (Monad m, Monoid w)+  => EpAnn (AnnList l) -> EP w m a -> EP w m (EpAnn (AnnList l), a)+markAnnList ann action = do+  markAnnListA ann $ \a -> do+    r <- action+    return (a,r)++markAnnList' :: (Monad m, Monoid w)+  => AnnList l -> EP w m a -> EP w m (AnnList l, a)+markAnnList' ann action = do+  markAnnListA' ann $ \a -> do+    r <- action+    return (a,r)++markAnnListA :: (Monad m, Monoid w)+  => EpAnn (AnnList l)+  -> (EpAnn (AnnList l) -> EP w m (EpAnn (AnnList l), a))+  -> EP w m (EpAnn (AnnList l), a)+markAnnListA an action = do+  an0 <- markLensBracketsO an lal_brackets+  an1 <- markEpAnnAllLT an0 lal_semis+  (an2, r) <- action an1+  an3 <- markLensBracketsC an2 lal_brackets+  return (an3, r)++markAnnListA' :: (Monad m, Monoid w)+  => AnnList l+  -> (AnnList l -> EP w m (AnnList l, a))+  -> EP w m (AnnList l , a)+markAnnListA' an action = do+  an0 <- markLensBracketsO' an lal_brackets+  an1 <- markEpAnnAllLT' an0 lal_semis+  (an2, r) <- action an1+  an3 <- markLensBracketsC' an2 lal_brackets+  return (an3, r)++-- ---------------------------------------------------------------------++printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+printCommentsBefore ss = do+  cs <- commentAllocationBefore ss+  debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss)+  -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs)+  mapM_ printOneComment cs++printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+printCommentsIn ss = do+  cs <- commentAllocationIn ss+  debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss)+  -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs)+  mapM_ printOneComment cs+  debugM $ "printCommentsIn:done"++-- ---------------------------------------------------------------------++printOneComment :: (Monad m, Monoid w) => Comment -> EP w m ()+printOneComment c@(Comment _str loc _r _mo) = do+  debugM $ "printOneComment:c=" ++ showGhc c+  dp <-case loc of+    EpaDelta _ dp _ -> return dp+    EpaSpan (RealSrcSpan r _) -> do+        pe <- getPriorEndD+        debugM $ "printOneComment:pe=" ++ showGhc pe+        let dp = ss2delta pe r+        debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc)+        adjustDeltaForOffsetM dp+    EpaSpan (UnhelpfulSpan _) -> return (SameLine 0)+  mep <- getExtraDP+  dp' <- case mep of+    Just (EpaDelta _ edp _) -> do+      debugM $ "printOneComment:edp=" ++ show edp+      return edp+    _ -> return dp+  -- Start of debug printing+  LayoutStartCol dOff <- getLayoutOffsetD+  debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc)+  -- End of debug printing+  updateAndApplyComment c dp'+  printQueuedComment c dp'++updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()+updateAndApplyComment (Comment str anc pp mo) dp = do+  applyComment (Comment str anc' pp mo)+  where+    ss = case anc of+        EpaSpan ss' -> ss'+        _          -> noSrcSpan+    anc' = EpaDelta ss dp NoComments++-- ---------------------------------------------------------------------++commentAllocationBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]+commentAllocationBefore ss = do+  cs <- getUnallocatedComments+  -- Note: The CPP comment injection may change the file name in the+  -- RealSrcSpan, which affects comparison, as the Ord instance for+  -- RealSrcSpan compares the file first. So we sort via ss2pos+  -- TODO: this is inefficient, use Pos all the way through+  let (earlier,later) = partition (\(Comment _str loc _r _mo) ->+                                     case loc of+                                       EpaSpan (RealSrcSpan r _) -> (ss2pos r) <= (ss2pos ss)+                                       _ -> True -- Choose one+                                  ) cs+  putUnallocatedComments later+  -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)+  return earlier++commentAllocationIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]+commentAllocationIn ss = do+  cs <- getUnallocatedComments+  -- Note: The CPP comment injection may change the file name in the+  -- RealSrcSpan, which affects comparison, as the Ord instance for+  -- RealSrcSpan compares the file first. So we sort via ss2pos+  -- TODO: this is inefficient, use Pos all the way through+  let (earlier,later) = partition (\(Comment _str loc _r _mo) ->+                                     case loc of+                                       EpaSpan (RealSrcSpan r _) -> (ss2posEnd r) <= (ss2posEnd ss)+                                       _ -> True -- Choose one+                                  ) cs+  putUnallocatedComments later+  -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)+  return earlier+-- ---------------------------------------------------------------------++markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast+markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a++-- ---------------------------------------------------------------------+-- End of utility functions+-- ---------------------------------------------------------------------+-- Start of ExactPrint instances+-- ---------------------------------------------------------------------++-- | Bare Located elements are simply stripped off without further+-- processing.+instance (ExactPrint a) => ExactPrint (Located a) where+  getAnnotationEntry (L l _) = case l of+    UnhelpfulSpan _ -> NoEntryVal+    _ -> Entry (EpaSpan l) [] emptyComments NoFlushComments CanUpdateAnchorOnly++  setAnnotationAnchor (L l a) _anc _ts _cs = L l a++  exact (L l a) = L l <$> markAnnotated a++instance (ExactPrint a) => ExactPrint (LocatedE a) where+  getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly+  setAnnotationAnchor (L _ a) anc _ts _cs = L anc a++  exact (L la a) = do+    debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la)+    a' <- markAnnotated a+    return (L la a')++instance (ExactPrint a) => ExactPrint (LocatedA a) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs+  exact (L la a) = do+    debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la)+    a' <- markAnnotated a+    return (L la a')++instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs+  exact (L la a) = do+    a' <- markAnnotated a+    return (L la a')++instance (ExactPrint a) => ExactPrint [a] where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor ls _ _ _ = ls+  exact ls = mapM markAnnotated ls++instance (ExactPrint a) => ExactPrint (Maybe a) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor ma _ _ _ = ma+  exact ma = mapM markAnnotated ma++instance (ExactPrint a) => ExactPrint (NonEmpty a) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor ls _ _ _ = ls+  exact ls = mapM markAnnotated ls++-- ---------------------------------------------------------------------++-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'+instance ExactPrint (HsModule GhcPs) where+  getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod)+  -- A bit pointless actually changing anything here+  setAnnotationAnchor hsmod anc _ts cs = setAnchorHsModule hsmod anc cs+                   `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs))++  exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do++    let mbDoc' = mbDoc++    (an0, mmn' , mdeprec', mexports') <-+      case mmn of+        Nothing -> return (an, mmn, mdeprec, mexports)+        Just m -> do+          an0 <- markLensTok an lam_mod+          m' <- markAnnotated m++          mdeprec' <- markAnnotated mdeprec++          mexports' <- markAnnotated mexports++          an1 <- markLensTok an0 lam_where++          return (an1, Just m', mdeprec', mexports')++    lo0 <- case lo of+        EpExplicitBraces open close -> do+          open' <- markEpToken open+          return (EpExplicitBraces open' close)+        _ -> return lo++    am_decls' <- markTrailing (am_decls $ anns an0)++    mid <- markAnnotated (HsModuleImpDecls (am_cs $ anns an0) imports decls)+    let imports' = id_imps mid+    let decls' = id_decls mid++    lo1 <- case lo0 of+        EpExplicitBraces open close -> do+          close' <- markEpToken close+          return (EpExplicitBraces open close')+        _ -> return lo++    -- Print EOF+    case am_eof $ anns an of+      Nothing -> return ()+      Just (pos, prior) -> do+        debugM $ "am_eof:" ++ showGhc (pos, prior)+        setEofPos (Just (pos, prior))++    let anf = an0 { anns = (anns an0) { am_decls = am_decls', am_cs = [] }}+    debugM $ "HsModule, anf=" ++ showAst anf++    return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls')++-- ---------------------------------------------------------------------++-- | This is used to ensure the comments are updated into the right+-- place for makeDeltaAst.+data HsModuleImpDecls+    = HsModuleImpDecls {+        id_cs     :: [LEpaComment],+        id_imps   :: [LImportDecl GhcPs],+        id_decls  :: [LHsDecl GhcPs]+    } deriving Data++instance ExactPrint HsModuleImpDecls where+  -- Use an UnhelpfulSpan for the anchor, we are only interested in the comments+  getAnnotationEntry mid = mkEntry (EpaSpan (UnhelpfulSpan UnhelpfulNoLocationInfo)) [] (EpaComments (id_cs mid))+  setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs }+     `debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs)+  exact (HsModuleImpDecls cs imports decls) = do+    imports' <- mapM markAnnotated imports+    decls' <- mapM markAnnotated (filter notDocDecl decls)+    return (HsModuleImpDecls cs imports' decls')+++-- ---------------------------------------------------------------------++instance ExactPrint ModuleName where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor n _anc _ cs = n+     `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs)+  exact n = do+    debugM $ "ModuleName: " ++ showPprUnsafe n+    withPpr n++-- ---------------------------------------------------------------------++instance ExactPrint (LocatedP (WarningTxt GhcPs)) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn++  exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt mb_cat src ws)) = do+    o' <- markAnnOpen'' o src "{-# WARNING"+    mb_cat' <- markAnnotated mb_cat+    os' <- markEpToken os+    ws' <- markAnnotated ws+    cs' <- markEpToken cs+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt mb_cat' src ws'))++  exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do+    o' <- markAnnOpen'' o src "{-# DEPRECATED"+    os' <- markEpToken os+    ws' <- markAnnotated ws+    cs' <- markEpToken cs+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))++instance ExactPrint InWarningCategory where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (InWarningCategory tkIn source (L l wc)) = do+      tkIn' <- markEpToken tkIn+      L l' (_,wc') <- markAnnotated (L l (source, wc))+      return (InWarningCategory tkIn' source (L l' wc'))++instance ExactPrint (SourceText, WarningCategory) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (st, WarningCategory wc) = do+      case st of+          NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\""+          SourceText src -> printStringAdvance $ (unpackFS src)+      return (st, WarningCategory wc)++-- ---------------------------------------------------------------------++instance ExactPrint (ImportDecl GhcPs) where+  getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl)+  setAnnotationAnchor idecl anc ts cs = idecl { ideclExt+                    = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} }++  exact (ImportDecl (XImportDeclPass ann msrc impl)+                     modname mpkg src st safeflag qualFlag mAs hiding) = do++    ann0 <- markLensFun' ann limportDeclAnnImport markEpToken+    let (EpAnn _anc an _cs) = ann0++    -- "{-# SOURCE" and "#-}"+    importDeclAnnPragma' <-+      case msrc of+        SourceText _txt -> do+          debugM $ "ImportDecl sourcetext"+          case importDeclAnnPragma an of+            Just (mo, mc) -> do+              mo' <- markAnnOpen'' mo msrc "{-# SOURCE"+              mc' <- markEpToken mc+              return $ Just (mo', mc')+            Nothing ->  do+              _ <- markAnnOpen' Nothing msrc "{-# SOURCE"+              printStringAtLsDelta (SameLine 1) "#-}"+              return Nothing+        NoSourceText -> return (importDeclAnnPragma an)+    -- pre level+    ann0' <- case st of+        LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt)+        _ -> return ann0+++    ann1 <- if safeflag+      then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt)+      else return ann0'+    ann2 <-+      case qualFlag of+        QualifiedPre  -- 'qualified' appears in prepositive position.+          -> markLensFun' ann1 limportDeclAnnQualified (\ml -> mapM markEpToken ml)+        _ -> return ann1+    ann3 <-+      case mpkg of+       RawPkgQual (StringLiteral src' v _) ->+         printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v))+       _ -> return ann2+    modname' <- markAnnotated modname++    -- post level+    ann3' <- case st of+        LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt)+        _ -> return ann3++    ann4 <-+      case qualFlag of+        QualifiedPost  -- 'qualified' appears in postpositive position.+          -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml)+        _ -> return ann3'++    (importDeclAnnAs', mAs') <-+      case mAs of+        Nothing -> return (importDeclAnnAs an, Nothing)+        Just m0 -> do+          a <- mapM markEpToken (importDeclAnnAs an)+          m'' <- markAnnotated m0+          return (a, Just m'')++    hiding' <-+      case hiding of+        Nothing -> return hiding+        Just (isHiding,lie) -> do+          lie' <- markAnnotated lie+          return (Just (isHiding, lie'))++    let (EpAnn anc' an' cs') = ann4+    let an2 = an' { importDeclAnnAs = importDeclAnnAs'+                  , importDeclAnnPragma = importDeclAnnPragma'+                  }++    return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl)+                     modname' mpkg src st safeflag qualFlag mAs' hiding')++markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel+markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok+markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok++-- ---------------------------------------------------------------------++instance ExactPrint HsDocString where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (MultiLineDocString decorator (x :| xs)) = do+    printStringAdvance ("-- " ++ printDecorator decorator)+    pe <- getPriorEndD+    debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x)+    x' <- markAnnotated x+    xs' <- markAnnotated (map dedentDocChunk xs)+    return (MultiLineDocString decorator (x' :| xs'))+  exact x = do+    -- TODO: can this happen?+    debugM $ "Not exact printing:" ++ showAst x+    return x+++instance ExactPrint HsDocStringChunk where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact chunk = do+    printStringAdvance ("--" ++ unpackHDSC chunk)+    return chunk+++instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (WithHsDocIdentifiers ds ids) = do+    ds' <- exact ds+    return (WithHsDocIdentifiers ds' ids)++-- ---------------------------------------------------------------------++instance ExactPrint (HsDecl GhcPs) where+  getAnnotationEntry (TyClD      _ _) = NoEntryVal+  getAnnotationEntry (InstD      _ _) = NoEntryVal+  getAnnotationEntry (DerivD     _ _) = NoEntryVal+  getAnnotationEntry (ValD       _ _) = NoEntryVal+  getAnnotationEntry (SigD       _ _) = NoEntryVal+  getAnnotationEntry (KindSigD   _ _) = NoEntryVal+  getAnnotationEntry (DefD       _ _) = NoEntryVal+  getAnnotationEntry (ForD       _ _) = NoEntryVal+  getAnnotationEntry (WarningD   _ _) = NoEntryVal+  getAnnotationEntry (AnnD       _ _) = NoEntryVal+  getAnnotationEntry (RuleD      _ _) = NoEntryVal+  getAnnotationEntry (SpliceD    _ _) = NoEntryVal+  getAnnotationEntry (DocD       _ _) = NoEntryVal+  getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal++  -- We do not recurse, the generic traversal using this feature+  -- should do that for us.+  setAnnotationAnchor d _ _ _ = d++  exact (TyClD       x d) = TyClD       x <$> markAnnotated d+  exact (InstD       x d) = InstD       x <$> markAnnotated d+  exact (DerivD      x d) = DerivD      x <$> markAnnotated d+  exact (ValD        x d) = ValD        x <$> markAnnotated d+  exact (SigD        x d) = SigD        x <$> markAnnotated d+  exact (KindSigD    x d) = KindSigD    x <$> markAnnotated d+  exact (DefD        x d) = DefD        x <$> markAnnotated d+  exact (ForD        x d) = ForD        x <$> markAnnotated d+  exact (WarningD    x d) = WarningD    x <$> markAnnotated d+  exact (AnnD        x d) = AnnD        x <$> markAnnotated d+  exact (RuleD       x d) = RuleD       x <$> markAnnotated d+  exact (SpliceD     x d) = SpliceD     x <$> markAnnotated d+  exact (DocD        x d) = DocD        x <$> markAnnotated d+  exact (RoleAnnotD  x d) = RoleAnnotD  x <$> markAnnotated d++-- ---------------------------------------------------------------------++instance ExactPrint (InstDecl GhcPs) where+  getAnnotationEntry (ClsInstD     _ _) = NoEntryVal+  getAnnotationEntry (DataFamInstD _ _) = NoEntryVal+  getAnnotationEntry (TyFamInstD   _ _) = NoEntryVal++  setAnnotationAnchor d _ _ _ = d+++  exact (ClsInstD     a  cid) = do+    cid' <- markAnnotated cid+    return (ClsInstD     a  cid')+  exact (DataFamInstD a decl) = do+    decl' <- markAnnotated decl+    return (DataFamInstD a decl')+  exact (TyFamInstD a eqn) = do+    eqn' <- markAnnotated eqn+    return (TyFamInstD a eqn')++-- ---------------------------------------------------------------------++instance ExactPrint (DataFamInstDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact d = do+    d' <- exactDataFamInstDecl d+    return d'++-- ---------------------------------------------------------------------++exactDataFamInstDecl :: (Monad m, Monoid w)+                     => DataFamInstDecl GhcPs+                     -> EP w m (DataFamInstDecl GhcPs)+exactDataFamInstDecl+  (DataFamInstDecl (FamEqn { feqn_ext    = (ops, cps, eq)+                           , feqn_tycon  = tycon+                           , feqn_bndrs  = bndrs+                           , feqn_pats   = pats+                           , feqn_fixity = fixity+                           , feqn_rhs    = defn })) = do+    ((ops', cps'), tycon', bndrs', pats', defn') <- exactDataDefn pp_hdr defn+    return+      (DataFamInstDecl ( FamEqn { feqn_ext    = (ops', cps', eq)+                                , feqn_tycon  = tycon'+                                , feqn_bndrs  = bndrs'+                                , feqn_pats   = pats'+                                , feqn_fixity = fixity+                                , feqn_rhs    = defn' }))+                    `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn'))+  where+    pp_hdr :: (Monad m, Monoid w)+           => Maybe (LHsContext GhcPs)+           -> EP w m ( ([EpToken "("], [EpToken ")"] )+                     , LocatedN RdrName+                     , HsOuterTyVarBndrs () GhcPs+                     , HsFamEqnPats GhcPs+                     , Maybe (LHsContext GhcPs))+    pp_hdr mctxt = exactHsFamInstLHS ops cps tycon bndrs pats fixity mctxt++-- ---------------------------------------------------------------------++instance ExactPrint (DerivDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (DerivDecl (mw, (td,ti)) typ ms mov) = do+    td' <- markEpToken td+    ms' <- mapM markAnnotated ms+    ti' <- markEpToken ti+    mw' <- mapM markAnnotated mw+    mov' <- mapM markAnnotated mov+    typ' <- markAnnotated typ+    return (DerivDecl (mw', (td',ti')) typ' ms' mov')++-- ---------------------------------------------------------------------++instance ExactPrint (ForeignDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (ForeignImport (tf,ti,td) n ty fimport) = do+    tf' <- markEpToken tf+    ti' <- markEpToken ti++    fimport' <- markAnnotated fimport++    n' <- markAnnotated n+    td' <- markEpUniToken td+    ty' <- markAnnotated ty+    return (ForeignImport (tf',ti',td') n' ty' fimport')++  exact (ForeignExport (tf,te,td) n ty fexport) = do+    tf' <- markEpToken tf+    te' <- markEpToken te+    fexport' <- markAnnotated fexport+    n' <- markAnnotated n+    td' <- markEpUniToken td+    ty' <- markAnnotated ty+    return (ForeignExport (tf',te',td') n' ty' fexport')++-- ---------------------------------------------------------------------++instance ExactPrint (ForeignImport GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do+    cconv' <- markAnnotated cconv+    safety' <- if notDodgyE l+        then markAnnotated safety+        else return safety+    ls' <- if notDodgyE ls+        then markExternalSourceTextE ls src ""+        else return ls+    return (CImport (L ls' src) cconv' safety' mh imp)++-- ---------------------------------------------------------------------++instance ExactPrint (ForeignExport GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (CExport (L ls src) spec) = do+    debugM $ "CExport starting"+    spec' <- markAnnotated spec+    ls' <- if notDodgyE ls+        then markExternalSourceTextE ls src ""+        else return ls+    return (CExport (L ls' src) spec')++-- ---------------------------------------------------------------------++instance ExactPrint CExportSpec where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (CExportStatic st lbl cconv) = do+    debugM $ "CExportStatic starting"+    cconv' <- markAnnotated cconv+    return (CExportStatic st lbl cconv')++-- ---------------------------------------------------------------------++instance ExactPrint Safety where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact = withPpr++-- ---------------------------------------------------------------------++instance ExactPrint CCallConv where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact = withPpr++-- ---------------------------------------------------------------------++instance ExactPrint (WarnDecls GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (Warnings ((o,c),src) warns) = do+    o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED+    warns' <- markAnnotated warns+    c' <- markEpToken c+    return (Warnings ((o',c'),src) warns')++-- ---------------------------------------------------------------------++instance ExactPrint (WarnDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (Warning (ns_spec, (o,c)) lns  (WarningTxt mb_cat src ls )) = do+    mb_cat' <- markAnnotated mb_cat+    ns_spec' <- exactNsSpec ns_spec+    lns' <- markAnnotated lns+    o' <- markEpToken o+    ls' <- markAnnotated ls+    c' <- markEpToken c+    return (Warning (ns_spec', (o',c')) lns'  (WarningTxt mb_cat' src ls'))++  exact (Warning (ns_spec, (o,c)) lns (DeprecatedTxt src ls)) = do+    ns_spec' <- exactNsSpec ns_spec+    lns' <- markAnnotated lns+    o' <- markEpToken o+    ls' <- markAnnotated ls+    c' <- markEpToken c+    return (Warning (ns_spec', (o',c')) lns' (DeprecatedTxt src ls'))++exactNsSpec :: (Monad m, Monoid w) => NamespaceSpecifier -> EP w m NamespaceSpecifier+exactNsSpec NoNamespaceSpecifier = pure NoNamespaceSpecifier+exactNsSpec (TypeNamespaceSpecifier type_) = do+  type_' <- markEpToken type_+  pure (TypeNamespaceSpecifier type_')+exactNsSpec (DataNamespaceSpecifier data_) = do+  data_' <- markEpToken data_+  pure (DataNamespaceSpecifier data_')++-- ---------------------------------------------------------------------++instance ExactPrint StringLiteral where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (StringLiteral src fs mcomma) = do+    printSourceTextAA src (show (unpackFS fs))+    mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma+    return (StringLiteral src fs mcomma')++-- ---------------------------------------------------------------------++instance ExactPrint FastString where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.+  -- exact fs = printStringAdvance (show (unpackFS fs))+  exact fs = printStringAdvance (unpackFS fs) >> return fs++-- ---------------------------------------------------------------------++instance ExactPrint (RuleDecls GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (HsRules ((o,c), src) rules) = do+    o' <-+      case src of+        NoSourceText      -> printStringAtAA o "{-# RULES"+        SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt)+    rules' <- markAnnotated rules+    c' <- markEpToken c+    return (HsRules ((o',c'),src) rules')++-- ---------------------------------------------------------------------++instance ExactPrint (RuleDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsRule ((ann_act, ann_eq),nsrc) (L ln n) act bndrs lhs rhs) = do+    (L ln' _) <- markAnnotated (L ln (nsrc, n))+    ann_act' <- markActivation ann_act act+    bndrs' <- markAnnotated bndrs+    lhs' <- markAnnotated lhs+    ann_eq' <- markEpToken ann_eq+    rhs' <- markAnnotated rhs+    return (HsRule ((ann_act', ann_eq'),nsrc) (L ln' n) act bndrs' lhs' rhs')++markActivation :: (Monad m, Monoid w)+  => ActivationAnn -> Activation -> EP w m ActivationAnn+markActivation (ActivationAnn o c t v) act = do+  case act of+    ActiveBefore src phase -> do+      o' <- markEpToken o --  '['+      t' <- mapM markEpToken t -- ~+      v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v+      c' <- markEpToken c -- ']'+      return (ActivationAnn o' c' t' v')+    ActiveAfter src phase -> do+      o' <- markEpToken o --  '['+      v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v+      c' <- markEpToken c -- ']'+      return (ActivationAnn o' c' t v')+    NeverActive -> do+      o' <- markEpToken o --  '['+      t' <- mapM markEpToken t -- ~+      c' <- markEpToken c -- ']'+      return (ActivationAnn o' c' t' v)+    _ -> return (ActivationAnn o c t v)++-- ---------------------------------------------------------------------++instance ExactPrint (SpliceDecl GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (SpliceDecl x splice flag) = do+    splice' <- markAnnotated splice+    return (SpliceDecl x splice' flag)++-- ---------------------------------------------------------------------++instance ExactPrint (DocDecl GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  -- We print these as plain comments instead, do a NOP here.+  exact v = return v++-- ---------------------------------------------------------------------++instance ExactPrint (RoleAnnotDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (RoleAnnotDecl (tt,tr) ltycon roles) = do+    tt' <- markEpToken tt+    tr' <- markEpToken tr+    ltycon' <- markAnnotated ltycon+    let markRole (L l (Just r)) = do+          (L l' r') <- markAnnotated (L l r)+          return (L l' (Just r'))+        markRole (L l Nothing) = do+          e' <- printStringAtAA  (entry l) "_"+          return (L (l { entry = e'}) Nothing)+    roles' <- mapM markRole roles+    return (RoleAnnotDecl (tt',tr') ltycon' roles')++-- ---------------------------------------------------------------------++instance ExactPrint Role where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact = withPpr++-- ---------------------------------------------------------------------++instance ExactPrint (RuleBndrs GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (RuleBndrs an0 mtybndrs termbndrs) = do+    (an2, mtybndrs') <-+      case mtybndrs of+        Nothing -> return (an0, Nothing)+        Just bndrs -> do+          an1 <- markLensFun an0 lrb_tyanns_fst (traverse markEpUniToken) -- AnnForall+          bndrs' <- mapM markAnnotated bndrs+          an2 <- markLensFun an1 lrb_tyanns_snd (traverse markEpToken) -- AnnDot+          return (an2, Just bndrs')++    an3 <- markLensFun an2 lrb_tmanns_fst (traverse markEpUniToken) -- AnnForall+    termbndrs' <- mapM markAnnotated termbndrs+    an4 <- markLensFun an3 lrb_tmanns_snd (traverse markEpToken) -- AnnDot+    return (RuleBndrs an4 mtybndrs' termbndrs')++-- ---------------------------------------------------------------------++instance ExactPrint (RuleBndr GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (RuleBndr x ln) = do+    ln' <- markAnnotated ln+    return (RuleBndr x ln')+  exact (RuleBndrSig (AnnTyVarBndr os cs ap dc) ln (HsPS x ty)) = do+    os' <- markEpaLocationAll os "("+    ln' <- markAnnotated ln+    dc' <- markEpUniToken dc+    ty' <- markAnnotated ty+    cs' <- markEpaLocationAll cs ")"+    return (RuleBndrSig (AnnTyVarBndr os' cs' ap dc') ln' (HsPS x ty'))++-- ---------------------------------------------------------------------++instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor fe _ _ _s = fe+  exact (FamEqn { feqn_ext    = (ops, cps, eq)+                , feqn_tycon  = tycon+                , feqn_bndrs  = bndrs+                , feqn_pats   = pats+                , feqn_fixity = fixity+                , feqn_rhs    = rhs }) = do+    ((ops', cps'), tycon', bndrs', pats',_) <- exactHsFamInstLHS ops cps tycon bndrs pats fixity Nothing+    eq' <- markEpToken eq+    rhs' <- markAnnotated rhs+    return (FamEqn { feqn_ext    = (ops', cps', eq')+                   , feqn_tycon  = tycon'+                   , feqn_bndrs  = bndrs'+                   , feqn_pats   = pats'+                   , feqn_fixity = fixity+                   , feqn_rhs    = rhs' })++-- ---------------------------------------------------------------------++exactHsFamInstLHS ::+      (Monad m, Monoid w)+   => [EpToken "("]+   -> [EpToken ")"]+   -> LocatedN RdrName+   -> HsOuterTyVarBndrs () GhcPs+   -> HsFamEqnPats GhcPs+   -> LexicalFixity+   -> Maybe (LHsContext GhcPs)+   -> EP w m ( ([EpToken "("], [EpToken ")"])+             , LocatedN RdrName+             , HsOuterTyVarBndrs () GhcPs+             , HsFamEqnPats GhcPs, Maybe (LHsContext GhcPs))+exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do+  -- TODO:AZ: do these ans exist? They are in the binders now+  -- an0 <- markEpAnnL an lidl AnnForall+  bndrs' <- markAnnotated bndrs+  -- an1 <- markEpAnnL an0 lidl AnnDot+  mb_ctxt' <- mapM markAnnotated mb_ctxt+  (ops', cps', thing', typats') <- exact_pats ops cps typats+  return ((ops', cps'), thing', bndrs', typats', mb_ctxt')+  where+    exact_pats :: (Monad m, Monoid w)+      => [EpToken "("] -> [EpToken ")"] -> HsFamEqnPats GhcPs+      -> EP w m ([EpToken "("], [EpToken ")"], LocatedN RdrName, HsFamEqnPats GhcPs)+    exact_pats ops1 cps1 (patl:patr:pats)+      | Infix <- fixity+      = let exact_op_app = do+              ops' <- mapM markEpToken ops1+              patl' <- markAnnotated patl+              thing' <- markAnnotated thing+              patr' <- markAnnotated patr+              cps' <- mapM markEpToken cps1+              return (ops', cps', thing', [patl',patr'])+        in case pats of+             [] -> exact_op_app+             _  -> do+               (ops', cps', thing', p) <- exact_op_app+               pats' <- mapM markAnnotated pats+               return (ops', cps', thing', p++pats')++    exact_pats ops0 cps0 pats = do+      ops' <- mapM markEpToken ops0+      thing' <- markAnnotated thing+      pats' <- markAnnotated pats+      cps' <- mapM markEpToken cps0+      return (ops', cps', thing', pats')++-- ---------------------------------------------------------------------++instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)+     =>  ExactPrint (HsArg GhcPs tm ty) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsValArg x tm) = do+      tm' <- markAnnotated tm+      return (HsValArg x tm')+  exact (HsTypeArg at ty) = do+      at' <- markEpToken at+      ty' <- markAnnotated ty+      return (HsTypeArg at' ty')+  exact x@(HsArgPar _sp)    = withPpr x -- Does not appear in original source++-- ---------------------------------------------------------------------++instance ExactPrint (ClsInstDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (ClsInstDecl { cid_ext = (mbWarn, AnnClsInstDecl i w oc semis cc, sortKey)+                     , cid_poly_ty = inst_ty, cid_binds = binds+                     , cid_sigs = sigs, cid_tyfam_insts = ats+                     , cid_overlap_mode = mbOverlap+                     , cid_datafam_insts = adts })+      = do+          (mbWarn', i', w', mbOverlap', inst_ty') <- top_matter+          oc' <- markEpToken oc+          semis' <- mapM markEpToken semis+          (sortKey', ds) <- withSortKey sortKey+                               [(ClsAtTag, prepareListAnnotationA ats),+                                (ClsAtdTag, prepareListAnnotationF adts),+                                (ClsMethodTag, prepareListAnnotationA binds),+                                (ClsSigTag, prepareListAnnotationA sigs)+                               ]+          cc' <- markEpToken cc+          let+            ats'   = undynamic ds+            adts'  = undynamic ds+            binds' = undynamic ds+            sigs'  = undynamic ds+          return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' oc' semis' cc', sortKey')+                              , cid_poly_ty = inst_ty', cid_binds = binds'+                              , cid_sigs = sigs', cid_tyfam_insts = ats'+                              , cid_overlap_mode = mbOverlap'+                              , cid_datafam_insts = adts' })++      where+        top_matter = do+          i' <- markEpToken i+          mw <- mapM markAnnotated mbWarn+          mo <- mapM markAnnotated mbOverlap+          it <- markAnnotated inst_ty+          w' <- markEpToken w -- Optional+          return (mw, i', w', mo,it)++-- ---------------------------------------------------------------------++instance ExactPrint (TyFamInstDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact d@(TyFamInstDecl { tfid_xtn = (tt,ti), tfid_eqn = eqn }) = do+    tt' <- markEpToken tt+    ti' <- markEpToken ti+    eqn' <- markAnnotated eqn+    return (d { tfid_xtn = (tt',ti'), tfid_eqn = eqn' })++-- ---------------------------------------------------------------------++instance ExactPrint (LocatedP OverlapMode) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn++  -- NOTE: NoOverlap is only used in the typechecker+  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do+    o' <- markAnnOpen'' o src "{-# NO_OVERLAP"+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src))++  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do+    o' <- markAnnOpen'' o src "{-# OVERLAPPABLE"+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src))++  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do+    o' <- markAnnOpen'' o src "{-# OVERLAPPING"+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src))++  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do+    o' <- markAnnOpen'' o src "{-# OVERLAPS"+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src))++  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do+    o' <- markAnnOpen'' o src "{-# INCOHERENT"+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))++  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do+    o' <- markAnnOpen'' o src "{-# INCOHERENT"+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))++-- ---------------------------------------------------------------------++instance ExactPrint (HsBind GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (FunBind x fid matches) = do+    matches' <- markAnnotated matches+    let+      fun_id' = case unLoc (mg_alts matches') of+        [] -> fid+        (L _ m:_) -> case m_ctxt m of+          FunRhs f _ _ _ -> f+          _ -> fid+    return (FunBind x fun_id' matches')++  exact (PatBind x pat q grhss) = do+    (q', pat') <- markMultAnnOf q (markAnnotated pat)+    grhss' <- markAnnotated grhss+    return (PatBind x pat' q' grhss')+  exact (PatSynBind x bind) = do+    bind' <- markAnnotated bind+    return (PatSynBind x bind')++  exact x = error $ "HsBind: exact for " ++ showAst x++-- ---------------------------------------------------------------------++instance ExactPrint (PatSynBind GhcPs GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (PSB{ psb_ext = AnnPSB ap ao ac al ae+            , psb_id = psyn, psb_args = details+            , psb_def = pat+            , psb_dir = dir }) = do+    ap' <- markEpToken ap+    (ao', ac', psyn', details') <-+      case details of+        InfixCon v1 v2 -> do+          v1' <- markAnnotated v1+          psyn' <- markAnnotated psyn+          v2' <- markAnnotated v2+          return (ao, ac, psyn',InfixCon v1' v2')+        PrefixCon vs -> do+          psyn' <- markAnnotated psyn+          vs' <- markAnnotated vs+          return (ao, ac, psyn', PrefixCon vs')+        RecCon vs -> do+          psyn' <- markAnnotated psyn+          ao' <- mapM markEpToken ao+          vs' <- markAnnotated vs+          ac' <- mapM markEpToken ac+          return (ao', ac', psyn', RecCon vs')++    (al', ae', pat', dir') <-+      case dir of+        Unidirectional           -> do+          al' <- mapM markEpUniToken al+          pat' <- markAnnotated pat+          return (al', ae, pat', dir)+        ImplicitBidirectional    -> do+          ae' <- mapM markEpToken ae+          pat' <- markAnnotated pat+          return (al, ae', pat', dir)+        ExplicitBidirectional mg -> do+          al' <- mapM markEpUniToken al+          pat' <- markAnnotated pat+          mg' <- markAnnotated mg+          return (al', ae, pat', ExplicitBidirectional mg')++    return (PSB{ psb_ext = AnnPSB ap' ao' ac' al' ae'+               , psb_id = psyn', psb_args = details'+               , psb_def = pat'+               , psb_dir = dir' })+++-- ---------------------------------------------------------------------++instance ExactPrint (RecordPatSynField GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (RecordPatSynField f v) = do+      f' <- markAnnotated f+      return (RecordPatSynField f' v)++-- ---------------------------------------------------------------------++instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (Match an mctxt pats grhss) =+    exactMatch (Match an mctxt pats grhss)++-- -------------------------------------++instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (Match an mctxt pats grhss) =+    exactMatch (Match an mctxt pats grhss)++-- ---------------------------------------------------------------------++exactMatch :: (Monad m, Monoid w, ExactPrint (GRHSs GhcPs body))+           => (Match GhcPs body) -> EP w m (Match GhcPs body)+exactMatch (Match an mctxt pats grhss) = do++  debugM $ "exact Match entered"++  (mctxt', pats') <-+    case mctxt of+      FunRhs fun fixity strictness (AnnFunRhs strict opens closes) -> do+        debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun+        strict' <- markEpToken strict+        case fixity of+          Prefix -> do+            epTokensToComments "(" opens+            epTokensToComments ")" closes+            fun' <- markAnnotated fun+            pats' <- markAnnotated pats+            return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats')+          Infix ->+            case pats of+              L l (p1:p2:rest)+                | null rest -> do+                    p1'  <- markAnnotated p1+                    fun' <- markAnnotated fun+                    p2'  <- markAnnotated p2+                    return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), L l [p1',p2'])+                | otherwise -> do+                    opens' <- markEpToken1 opens+                    p1'  <- markAnnotated p1+                    fun' <- markAnnotated fun+                    p2'  <- markAnnotated p2+                    closes' <- markEpToken1 closes+                    rest' <- mapM markAnnotated rest+                    return (FunRhs fun' fixity strictness (AnnFunRhs strict' opens' closes'), L l (p1':p2':rest'))+              _ -> panic "FunRhs"++      LamAlt v -> do+        pats' <- markAnnotated pats+        return (LamAlt v, pats')++      CaseAlt -> do+        pats' <- markAnnotated pats+        return (CaseAlt, pats')++      _ -> do+        mctxt' <- withPpr mctxt+        return (mctxt', pats)++  grhss' <- markAnnotated grhss++  return (Match an mctxt' pats' grhss')++-- ---------------------------------------------------------------------++instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where+  getAnnotationEntry (GRHSs _ _ _) = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (GRHSs cs grhss binds) = do+    addCommentsA $ priorComments cs+    addCommentsA $ getFollowingComments cs+    grhss' <- markAnnotated grhss+    binds' <- markAnnotated binds+    -- The comments will be added back as they are printed+    return (GRHSs emptyComments grhss' binds')+++instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where+  getAnnotationEntry (GRHSs _ _ _) = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (GRHSs cs grhss binds) = do+    addCommentsA $ priorComments cs+    addCommentsA $ getFollowingComments cs+    grhss' <- markAnnotated grhss+    binds' <- markAnnotated binds+    -- The comments will be added back as they are printed+    return (GRHSs emptyComments grhss' binds')++-- ---------------------------------------------------------------------++instance ExactPrint (HsLocalBinds GhcPs) where+  getAnnotationEntry (HsValBinds an _) = fromAnn an+  getAnnotationEntry (HsIPBinds{}) = NoEntryVal+  getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal++  setAnnotationAnchor (HsValBinds an a) anc ts cs = HsValBinds (setAnchorEpaL an anc ts cs) a+  setAnnotationAnchor a _ _ _ = a++  exact (HsValBinds an valbinds) = do+    an0 <- markLensFun' an lal_rest markEpToken -- 'where'++    case al_anchor $ anns an of+      Just anc -> do+        when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc)+      _ -> return ()++    (an1, valbinds') <- markAnnList an0 $ markAnnotatedWithLayout valbinds+    debugM $ "exact HsValBinds: an1=" ++ showAst an1+    medr <- getExtraDPReturn+    an2 <- case medr of+             Nothing -> return an1+             Just (ss,dp) -> do+                 setExtraDPReturn Nothing+                 return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta ss dp []) }}+    return (HsValBinds an2 valbinds')++  exact (HsIPBinds an bs) = do+    (an2,bs') <- markAnnListA an $ \an0 -> do+                           an1 <- markLensFun' an0 lal_rest markEpToken+                           bs' <- markAnnotated bs+                           return (an1, bs')+    return (HsIPBinds an2 bs')+  exact b@(EmptyLocalBinds _) = return b+++-- ---------------------------------------------------------------------+instance ExactPrint (HsValBindsLR GhcPs GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (ValBinds sortKey binds sigs) = do+    decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs)+    let+      binds' = concatMap decl2Bind decls+      sigs'  = concatMap decl2Sig decls+      sortKey' = captureOrderBinds decls+    return (ValBinds sortKey' binds' sigs')+  exact (XValBindsLR _) = panic "XValBindsLR"++undynamic :: Typeable a => [Dynamic] -> [a]+undynamic ds = mapMaybe fromDynamic ds++-- ---------------------------------------------------------------------++instance ExactPrint (HsIPBinds GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (IPBinds x binds) = setLayoutBoth $ do+      binds' <- markAnnotated binds+      return (IPBinds x binds')++-- ---------------------------------------------------------------------++instance ExactPrint (IPBind GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (IPBind an lr rhs) = do+    lr' <- markAnnotated lr+    an0 <- markEpToken an+    rhs' <- markAnnotated rhs+    return (IPBind an0 lr' rhs')+++-- ---------------------------------------------------------------------++instance ExactPrint HsIPName where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact i@(HsIPName fs) = printStringAdvanceA ("?" ++ (unpackFS fs)) >> return i++-- ---------------------------------------------------------------------+-- Managing lists which have been separated, e.g. Sigs and Binds++prepareListAnnotationF :: (Monad m, Monoid w) =>+  [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)]+prepareListAnnotationF ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls+  where+    go (L l a) = do+      (L l' d') <- markAnnotated (L l a)+      return (toDyn (L l' d'))++prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))+  => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)]+prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls+  where+    go b = do+      b' <- markAnnotated b+      return (toDyn b')++withSortKey :: (Monad m, Monoid w)+  => AnnSortKey DeclTag -> [(DeclTag, [(RealSrcSpan, EP w m Dynamic)])]+  -> EP w m (AnnSortKey DeclTag, [Dynamic])+withSortKey annSortKey xs = do+  debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey+  let (sk, ordered) = case annSortKey of+                  NoAnnSortKey -> (annSortKey', map snd os)+                    where+                      doOne (tag, ds) = map (\d -> (tag, d)) ds+                      xsExpanded = concatMap doOne xs+                      os = sortBy orderByFst $ xsExpanded+                      annSortKey' = AnnSortKey (map fst os)+                  AnnSortKey _keys -> (annSortKey, orderedDecls annSortKey (Map.fromList xs))+  ordered' <- mapM snd ordered+  return (sk, ordered')++orderByFst :: Ord a => (t, (a,b1)) -> (t, (a, b2)) -> Ordering+orderByFst (_,(a,_)) (_,(b,_)) = compare a b++-- ---------------------------------------------------------------------++instance ExactPrint (Sig GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (TypeSig (AnnSig dc mp md) vars ty)  = do+    (dc', vars', ty') <- exactVarSig dc vars ty+    return (TypeSig (AnnSig dc' mp md) vars' ty')++  exact (PatSynSig (AnnSig dc mp md) lns typ) = do+    mp' <- mapM markEpToken mp+    lns' <- markAnnotated lns+    dc' <- markEpUniToken dc+    typ' <- markAnnotated typ+    return (PatSynSig (AnnSig dc' mp' md) lns' typ')++  exact (ClassOpSig (AnnSig dc mp md) is_deflt vars ty)+    | is_deflt  = do+        md' <- mapM markEpToken md+        (dc', vars',ty') <- exactVarSig dc vars ty+        return (ClassOpSig (AnnSig dc' mp md') is_deflt vars' ty')+    | otherwise = do+        (dc', vars',ty') <- exactVarSig dc vars ty+        return (ClassOpSig (AnnSig dc' mp md) is_deflt vars' ty')++  exact (FixSig ((af, ma),src) (FixitySig ns names (Fixity v fdir))) = do+    let fixstr = case fdir of+         InfixL -> "infixl"+         InfixR -> "infixr"+         InfixN -> "infix"+    af' <- printStringAtAA af fixstr+    ma' <- mapM (\l -> printStringAtAA l (sourceTextToString src (show v))) ma+    ns' <- markAnnotated ns+    names' <- markAnnotated names+    return (FixSig ((af',ma'),src) (FixitySig ns' names' (Fixity v fdir)))++  exact (InlineSig (o,c,act) ln inl) = do+    o' <- markAnnOpen'' o (inl_src inl) "{-# INLINE"+    act' <- markActivation act (inl_act inl)+    ln' <- markAnnotated ln+    c' <- markEpToken c+    return (InlineSig (o', c', act') ln' inl)++  exact (SpecSig (AnnSpecSig o c dc act) ln typs inl) = do+    o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE+    act' <- markActivation act (inl_act inl)+    ln' <- markAnnotated ln+    dc' <- traverse markEpUniToken dc+    typs' <- markAnnotated typs+    c' <- markEpToken c+    return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl)++  exact (SpecSigE (AnnSpecSig o c dc act) bndrs expr inl) = do+    o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE+    act' <- markActivation act (inl_act inl)+    bndrs' <- markAnnotated bndrs+    expr' <- markAnnotated expr+    c' <- markEpToken c+    return (SpecSigE (AnnSpecSig o' c' dc act') bndrs' expr' inl)++  exact (SpecInstSig ((o,i,c),src) typ) = do+    o' <- markAnnOpen'' o src "{-# SPECIALISE"+    i' <- markEpToken i+    typ' <- markAnnotated typ+    c' <- markEpToken c+    return (SpecInstSig ((o',i',c'),src) typ')++  exact (MinimalSig ((o,c),src) formula) = do+    o' <- markAnnOpen'' o src "{-# MINIMAL"+    formula' <- markAnnotated formula+    c' <- markEpToken c+    return (MinimalSig ((o',c'),src) formula')++  exact (SCCFunSig ((o,c),src) ln ml) = do+    o' <- markAnnOpen'' o src "{-# SCC"+    ln' <- markAnnotated ln+    ml' <- markAnnotated ml+    c' <- markEpToken c+    return (SCCFunSig ((o',c'),src) ln' ml')++  exact (CompleteMatchSig ((o,md,c),src) cs mty) = do+    o' <- markAnnOpen'' o src "{-# COMPLETE"+    cs' <- mapM markAnnotated cs+    (md', mty') <-+      case mty of+        Nothing -> return (md, mty)+        Just ty -> do+          md' <- mapM markEpUniToken md+          ty' <- markAnnotated ty+          return (md', Just ty')+    c' <- markEpToken c+    return (CompleteMatchSig ((o',md',c'),src) cs' mty')++-- ---------------------------------------------------------------------++instance ExactPrint NamespaceSpecifier where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact NoNamespaceSpecifier = return NoNamespaceSpecifier+  exact (TypeNamespaceSpecifier typeTok) = do+      typeTok' <- markEpToken typeTok+      return (TypeNamespaceSpecifier typeTok')+  exact (DataNamespaceSpecifier dataTok) = do+      dataTok' <- markEpToken dataTok+      return (DataNamespaceSpecifier dataTok')++-- ---------------------------------------------------------------------++exactVarSig :: (Monad m, Monoid w, ExactPrint a)+  => TokDcolon -> [LocatedN RdrName] -> a -> EP w m (TokDcolon, [LocatedN RdrName], a)+exactVarSig dc vars ty = do+  vars' <- mapM markAnnotated vars+  dc' <- markEpUniToken dc+  ty' <- markAnnotated ty+  return (dc', vars', ty')++-- ---------------------------------------------------------------------++instance ExactPrint (StandaloneKindSig GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (StandaloneKindSig (tt,td) vars sig) = do+    tt' <- markEpToken tt+    vars' <- markAnnotated vars+    td' <- markEpUniToken td+    sig' <- markAnnotated sig+    return (StandaloneKindSig (tt',td') vars' sig')++-- ---------------------------------------------------------------------++instance ExactPrint (DefaultDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (DefaultDecl (d,op,cp) cl tys) = do+    d' <- markEpToken d+    cl' <- markAnnotated cl+    op' <- markEpToken op+    tys' <- markAnnotated tys+    cp' <- markEpToken cp+    return (DefaultDecl (d',op',cp') cl' tys')++-- ---------------------------------------------------------------------++instance ExactPrint (AnnDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do+    o' <- markAnnOpen'' o src "{-# ANN"+    (t', m', prov') <-+      case prov of+        (ValueAnnProvenance n) -> do+          n' <- markAnnotated n+          return (t, m, ValueAnnProvenance n')+        (TypeAnnProvenance n) -> do+          t' <- markEpToken t+          n' <- markAnnotated n+          return (t', m, TypeAnnProvenance n')+        ModuleAnnProvenance -> do+          m' <- markEpToken m+          return (t, m', prov)++    e' <- markAnnotated e+    c' <- markEpToken c+    return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e')++-- ---------------------------------------------------------------------++instance ExactPrint (BF.BooleanFormula GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (BF.Var x)  = do+    x' <- markAnnotated x+    return (BF.Var x')+  exact (BF.Or ls)  = do+    ls' <- markAnnotated ls+    return (BF.Or ls')+  exact (BF.And ls) = do+    ls' <- markAnnotated ls+    return (BF.And ls')+  exact (BF.Parens x)  = do+    x' <- markAnnotated x+    return (BF.Parens x')++-- ---------------------------------------------------------------------++instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _= a+  exact (HsWC x ty) = do+    ty' <- markAnnotated ty+    return (HsWC x ty')++-- ---------------------------------------------------------------------++instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where+  getAnnotationEntry (GRHS an _ _) = fromAnn an+  setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b++  exact (GRHS an guards expr) = do+    an0 <- if null guards+             then return an+             else markLensFun' an lga_vbar (\mt -> mapM markEpToken mt)+    guards' <- markAnnotated guards+    -- Mark the matchSeparator for these GRHSs+    an1 <- markLensFun' an0 lga_sep (\s -> case s of+                                       Left  tok -> Left  <$> markEpToken tok+                                       Right tok -> Right <$> markEpUniToken tok)+    expr' <- markAnnotated expr+    return (GRHS an1 guards' expr')++instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where+  getAnnotationEntry (GRHS ann _ _) = fromAnn ann+  setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b++  exact (GRHS an guards expr) = do+    an0 <- markLensFun' an lga_vbar (\mt -> mapM markEpToken mt)+    guards' <- markAnnotated guards+    -- Mark the matchSeparator for these GRHSs+    an1 <- markLensFun' an0 lga_sep (\s -> case s of+                                       Left  tok -> Left  <$> markEpToken tok+                                       Right tok -> Right <$> markEpUniToken tok)+    expr' <- markAnnotated expr+    return (GRHS an1 guards' expr')++-- ---------------------------------------------------------------------++instance ExactPrint (HsExpr GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _s = a++  exact (HsVar x n) = do+    -- The parser inserts a placeholder value for a record pun rhs. This must be+    -- filtered.+    let pun_RDR = "pun-right-hand-side"+    n' <- if (showPprUnsafe n /= pun_RDR)+      then markAnnotated n+      else return n+    return (HsVar x n')+  exact (HsHole (HoleVar n)) = do+    let pun_RDR = "pun-right-hand-side"+    n' <- if (showPprUnsafe n /= pun_RDR)+      then markAnnotated n+      else return n+    return (HsHole (HoleVar n'))+  -- TODO: Adapt 'HoleError' to include the 'SourceText':+  exact (HsHole HoleError) = error "Cannot exact print HoleError"+  exact x@(HsOverLabel src l) = do+    printStringAdvanceA "#" >> return ()+    case src of+      NoSourceText   -> printStringAdvanceA (unpackFS l)  >> return ()+      SourceText txt -> printStringAdvanceA (unpackFS txt) >> return ()+    return x++  exact x@(HsIPVar _ (HsIPName n))+    = printStringAdvance ("?" ++ unpackFS n) >> return x++  exact x@(HsOverLit _an ol) = do+    let str = case ol_val ol of+                HsIntegral   (IL src _ _) -> src+                HsFractional (FL { fl_text = src }) -> src+                HsIsString src _          -> src+    case str of+      SourceText s -> printStringAdvance (unpackFS s) >> return ()+      NoSourceText -> withPpr x >> return ()+    return x++  exact (HsLit an lit) = do+    lit' <- withPpr lit+    return (HsLit an lit')++  exact (HsLam an lam_variant mg) = do+    an0 <- markLensFun an lepl_lambda markEpToken+    an1 <- case lam_variant of+             LamSingle -> return an0+             LamCase  -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml)+             LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml)+    mg' <- markAnnotated mg+    return (HsLam an1 lam_variant mg')++  exact (HsApp an e1 e2) = do+    p <- getPosP+    debugM $ "HsApp entered. p=" ++ show p+    e1' <- markAnnotated e1+    e2' <- markAnnotated e2+    return (HsApp an e1' e2')+  exact (HsAppType at fun arg) = do+    fun' <- markAnnotated fun+    at' <- markEpToken at+    arg' <- markAnnotated arg+    return (HsAppType at' fun' arg')+  exact (OpApp x e1 e2 e3) = do+    e1' <- markAnnotated e1+    e2' <- markAnnotated e2+    e3' <- markAnnotated e3+    return (OpApp x e1' e2' e3')++  exact (NegApp an e s) = do+    an0 <- markEpToken an+    e' <- markAnnotated e+    return (NegApp an0 e' s)++  exact (HsPar (lpar, rpar) e) = do+    lpar' <- markEpToken lpar+    e' <- markAnnotated e+    debugM $ "HsPar closing paren"+    rpar' <- markEpToken rpar+    debugM $ "HsPar done"+    return (HsPar (lpar', rpar') e')++  exact (SectionL an expr op) = do+    expr' <- markAnnotated expr+    op' <- markAnnotated op+    return (SectionL an expr' op')++  exact (SectionR an op expr) = do+    op' <- markAnnotated op+    expr' <- markAnnotated expr+    return (SectionR an op' expr')++  exact (ExplicitTuple (o,c) args b) = do+    o0 <- if b == Boxed then printStringAtAA o "("+                        else printStringAtAA o "(#"++    args' <- mapM markAnnotated args++    c0 <- if b == Boxed then printStringAtAA c ")"+                        else printStringAtAA c "#)"+    debugM $ "ExplicitTuple done"+    return (ExplicitTuple (o0,c0) args' b)++  exact (ExplicitSum an alt arity expr) = do+    an0 <- markLensFun an laesOpen (\loc -> printStringAtAA loc "(#")+    an1 <- markLensFun an0 laesBarsBefore (\locs -> mapM markEpToken locs)+    expr' <- markAnnotated expr+    an2 <- markLensFun an1 laesBarsAfter (\locs -> mapM markEpToken locs)+    an3 <- markLensFun an2 laesClose (\loc -> printStringAtAA loc "#)")+    return (ExplicitSum an3 alt arity expr')++  exact (HsCase an e alts) = do+    an0 <- markLensFun an lhsCaseAnnCase markEpToken+    e' <- markAnnotated e+    an1 <- markLensFun an0 lhsCaseAnnOf markEpToken+    alts' <- setLayoutBoth $ markAnnotated alts+    return (HsCase an1 e' alts')++  exact (HsIf an e1 e2 e3) = do+    an0 <- markLensFun an laiIf markEpToken+    e1' <- markAnnotated e1+    an1 <- markLensFun an0 laiThenSemi (\mt -> mapM markEpToken mt)+    an2 <- markLensFun an1 laiThen markEpToken+    e2' <- markAnnotated e2+    an3 <- markLensFun an2 laiElseSemi (\mt -> mapM markEpToken mt)+    an4 <- markLensFun an3 laiElse markEpToken+    e3' <- markAnnotated e3+    return (HsIf an4 e1' e2' e3')++  exact (HsMultiIf (i,o,c) mg) = do+    i0 <- markEpToken i+    o0 <- markEpToken o+    mg' <- markAnnotated mg+    c0 <- markEpToken c+    return (HsMultiIf (i0,o0,c0) mg')++  exact (HsLet (tkLet, tkIn) binds e) = do+    setLayoutBoth $ do -- Make sure the 'in' gets indented too+      tkLet' <- markEpToken tkLet+      binds' <- setLayoutBoth $ markAnnotated binds+      tkIn' <- markEpToken tkIn+      e' <- markAnnotated e+      return (HsLet (tkLet',tkIn') binds' e')++  exact (HsDo an do_or_list_comp stmts) = do+    debugM $ "HsDo"+    (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts+    return (HsDo an' do_or_list_comp stmts')++  exact (ExplicitList an es) = do+    debugM $ "ExplicitList start"+    an0 <- markLensBracketsO' an lal_brackets+    es' <- markAnnotated es+    an1 <- markLensBracketsC' an0 lal_brackets+    debugM $ "ExplicitList end"+    return (ExplicitList an1 es')+  exact (RecordCon (open, close) con_id binds) = do+    con_id' <- markAnnotated con_id+    open' <- mapM markEpToken open+    binds' <- markAnnotated binds+    close' <- mapM markEpToken close+    return (RecordCon (open',close') con_id' binds')+  exact (RecordUpd (open, close) expr fields) = do+    expr' <- markAnnotated expr+    open' <- mapM markEpToken open+    fields' <- markAnnotated fields+    close' <- mapM markEpToken close+    return (RecordUpd (open', close') expr' fields')+  exact (HsGetField an expr field) = do+    expr' <- markAnnotated expr+    field' <- markAnnotated field+    return (HsGetField an expr' field')+  exact (HsProjection an flds) = do+    an0 <- markLensFun an lapOpen markEpToken+    flds' <- mapM markAnnotated flds+    an1 <- markLensFun an0 lapClose markEpToken+    return (HsProjection an1 flds')+  exact (ExprWithTySig an expr sig) = do+    expr' <- markAnnotated expr+    an0 <- markEpUniToken an+    sig' <- markAnnotated sig+    return (ExprWithTySig an0 expr' sig')+  exact (ArithSeq (AnnArithSeq o mc dd c) s seqInfo) = do+    o' <- markEpToken o+    (mc', dd', seqInfo') <-+      case seqInfo of+        From e -> do+          e' <- markAnnotated e+          dd' <- markEpToken dd+          return (mc, dd', From e')+        FromTo e1 e2 -> do+          e1' <- markAnnotated e1+          dd' <- markEpToken dd+          e2' <- markAnnotated e2+          return (mc, dd', FromTo e1' e2')+        FromThen e1 e2 -> do+          e1' <- markAnnotated e1+          mc' <- mapM markEpToken mc+          e2' <- markAnnotated e2+          dd' <- markEpToken dd+          return (mc', dd', FromThen e1' e2')+        FromThenTo e1 e2 e3 -> do+          e1' <- markAnnotated e1+          mc' <- mapM markEpToken mc+          e2' <- markAnnotated e2+          dd' <- markEpToken dd+          e3' <- markAnnotated e3+          return (mc', dd', FromThenTo e1' e2' e3')+    c' <- markEpToken c+    return (ArithSeq (AnnArithSeq o' mc' dd' c') s seqInfo')+++  exact (HsTypedBracket (o,c) e) = do+    o' <- case o of+      BracketNoE  t -> BracketNoE  <$> markEpToken t+      BracketHasE t -> BracketHasE <$> markEpToken t+    e' <- markAnnotated e+    c' <- markEpToken c+    return (HsTypedBracket (o',c') e')++  exact (HsUntypedBracket a (ExpBr (o,c) e)) = do+    o' <- case o of+      BracketNoE  t -> BracketNoE  <$> markEpUniToken t+      BracketHasE t -> BracketHasE <$> markEpToken t+    e' <- markAnnotated e+    c' <- markEpUniToken c+    return (HsUntypedBracket a (ExpBr (o',c') e'))++  exact (HsUntypedBracket a (PatBr (o,c) e)) = do+    o' <- markEpToken o+    e' <- markAnnotated e+    c' <- markEpUniToken c+    return (HsUntypedBracket a (PatBr (o',c') e'))++  exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do+    o' <- markEpToken o+    oc' <- markEpToken oc+    e' <- markAnnotated e+    cc' <- markEpToken cc+    c' <- markEpUniToken c+    return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e'))++  exact (HsUntypedBracket a (TypBr (o,c) e)) = do+    o' <- markEpToken o+    e' <- markAnnotated e+    c' <- markEpUniToken c+    return (HsUntypedBracket a (TypBr (o',c') e'))++  exact (HsUntypedBracket a (VarBr an b e)) = do+    (an0, e') <- if b+      then do+        an' <- printStringAtAA an "'"+        e' <- markAnnotated e+        return (an', e')+      else do+        an' <- printStringAtAA an "''"+        e' <- markAnnotated e+        return (an', e')+    return (HsUntypedBracket a (VarBr an0 b e'))++  exact (HsTypedSplice an s)   = do+    s' <- markAnnotated s+    return (HsTypedSplice an s')++  exact (HsUntypedSplice an s) = do+    s' <- markAnnotated s+    return (HsUntypedSplice an s')++  exact (HsProc (pr,r) p c) = do+    debugM $ "HsProc start"+    pr' <- markEpToken pr+    p' <- markAnnotated p+    r' <- markEpUniToken r+    c' <- markAnnotated c+    return (HsProc (pr',r') p' c')++  exact (HsStatic an e) = do+    an0 <- markEpToken an+    e' <- markAnnotated e+    return (HsStatic an0 e')++  exact (HsPragE a prag e) = do+    prag' <- markAnnotated prag+    e' <- markAnnotated e+    return (HsPragE a prag' e')++  exact (HsEmbTy toktype t) = do+    toktype' <- markEpToken toktype+    t' <- markAnnotated t+    return (HsEmbTy toktype' t')++  exact (HsFunArr _ mult arg res) = do+    (mult', arg') <- markMultAnnOf mult (markAnnotated arg)+    res' <- markAnnotated res+    return (HsFunArr noExtField mult' arg' res')++  exact (HsForAll _ tele body) = do+    tele' <- markAnnotated tele+    body' <- markAnnotated body+    return (HsForAll noExtField tele' body')++  exact (HsQual _ ctxt body) = do+    ctxt' <- markAnnotated ctxt+    body' <- markAnnotated body+    return (HsQual noExtField ctxt' body')++  exact x = error $ "exact HsExpr for:" ++ showAst x++-- ---------------------------------------------------------------------++exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))+        => AnnList EpaLocation -> HsDoFlavour -> LocatedAn an a+        -> EP w m (AnnList EpaLocation, LocatedAn an a)+exactDo an (DoExpr m)    stmts = exactMdo an m "do"          >>= \an0 -> markMaybeDodgyStmts an0 stmts+exactDo an GhciStmtCtxt  stmts = markLensFun an lal_rest (\l -> printStringAtAA l "do") >>=+                                 \an0 -> markMaybeDodgyStmts an0 stmts+exactDo an (MDoExpr m)   stmts = exactMdo an m  "mdo" >>= \an0 -> markMaybeDodgyStmts an0 stmts+exactDo an ListComp      stmts = markMaybeDodgyStmts an stmts+exactDo an MonadComp     stmts = markMaybeDodgyStmts an stmts++exactMdo :: (Monad m, Monoid w)+  => AnnList EpaLocation -> Maybe ModuleName -> String -> EP w m (AnnList EpaLocation)+exactMdo an Nothing            kw = markLensFun an lal_rest (\l -> printStringAtAA l kw)+exactMdo an (Just module_name) kw = markLensFun an lal_rest (\l -> printStringAtAA l n)+    where+      n = (moduleNameString module_name) ++ "." ++ kw++markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))+  => AnnList l -> LocatedAn an a -> EP w m (AnnList l, LocatedAn an a)+markMaybeDodgyStmts an stmts =+  if notDodgy stmts+    then do+      r <- markAnnotatedWithLayout stmts+      return (an, r)+    else return (an, stmts)++notDodgy :: GenLocated (EpAnn ann) a -> Bool+notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc++notDodgyE :: EpaLocation -> Bool+notDodgyE anc =+  case anc of+    EpaSpan s -> isGoodSrcSpan s+    EpaDelta{} -> True++-- ---------------------------------------------------------------------+instance ExactPrint (HsPragE GhcPs) where+  getAnnotationEntry HsPragSCC{}  = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do+    o' <- markAnnOpen'' o st  "{-# SCC"+    l1' <- printStringAtAA l1 (sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl))+    c' <- markEpToken c+    return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl)++instance ExactPrint (HsTypedSplice GhcPs) where+  getAnnotationEntry _ = NoEntryVal++  setAnnotationAnchor a _ _ _ = a++  exact (HsTypedSpliceExpr an e) = do+    an0 <- markEpToken an+    e' <- markAnnotated e+    return (HsTypedSpliceExpr an0 e')+++-- ---------------------------------------------------------------------++instance ExactPrint (HsUntypedSplice GhcPs) where+  getAnnotationEntry _ = NoEntryVal++  setAnnotationAnchor a _ _  _= a++  exact (HsUntypedSpliceExpr an e) = do+    an0 <- markEpToken an+    e' <- markAnnotated e+    return (HsUntypedSpliceExpr an0 e')++  exact (HsQuasiQuote an q (L l fs)) = do+    -- The quasiquote string does not honour layout offsets. Store+    -- the colOffset for now.+    -- TODO: use local?+    oldOffset <- getLayoutOffsetP+    EPState{pMarkLayout} <- get+    unless pMarkLayout $ setLayoutOffsetP 0+    printStringAdvance+            -- Note: Lexer.x does not provide unicode alternative. 2017-02-26+            ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]")+    unless pMarkLayout $ setLayoutOffsetP oldOffset+    return (HsQuasiQuote an q (L l fs))++-- ---------------------------------------------------------------------++-- TODO:AZ: combine these instances+instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (MG x matches) = do+    -- TODO:AZ use SortKey, in MG ann.+    matches' <- markAnnotated matches+    return (MG x matches')++instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (MG x matches) = do+    -- TODO:AZ use SortKey, in MG ann.+    matches' <- if notDodgy matches+      then markAnnotated matches+      else return matches+    return (MG x matches')++-- ---------------------------------------------------------------------++instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (HsRecFields x fields mdot) = do+    fields' <- markAnnotated fields+    mdot' <- case mdot of+      Nothing -> return Nothing+      Just (L ss d) -> do+        ss' <- printStringAtAA ss ".."+        return $ Just (L ss' d)+      -- Note: mdot contains the SrcSpan where the ".." appears, if present+    return (HsRecFields x fields' mdot')++-- ---------------------------------------------------------------------++instance (ExactPrint body)+    => ExactPrint (HsFieldBind (LocatedA (FieldOcc GhcPs)) body) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsFieldBind an f arg isPun) = do+    debugM $ "HsFieldBind"+    f' <- markAnnotated f+    (an0, arg') <- if isPun then return (an, arg)+             else do+               an0 <- mapM markEpToken an+               arg' <- markAnnotated arg+               return (an0, arg')+    return (HsFieldBind an0 f' arg' isPun)++-- ---------------------------------------------------------------------++instance (ExactPrint body)+    => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsFieldBind an f arg isPun) = do+    debugM $ "HsFieldBind FieldLabelStrings"+    f' <- markAnnotated f+    (an0, arg') <- if isPun then return (an, arg)+             else do+               an0 <- mapM markEpToken an+               arg' <- markAnnotated arg+               return (an0, arg')+    return (HsFieldBind an0 f' arg' isPun)++-- ---------------------------------------------------------------------++instance ExactPrint (LHsRecUpdFields GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact flds@(RegularRecUpdFields    { recUpdFields  = rbinds }) = do+    debugM $ "RegularRecUpdFields"+    rbinds' <- markAnnotated rbinds+    return $ flds { recUpdFields = rbinds' }+  exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do+    debugM $ "OverloadedRecUpdFields"+    pbinds' <- markAnnotated pbinds+    return $ flds { olRecUpdFields = pbinds' }++-- ---------------------------------------------------------------------++instance ExactPrint (FieldLabelStrings GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs++-- ---------------------------------------------------------------------++instance ExactPrint (DotFieldOcc GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do+    an0 <- markLensFun an lafDot (\ml -> mapM markEpToken ml)+    -- The field name has a SrcSpanAnnN, print it as a+    -- LocatedN RdrName+    L loc' _ <- markAnnotated (L loc (mkVarUnqual fs))+    return (DotFieldOcc an0 (L loc' (FieldLabelString fs)))++-- ---------------------------------------------------------------------++instance ExactPrint (HsTupArg GhcPs) where+  getAnnotationEntry (Present _ _) = NoEntryVal+  getAnnotationEntry (Missing (EpAnn _ False _)) = NoEntryVal+  getAnnotationEntry (Missing an)   = fromAnn an++  setAnnotationAnchor (Present a b) _ _ _ = Present a b+  setAnnotationAnchor (Missing an)   anc ts cs = Missing (setAnchorEpa an anc ts cs)++  exact (Present a e) = Present a <$> markAnnotated e++  exact a@(Missing (EpAnn _ False _)) = return a+  exact a@(Missing _) = printStringAdvance "," >> return a++-- ---------------------------------------------------------------------++instance ExactPrint (HsCmdTop GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd++-- ---------------------------------------------------------------------++instance ExactPrint (HsCmd GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp True) = do+    arr' <- markAnnotated arr+    l' <- case isU of+      UnicodeSyntax -> printStringAtAA l  "⤙"+      NormalSyntax -> printStringAtAA l  "-<"+    arg' <- markAnnotated arg+    return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp True)+  exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp False) = do+    arg' <- markAnnotated arg+    l' <- case isU of+      UnicodeSyntax -> printStringAtAA l  "⤚"+      NormalSyntax -> printStringAtAA l  ">-"+    arr' <- markAnnotated arr+    return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp False)+  exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp True) = do+    arr' <- markAnnotated arr+    l' <- case isU of+      UnicodeSyntax -> printStringAtAA l  "⤛"+      NormalSyntax -> printStringAtAA l  "-<<"+    arg' <- markAnnotated arg+    return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp True)+  exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp False) = do+    arg' <- markAnnotated arg+    l' <- case isU of+      UnicodeSyntax -> printStringAtAA l  "⤜"+      NormalSyntax -> printStringAtAA l  ">>-"+    arr' <- markAnnotated arr+    return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False)++  exact (HsCmdArrForm an e fixity cs) = do+    an0 <- markLensBracketsO' an lal_brackets+    (e',cs') <- case (fixity, cs) of+      (Infix, (arg1:argrest)) -> do+        arg1' <- markAnnotated arg1+        e' <- markAnnotated e+        argrest' <- markAnnotated argrest+        return (e', arg1':argrest')+      (Prefix, _) -> do+        e' <- markAnnotated e+        cs' <- markAnnotated cs+        return (e', cs')+      (Infix, []) -> error "Not possible"+    an1 <- markLensBracketsC' an0 lal_brackets+    return (HsCmdArrForm an1 e' fixity cs')++  exact (HsCmdApp an e1 e2) = do+    e1' <- markAnnotated e1+    e2' <- markAnnotated e2+    return (HsCmdApp an e1' e2')++  exact (HsCmdLam an lam_variant matches) = do+    an0 <- markLensFun an lepl_lambda markEpToken+    an1 <- case lam_variant of+             LamSingle -> return an0+             LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml)+             LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml)+    matches' <- markAnnotated matches+    return (HsCmdLam an1 lam_variant matches')++  exact (HsCmdPar (lpar, rpar) e) = do+    lpar' <- markEpToken lpar+    e' <- markAnnotated e+    rpar' <- markEpToken rpar+    return (HsCmdPar (lpar', rpar') e')++  exact (HsCmdCase an e alts) = do+    an0 <- markLensFun an lhsCaseAnnCase markEpToken+    e' <- markAnnotated e+    an1 <- markLensFun an0 lhsCaseAnnOf markEpToken+    alts' <- markAnnotated alts+    return (HsCmdCase an1 e' alts')++  exact (HsCmdIf an a e1 e2 e3) = do+    an0 <- markLensFun an laiIf markEpToken+    e1' <- markAnnotated e1+    an1 <- markLensFun an0 laiThenSemi (\mt -> mapM markEpToken mt)+    an2 <- markLensFun an1 laiThen markEpToken+    e2' <- markAnnotated e2+    an3 <- markLensFun an2 laiElseSemi (\mt -> mapM markEpToken mt)+    an4 <- markLensFun an3 laiElse markEpToken+    e3' <- markAnnotated e3+    return (HsCmdIf an4 a e1' e2' e3')++  exact (HsCmdLet (tkLet, tkIn) binds e) = do+    setLayoutBoth $ do -- Make sure the 'in' gets indented too+      tkLet' <- markEpToken tkLet+      binds' <- setLayoutBoth $ markAnnotated binds+      tkIn' <- markEpToken tkIn+      e' <- markAnnotated e+      return (HsCmdLet (tkLet', tkIn') binds' e')++  exact (HsCmdDo an es) = do+    debugM $ "HsCmdDo"+    an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do")+    es' <- markAnnotated es+    return (HsCmdDo an0 es')++-- ---------------------------------------------------------------------++instance (+  ExactPrint (LocatedA (body GhcPs)),+                 Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA,+           Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW,+           (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))])))+   => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _s = a++  exact (LastStmt a body b c) = do+    debugM $ "LastStmt"+    body' <- markAnnotated body+    return (LastStmt a body' b c)++  exact (BindStmt an pat body) = do+    debugM $ "BindStmt"+    pat' <- markAnnotated pat+    an0 <- markEpUniToken an+    body' <- markAnnotated body+    return (BindStmt an0 pat' body')++  exact (BodyStmt a body b c) = do+    debugM $ "BodyStmt"+    body' <- markAnnotated body+    return (BodyStmt a body' b c)++  exact (LetStmt tlet binds) = do+    debugM $ "LetStmt"+    tlet' <- markEpToken tlet+    binds' <- markAnnotated binds+    return (LetStmt tlet' binds')++  exact (ParStmt a pbs b c) = do+    debugM $ "ParStmt"+    pbs' <- markAnnotated pbs+    return (ParStmt a pbs' b c)++  exact (TransStmt an form stmts b using by c d e) = do+    debugM $ "TransStmt"+    stmts' <- markAnnotated stmts+    (an', by', using') <- exactTransStmt an by using form+    return (TransStmt an' form stmts' b using' by' c d e)++  exact (RecStmt an stmts a b c d e) = do+    debugM $ "RecStmt"+    an0 <- markLensFun an lal_rest markEpToken+    (an1, stmts') <- markAnnList' an0 (markAnnotated stmts)+    return (RecStmt an1 stmts' a b c d e)++-- ---------------------------------------------------------------------++instance ExactPrint (ParStmtBlock GhcPs GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (ParStmtBlock a stmts b c) = do+    stmts' <- markAnnotated stmts+    return (ParStmtBlock a stmts' b c)++exactTransStmt :: (Monad m, Monoid w)+  => AnnTransStmt -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm+  -> EP w m (AnnTransStmt, Maybe (LHsExpr GhcPs), (LHsExpr GhcPs))+exactTransStmt (AnnTransStmt at ag ab au) by using ThenForm = do+  debugM $ "exactTransStmt:ThenForm"+  at' <- markEpToken at+  using' <- markAnnotated using+  case by of+    Nothing -> return (AnnTransStmt at' ag ab au, by, using')+    Just b -> do+      ab' <- mapM markEpToken ab+      b' <- markAnnotated b+      return ((AnnTransStmt at' ag ab' au), Just b', using')+exactTransStmt (AnnTransStmt at ag ab au) by using GroupForm = do+  debugM $ "exactTransStmt:GroupForm"+  at' <- markEpToken at+  ag' <- mapM markEpToken ag+  (ab', by') <- case by of+    Nothing -> return (ab, by)+    Just b -> do+      ab0 <- mapM markEpToken ab+      b' <- markAnnotated b+      return (ab0, Just b')+  au' <- mapM markEpToken au+  using' <- markAnnotated using+  return (AnnTransStmt at' ag' ab' au', by', using')++-- ---------------------------------------------------------------------++instance ExactPrint (TyClDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _s = a++  exact (FamDecl a decl) = do+    decl' <- markAnnotated decl+    return (FamDecl a decl')++  exact (SynDecl { tcdSExt = AnnSynDecl ops cps t eq+                 , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                 , tcdRhs = rhs }) = 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+    -- TODO: no longer sorting on insert. What now?+    epTokensToComments "(" ops+    epTokensToComments ")" cps+    t' <- markEpToken t++    (_,ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing+    eq' <- markEpToken eq+    rhs' <- markAnnotated rhs+    return (SynDecl { tcdSExt = AnnSynDecl [] [] t' eq'+                    , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity+                    , tcdRhs = rhs' })++  exact (DataDecl { tcdDExt = x, tcdLName = ltycon, tcdTyVars = tyvars+                  , tcdFixity = fixity, tcdDataDefn = defn }) = do+    (_,ltycon', tyvars', _, defn') <-+      exactDataDefn (exactVanillaDeclHead ltycon tyvars fixity) defn+    return (DataDecl { tcdDExt = x, tcdLName = ltycon', tcdTyVars = tyvars'+                     , tcdFixity = fixity, tcdDataDefn = defn' })++  -- -----------------------------------++  exact (ClassDecl {tcdCExt = (AnnClassDecl c ops cps vb w oc cc semis, lo, sortKey),+                    tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,+                    tcdFixity = fixity,+                    tcdFDs  = fds,+                    tcdSigs = sigs, tcdMeths = methods,+                    tcdATs = ats, tcdATDefs = at_defs,+                    tcdDocs = _docs})+      -- TODO: add a test that demonstrates tcdDocs+      | null sigs && null methods && null ats && null at_defs -- No "where" part+      = do+          (c', w', vb', fds', lclas', tyvars',context') <- top_matter+          oc' <- markEpToken oc+          cc' <- markEpToken cc+          return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis, lo, sortKey),+                             tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',+                             tcdFixity = fixity,+                             tcdFDs  = fds',+                             tcdSigs = sigs, tcdMeths = methods,+                             tcdATs = ats, tcdATDefs = at_defs,+                             tcdDocs = _docs})++      | otherwise       -- Laid out+      = do+          (c', w', vb', fds', lclas', tyvars',context') <- top_matter+          oc' <- markEpToken oc+          semis' <- mapM markEpToken semis+          (sortKey', ds) <- withSortKey sortKey+                               [(ClsSigTag, prepareListAnnotationA sigs),+                                (ClsMethodTag, prepareListAnnotationA methods),+                                (ClsAtTag, prepareListAnnotationA ats),+                                (ClsAtdTag, prepareListAnnotationA at_defs)+                             -- ++ prepareListAnnotation docs+                               ]+          cc' <- markEpToken cc+          let+            sigs'    = undynamic ds+            methods' = undynamic ds+            ats'     = undynamic ds+            at_defs' = undynamic ds+          return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis', lo, sortKey'),+                             tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',+                             tcdFixity = fixity,+                             tcdFDs  = fds',+                             tcdSigs = sigs', tcdMeths = methods',+                             tcdATs = ats', tcdATDefs = at_defs',+                             tcdDocs = _docs})+      where+        top_matter = do+          epTokensToComments "(" ops+          epTokensToComments ")" cps+          c' <- markEpToken c+          (_,lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context+          (vb', fds') <- if (null fds)+            then return (vb, fds)+            else do+              vb' <- markEpToken vb+              fds' <- markAnnotated fds+              return (vb', fds')+          w' <- markEpToken w+          return (c', w', vb', fds', lclas', tyvars',context')+++-- ---------------------------------------------------------------------++instance ExactPrint (FunDep GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (FunDep an ls rs') = do+    ls' <- markAnnotated ls+    an0 <- markEpUniToken an+    rs'' <- markAnnotated rs'+    return (FunDep an0 ls' rs'')++-- ---------------------------------------------------------------------++instance ExactPrint (FamilyDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (FamilyDecl { fdExt = AnnFamilyDecl ops cps t d f dc eq vb w oc dd cc+                    , fdInfo = info+                    , fdTopLevel = top_level+                    , fdLName = ltycon+                    , fdTyVars = tyvars+                    , fdFixity = fixity+                    , fdResultSig = L lr result+                    , fdInjectivityAnn = mb_inj }) = do+    (d',t') <- exactFlavour (d,t) info+    f' <- exact_top_level f++    epTokensToComments "(" ops+    epTokensToComments ")" cps+    (_,ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing+    (dc', eq', result') <- exact_kind (dc, eq)+    (vb', mb_inj') <-+      case mb_inj of+        Nothing -> return (vb, mb_inj)+        Just inj -> do+          vb' <- markEpToken vb+          inj' <- markAnnotated inj+          return (vb', Just inj')+    (w', oc', dd', cc', info') <-+             case info of+               ClosedTypeFamily mb_eqns -> do+                 w' <- markEpToken w+                 oc' <- markEpToken oc+                 (dd', mb_eqns') <-+                   case mb_eqns of+                     Nothing -> do+                       dd' <- markEpToken dd+                       return (dd', mb_eqns)+                     Just eqns -> do+                       eqns' <- markAnnotated eqns+                       return (dd, Just eqns')+                 cc' <- markEpToken cc+                 return (w',oc',dd',cc', ClosedTypeFamily mb_eqns')+               _ -> return (w,oc,dd,cc, info)+    return (FamilyDecl { fdExt = AnnFamilyDecl [] [] t' d' f' dc' eq' vb' w' oc' dd' cc'+                       , fdInfo = info'+                       , fdTopLevel = top_level+                       , fdLName = ltycon'+                       , fdTyVars = tyvars'+                       , fdFixity = fixity+                       , fdResultSig = L lr result'+                       , fdInjectivityAnn = mb_inj' })+    where+      exact_top_level tfamily =+        case top_level of+          TopLevel    -> markEpToken tfamily+          NotTopLevel -> do+            -- It seems that in some kind of legacy+            -- mode the 'family' keyword is still+            -- accepted.+            markEpToken tfamily++      exact_kind (tdcolon, tequal) =+        case result of+          NoSig    _         -> return (tdcolon, tequal, result)+          KindSig  x kind    -> do+            tdcolon' <- markEpUniToken tdcolon+            kind' <- markAnnotated kind+            return (tdcolon', tequal, KindSig  x kind')+          TyVarSig x tv_bndr -> do+            tequal' <- markEpToken tequal+            tv_bndr' <- markAnnotated tv_bndr+            return (tdcolon, tequal', TyVarSig x tv_bndr')+++exactFlavour :: (Monad m, Monoid w) => (EpToken "data", EpToken "type") -> FamilyInfo GhcPs -> EP w m (EpToken "data", EpToken "type")+exactFlavour (td,tt) DataFamily            = (\td' -> (td',tt)) <$> markEpToken td+exactFlavour (td,tt) OpenTypeFamily        = (td,)              <$> markEpToken tt+exactFlavour (td,tt) (ClosedTypeFamily {}) = (td,)              <$> markEpToken tt++-- ---------------------------------------------------------------------++exactDataDefn+  :: (Monad m, Monoid w)+  => (Maybe (LHsContext GhcPs) -> EP w m (r+                                         , LocatedN RdrName+                                         , a+                                         , b+                                         , Maybe (LHsContext GhcPs))) -- Printing the header+  -> HsDataDefn GhcPs+  -> EP w m ( r -- ^ from exactHdr+            , LocatedN RdrName, a, b, HsDataDefn GhcPs)+exactDataDefn exactHdr+                 (HsDataDefn { dd_ext = AnnDataDefn ops cps t nt d i dc w oc cc eq+                             , dd_ctxt = context+                             , dd_cType = mb_ct+                             , dd_kindSig = mb_sig+                             , dd_cons = condecls, dd_derivs = derivings }) = do+++  epTokensToComments "(" ops+  epTokensToComments ")" cps++  (t',nt',d') <- case condecls of+    DataTypeCons is_type_data _ -> do+      t' <- if is_type_data+                then markEpToken t+                else return t+      d' <- markEpToken d+      return (t',nt,d')+    NewTypeCon   _ -> do+      nt' <- markEpToken nt+      return (t, nt', d)++  i' <- markEpToken i -- optional 'instance'+  mb_ct' <- mapM markAnnotated mb_ct+  (anx, ln', tvs', b, mctxt') <- exactHdr context+  (dc', mb_sig') <- case mb_sig of+    Nothing -> return (dc, Nothing)+    Just kind -> do+      dc' <- markEpUniToken dc+      kind' <- markAnnotated kind+      return (dc', Just kind')+  w' <- if (needsWhere condecls)+    then markEpToken w+    else return w+  oc' <- markEpToken oc+  (eq', condecls') <- exact_condecls eq (toList condecls)+  let condecls'' = case condecls of+        DataTypeCons td _ -> DataTypeCons td condecls'+        NewTypeCon _     -> case condecls' of+          [decl] -> NewTypeCon decl+          _ -> panic "exacprint NewTypeCon"+  cc' <- markEpToken cc+  derivings' <- mapM markAnnotated derivings+  return (anx, ln', tvs', b,+                 (HsDataDefn { dd_ext = AnnDataDefn [] [] t' nt' d' i' dc' w' oc' cc' eq'+                             , dd_ctxt = mctxt'+                             , dd_cType = mb_ct'+                             , dd_kindSig = mb_sig'+                             , dd_cons = condecls'', dd_derivs = derivings' }))+++exactVanillaDeclHead :: (Monad m, Monoid w)+                     => LocatedN RdrName+                     -> LHsQTyVars GhcPs+                     -> LexicalFixity+                     -> Maybe (LHsContext GhcPs)+                     -> EP w m ( () -- TO allow use in exactDataDefn+                               , LocatedN RdrName+                               , LHsQTyVars GhcPs+                               , (), Maybe (LHsContext GhcPs))+exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do+  let+    exact_tyvars (varl:varsr)+      | hvarsr : tvarsr@(_ : _) <- varsr+      , fixity == Infix = do+          varl' <- markAnnotated varl+          thing' <- markAnnotated thing+          hvarsr' <- markAnnotated hvarsr+          tvarsr' <- markAnnotated tvarsr+          return (thing', varl':hvarsr':tvarsr')+      | fixity == Infix = do+          varl' <- markAnnotated varl+          thing' <- markAnnotated thing+          varsr' <- markAnnotated varsr+          return (thing', varl':varsr')+      | otherwise = do+          thing' <- markAnnotated thing+          vs <- mapM markAnnotated (varl:varsr)+          return (thing', vs)+    exact_tyvars [] = do+      thing' <- markAnnotated thing+      return (thing', [])+  context' <- mapM markAnnotated context+  (thing', tyvars') <- exact_tyvars tyvars+  return ((), thing', tvs { hsq_explicit = tyvars' }, (), context')++-- ---------------------------------------------------------------------++instance ExactPrint (InjectivityAnn GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (InjectivityAnn rarrow lhs rhs) = do+    lhs' <- markAnnotated lhs+    rarrow' <- markEpUniToken rarrow+    rhs' <- mapM markAnnotated rhs+    return (InjectivityAnn rarrow' lhs' rhs')++-- ---------------------------------------------------------------------++class Typeable flag => ExactPrintTVFlag flag where+  exactTVDelimiters :: (Monad m, Monoid w)+    => AnnTyVarBndr -> flag+    -> EP w m (HsTyVarBndr flag GhcPs)+    -> EP w m (AnnTyVarBndr, flag, HsTyVarBndr flag GhcPs)++instance ExactPrintTVFlag () where+  exactTVDelimiters (AnnTyVarBndr os cs ap dc) flag thing_inside = do+    os' <- markEpaLocationAll os "("+    r <- thing_inside+    cs' <- markEpaLocationAll cs ")"+    return (AnnTyVarBndr os' cs' ap dc, flag, r)++instance ExactPrintTVFlag Specificity where+  exactTVDelimiters (AnnTyVarBndr os cs ap dc) s thing_inside = do+    os' <- markEpaLocationAll os open+    r <- thing_inside+    cs' <- markEpaLocationAll cs close+    return (AnnTyVarBndr os' cs' ap dc, s, r)+    where+      (open, close) = case s of+        SpecifiedSpec -> ("(", ")")+        InferredSpec  -> ("{", "}")++instance ExactPrintTVFlag (HsBndrVis GhcPs) where+  exactTVDelimiters (AnnTyVarBndr os cs ap dc) bvis thing_inside = do+    bvis' <- case bvis of+      HsBndrRequired _ -> return bvis+      HsBndrInvisible at -> HsBndrInvisible <$> markEpToken at+    os' <- markEpaLocationAll os "("+    r <- thing_inside+    cs' <- markEpaLocationAll cs ")"+    return (AnnTyVarBndr os' cs' ap dc, bvis', r)++instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsTvb an flag n (HsBndrNoKind _)) = do+    r <- exactTVDelimiters an flag $  do+           n' <- markAnnotated n+           return (HsTvb an flag n' (HsBndrNoKind noExtField))+    case r of+      (an', flag', HsTvb _ _ n'' k'') -> return (HsTvb an' flag' n'' k'')++  exact (HsTvb an@(AnnTyVarBndr os cs ap dc) flag n (HsBndrKind _ k)) = do+    r <- exactTVDelimiters an flag $ do+          n' <- markAnnotated n+          dc' <- markEpUniToken dc+          k' <- markAnnotated k+          let an0 = AnnTyVarBndr os cs ap dc'+          return (HsTvb an0 flag n' (HsBndrKind noExtField k'))+    case r of+      (an',flag', HsTvb an1 _ n'' k'') -> return (HsTvb (an'{ atv_dcolon = atv_dcolon an1 }) flag' n'' k'')++instance ExactPrint (HsBndrVar GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsBndrVar x n) = do+    n' <- markAnnotated n+    return (HsBndrVar x n')+  exact (HsBndrWildCard t) = do+    t' <- markEpToken t+    return (HsBndrWildCard t')++-- ---------------------------------------------------------------------++instance ExactPrint (HsType GhcPs) where+  getAnnotationEntry _         = NoEntryVal+  setAnnotationAnchor a _ _ _s = a++  exact (HsForAllTy { hst_xforall = an+                    , hst_tele = tele, hst_body = ty }) = do+    tele' <- markAnnotated tele+    ty' <- markAnnotated ty+    return (HsForAllTy { hst_xforall = an+                       , hst_tele = tele', hst_body = ty' })++  exact (HsQualTy an ctxt ty) = do+    ctxt' <- markAnnotated ctxt+    ty' <- markAnnotated ty+    return (HsQualTy an ctxt' ty')+  exact (HsTyVar an promoted name) = do+    an0 <- if (promoted == IsPromoted)+             then markEpToken an+             else return an+    name' <- markAnnotated name+    return (HsTyVar an0 promoted name')+  exact (HsAppTy an t1 t2) = do+    t1' <- markAnnotated t1+    t2' <- markAnnotated t2+    return (HsAppTy an t1' t2')+  exact (HsAppKindTy at ty ki) = do+    ty' <- markAnnotated ty+    at' <- markEpToken at+    ki' <- markAnnotated ki+    return (HsAppKindTy at' ty' ki')+  exact (HsFunTy an mult ty1 ty2) = do+    (mult', ty1') <- markMultAnnOf mult (markAnnotated ty1)+    ty2' <- markAnnotated ty2+    return (HsFunTy an mult' ty1' ty2')+  exact (HsListTy an tys) = do+    an0 <- markOpeningParen an+    tys' <- markAnnotated tys+    an1 <- markClosingParen an0+    return (HsListTy an1 tys')+  exact (HsTupleTy an con tys) = do+    an0 <- markOpeningParen an+    tys' <- markAnnotated tys+    an1 <- markClosingParen an0+    return (HsTupleTy an1 con tys')+  exact (HsSumTy an tys) = do+    an0 <- markOpeningParen an+    tys' <- markAnnotated tys+    an1 <- markClosingParen an0+    return (HsSumTy an1 tys')+  exact (HsOpTy x promoted t1 lo t2) = do+    t1' <- markAnnotated t1+    lo' <- markAnnotated lo+    t2' <- markAnnotated t2+    return (HsOpTy x promoted t1' lo' t2')+  exact (HsParTy (o,c) ty) = do+    o' <- markEpToken o+    ty' <- markAnnotated ty+    c' <- markEpToken c+    return (HsParTy (o',c') ty')+  exact (HsIParamTy an n t) = do+    n' <- markAnnotated n+    an0 <- markEpUniToken an+    t' <- markAnnotated t+    return (HsIParamTy an0 n' t')+  exact (HsStarTy an isUnicode) = do+    if isUnicode+        then printStringAdvance "\x2605" -- Unicode star+        else printStringAdvance "*"+    return (HsStarTy an isUnicode)+  exact (HsKindSig an ty k) = do+    ty' <- markAnnotated ty+    an0 <- markEpUniToken an+    k' <- markAnnotated k+    return (HsKindSig an0 ty' k')+  exact (HsSpliceTy a splice) = do+    splice' <- markAnnotated splice+    return (HsSpliceTy a splice')+  exact (HsDocTy an ty doc) = do+    ty' <- markAnnotated ty+    return (HsDocTy an ty' doc)+  exact (XHsType (HsBangTy ann (HsSrcBang mt up str) ty)) = do+    (ann', mt') <- exactBang (ann, mt) str+    ty' <- markAnnotated ty+    return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty'))+  exact (HsExplicitListTy (sq,o,c) prom tys) = do+    sq' <- if (isPromoted prom)+             then markEpToken sq+             else return sq+    o' <- markEpToken o+    tys' <- markAnnotated tys+    c' <- markEpToken c+    return (HsExplicitListTy (sq',o',c') prom tys')+  exact (HsExplicitTupleTy (sq, o, c) prom tys) = do+    sq' <- if (isPromoted prom)+              then markEpToken sq+              else return sq+    o' <- markEpToken o+    tys' <- markAnnotated tys+    c' <- markEpToken c+    return (HsExplicitTupleTy (sq', o', c') prom tys')+  exact (HsTyLit a lit) = do+    case lit of+      (HsNumTy src v) -> printSourceText src (show v)+      (HsStrTy src v) -> printSourceText src (show v)+      (HsCharTy src v) -> printSourceText src (show v)+    return (HsTyLit a lit)+  exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t+  exact x = error $ "missing match for HsType:" ++ showAst x++-- ---------------------------------------------------------------------++instance ExactPrint (HsForAllTelescope GhcPs) where+  getAnnotationEntry (HsForAllVis an _)   = fromAnn an+  getAnnotationEntry (HsForAllInvis an _) = fromAnn an++  setAnnotationAnchor (HsForAllVis an a) anc ts cs = HsForAllVis (setAnchorEpa an anc ts cs) a+  setAnnotationAnchor (HsForAllInvis an a) anc ts cs = HsForAllInvis (setAnchorEpa an anc ts cs) a++  exact (HsForAllVis (EpAnn l (f,r) cs) bndrs)   = do+    f' <- markEpUniToken f+    bndrs' <- markAnnotated bndrs+    r' <- markEpUniToken r+    return (HsForAllVis (EpAnn l (f',r') cs) bndrs')++  exact (HsForAllInvis (EpAnn l (f,d) cs) bndrs) = do+    f' <- markEpUniToken f+    bndrs' <- markAnnotated bndrs+    d' <- markEpToken d+    return (HsForAllInvis (EpAnn l (f',d') cs) bndrs')++-- ---------------------------------------------------------------------++instance ExactPrint (HsDerivingClause GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsDerivingClause { deriv_clause_ext      = an+                          , deriv_clause_strategy = dcs+                          , deriv_clause_tys      = dct }) = do+    an0 <- markEpToken an+    dcs0 <- case dcs of+            Just (L _ ViaStrategy{}) -> return dcs+            _ -> mapM markAnnotated dcs+    dct' <- markAnnotated dct+    dcs1 <- case dcs0 of+            Just (L _ ViaStrategy{}) -> mapM markAnnotated dcs0+            _ -> return dcs0+    return (HsDerivingClause { deriv_clause_ext      = an0+                             , deriv_clause_strategy = dcs1+                             , deriv_clause_tys      = dct' })++-- ---------------------------------------------------------------------++instance ExactPrint (DerivStrategy GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (StockStrategy an)    = do+    an0 <- markEpToken an+    return (StockStrategy an0)+  exact (AnyclassStrategy an) = do+    an0 <- markEpToken an+    return (AnyclassStrategy an0)+  exact (NewtypeStrategy an)  = do+    an0 <- markEpToken an+    return (NewtypeStrategy an0)+  exact (ViaStrategy (XViaStrategyPs an ty)) = do+    an0 <- markEpToken an+    ty' <- markAnnotated ty+    return (ViaStrategy (XViaStrategyPs an0 ty'))++-- ---------------------------------------------------------------------++instance (ExactPrint a) => ExactPrint (LocatedC a) where+  getAnnotationEntry (L sann _) = fromAnn sann+  setAnnotationAnchor = setAnchorAn++  exact (L (EpAnn anc (AnnContext ma opens closes) cs) a) = do+    opens' <- mapM markEpToken opens+    a' <- markAnnotated a+    closes' <- mapM markEpToken closes+    return (L (EpAnn anc (AnnContext ma opens' closes') cs) a')++-- ---------------------------------------------------------------------++instance ExactPrint (DerivClauseTys GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (DctSingle x ty) = do+    ty' <- markAnnotated ty+    return (DctSingle x ty')+  exact (DctMulti x tys) = do+    tys' <- markAnnotated tys+    return (DctMulti x tys')++-- ---------------------------------------------------------------------++instance ExactPrint (HsSigType GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsSig a bndrs ty) = do+    bndrs' <- markAnnotated bndrs+    ty' <- markAnnotated ty+    return (HsSig a bndrs' ty')++-- ---------------------------------------------------------------------++instance ExactPrint (LocatedN RdrName) where+  getAnnotationEntry (L sann _) = fromAnn sann+  setAnnotationAnchor = setAnchorAn++  exact (L (EpAnn anc ann cs) n) = do+    ann' <-+      case ann of+        NameAnn a l t -> do+          mn <- markName a (Just (l,n))+          case mn of+            (a', (Just (l',_n))) -> do+              return (NameAnn a' l' t)+            _ -> error "ExactPrint (LocatedN RdrName)"+        NameAnnCommas a commas t -> do+          a0 <- markNameAdornmentO a+          commas' <- forM commas markEpToken+          a1 <- markNameAdornmentC a0+          return (NameAnnCommas a1 commas' t)+        NameAnnBars (o,c) bars t -> do+          o' <- markEpToken o+          bars' <- mapM markEpToken bars+          c' <- markEpToken c+          return (NameAnnBars (o',c') bars' t)+        NameAnnOnly a t -> do+          (a',_) <- markName a Nothing+          return (NameAnnOnly a' t)+        NameAnnRArrow o nl c t -> do+          o' <- mapM markEpToken o+          nl' <- markEpUniToken nl+          c' <- mapM markEpToken c+          return (NameAnnRArrow o' nl' c' t)+        NameAnnQuote q name t -> do+          debugM $ "NameAnnQuote"+          q' <- markEpToken q+          (L name' _) <- markAnnotated (L name n)+          return (NameAnnQuote q' name' t)+        NameAnnTrailing t -> do+          _anc' <- printUnicode anc n+          return (NameAnnTrailing t)+    return (L (EpAnn anc ann' cs) n)+++markNameAdornmentO :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment+markNameAdornmentO (NameParens o c) = do+  o' <- markEpToken o+  return (NameParens o' c)+markNameAdornmentO (NameParensHash o c) = do+  o' <- markEpToken o+  return (NameParensHash o' c)+markNameAdornmentO (NameBackquotes o c) = do+  o' <- markEpToken o+  return (NameBackquotes o' c)+markNameAdornmentO (NameSquare o c) = do+  o' <- markEpToken o+  return (NameSquare o' c)+markNameAdornmentO NameNoAdornment      = return NameNoAdornment++markNameAdornmentC :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment+markNameAdornmentC (NameParens o c) = do+  c' <- markEpToken c+  return (NameParens o c')+markNameAdornmentC (NameParensHash o c) = do+  c' <- markEpToken c+  return (NameParensHash o c')+markNameAdornmentC (NameBackquotes o c) = do+  c' <- markEpToken c+  return (NameBackquotes o c')+markNameAdornmentC (NameSquare o c) = do+  c' <- markEpToken c+  return (NameSquare o c')+markNameAdornmentC NameNoAdornment      = return NameNoAdornment++printUnicode :: (Monad m, Monoid w) => EpaLocation -> RdrName -> EP w m EpaLocation+printUnicode anc n = do+  let str = case (showPprUnsafe n) of+            -- TODO: unicode support?+              "forall" -> if spanLength (epaLocationRealSrcSpan anc) == 1 then "∀" else "forall"+              s -> s+  loc <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str+  case loc of+    EpaSpan _ -> return anc+    EpaDelta ss dp [] -> return $ EpaDelta ss dp []+    EpaDelta _ _ _cs  -> error "printUnicode should not capture comments"+++markName :: (Monad m, Monoid w)+  => NameAdornment -> Maybe (EpaLocation,RdrName)+  -> EP w m (NameAdornment, Maybe (EpaLocation,RdrName))+markName adorn mname = do+  adorn0 <- markNameAdornmentO adorn+  mname' <-+    case mname of+      Nothing -> return Nothing+      Just (name, a) -> do+        name' <- printStringAtAAC CaptureComments name (showPprUnsafe a)+        return (Just (name',a))+  adorn1 <- markNameAdornmentC adorn0+  return (adorn1, mname')++markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn]+markTrailing ts = do+  p <- getPosP+  debugM $ "markTrailing:" ++ showPprUnsafe (p,ts)+  mapM markKwT ts++-- ---------------------------------------------------------------------++-- based on pp_condecls in Decls.hs+exact_condecls :: (Monad m, Monoid w)+  => EpToken "=" -> [LConDecl GhcPs] -> EP w m (EpToken "=",[LConDecl GhcPs])+exact_condecls eq cs+  | gadt_syntax                  -- In GADT syntax+  = do+      cs' <- mapM markAnnotated cs+      return (eq, cs')+  | otherwise                    -- In H98 syntax+  = do+      eq0 <- markEpToken eq+      cs' <- mapM markAnnotated cs+      return (eq0, cs')+  where+    gadt_syntax = case cs of+      []                      -> False+      (L _ ConDeclH98{}  : _) -> False+      (L _ ConDeclGADT{} : _) -> True++-- ---------------------------------------------------------------------++instance ExactPrint (ConDecl GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++-- based on pprConDecl+  exact (ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow+                    , con_name = con+                    , con_forall = has_forall+                    , con_ex_tvs = ex_tvs+                    , con_mb_cxt = mcxt+                    , con_args = args+                    , con_doc = doc }) = do+    tforall' <- if has_forall+      then markEpUniToken tforall+      else return tforall+    ex_tvs' <- mapM markAnnotated ex_tvs+    tdot' <- if has_forall+      then markEpToken tdot+      else return tdot+    mcxt' <- mapM markAnnotated mcxt+    tdarrow' <- if (isJust mcxt)+      then markEpUniToken tdarrow+      else return tdarrow++    (con', args') <- exact_details args+    return (ConDeclH98 { con_ext = AnnConDeclH98 tforall' tdot' tdarrow'+                       , con_name = con'+                       , con_forall = has_forall+                       , con_ex_tvs = ex_tvs'+                       , con_mb_cxt = mcxt'+                       , con_args = args'+                       , con_doc = doc })++    where+    -- In ppr_details: let's not print the multiplicities (they are always 1, by+    -- definition) as they do not appear in an actual declaration.+      exact_details (InfixCon t1 t2) = do+        t1' <- markAnnotated t1+        con' <- markAnnotated con+        t2' <- markAnnotated t2+        return (con', InfixCon t1' t2')+      exact_details (PrefixCon tys) = do+        con' <- markAnnotated con+        tys' <- markAnnotated tys+        return (con', PrefixCon tys')+      exact_details (RecCon fields) = do+        con' <- markAnnotated con+        fields' <- markAnnotated fields+        return (con', RecCon fields')++  -- -----------------------------------++  exact (ConDeclGADT { con_g_ext = AnnConDeclGADT ops cps dcol+                     , con_names = cons+                     , con_outer_bndrs = outer_bndrs+                     , con_inner_bndrs = inner_bndrs+                     , con_mb_cxt = mcxt, con_g_args = args+                     , con_res_ty = res_ty, con_doc = doc }) = do+    cons' <- mapM markAnnotated cons+    dcol' <- markEpUniToken dcol+    epTokensToComments "(" ops+    epTokensToComments ")" cps++    -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558+    outer_bndrs' <- case outer_bndrs of+      L _ (HsOuterImplicit _) -> return outer_bndrs+      _ -> markAnnotated outer_bndrs++    inner_bndrs' <- mapM markAnnotated inner_bndrs++    mcxt' <- mapM markAnnotated mcxt+    args' <-+      case args of+          (PrefixConGADT x args0) -> do+            args0' <- mapM markAnnotated args0+            return (PrefixConGADT x args0')+          (RecConGADT rarr fields) -> do+            fields' <- markAnnotated fields+            rarr' <- markEpUniToken rarr+            return (RecConGADT rarr' fields')+    res_ty' <- markAnnotated res_ty+    return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol'+                        , con_names = cons'+                        , con_outer_bndrs = outer_bndrs'+                        , con_inner_bndrs = inner_bndrs'+                        , con_mb_cxt = mcxt', con_g_args = args'+                        , con_res_ty = res_ty', con_doc = doc })++-- ---------------------------------------------------------------------++instance ExactPrint Void where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact x = return x++-- ---------------------------------------------------------------------++instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where+  getAnnotationEntry (HsOuterImplicit _) = NoEntryVal+  getAnnotationEntry (HsOuterExplicit an _) = fromAnn an++  setAnnotationAnchor (HsOuterImplicit a) _ _ _ = HsOuterImplicit a+  setAnnotationAnchor (HsOuterExplicit an a) anc ts cs = HsOuterExplicit (setAnchorEpa an anc ts cs) a++  exact b@(HsOuterImplicit _) = pure b+  exact (HsOuterExplicit (EpAnn l (f,d) cs) bndrs) = do+    f' <- markEpUniToken f+    bndrs' <- markAnnotated bndrs+    d' <- markEpToken d+    return (HsOuterExplicit (EpAnn l (f',d') cs) bndrs')++-- ---------------------------------------------------------------------++instance ExactPrint (HsConDeclRecField GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsConDeclRecField _ names ftype) = do+    names' <- markAnnotated names+    ftype' <- markAnnotated ftype+    return (HsConDeclRecField noExtField names' ftype')++-- ---------------------------------------------------------------------++instance ExactPrint (FieldOcc GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact (FieldOcc x n) = do+      n' <- markAnnotated n+      return (FieldOcc x n')++-- ---------------------------------------------------------------------++instance ExactPrint (HsConDeclField GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a+  exact cdf@(CDF { cdf_ext, cdf_bang, cdf_multiplicity, cdf_type }) = do+    (mult, (an, t)) <- markMultAnnOf cdf_multiplicity ((,) <$> exactBang cdf_ext cdf_bang <*> markAnnotated cdf_type)+    return (cdf { cdf_ext = an, cdf_multiplicity = mult, cdf_type = t })++markMultAnnOf :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOf a GhcPs -> EP w m b -> EP w m (HsMultAnnOf a GhcPs, b)+markMultAnnOf (HsUnannotated arrOrCol) tyM = do+  ((), arrOrCol', ty') <- markArrOrCol (pure ()) arrOrCol tyM+  return (HsUnannotated arrOrCol', ty')+markMultAnnOf (HsLinearAnn (EpPct1 pct1 arrOrCol)) tyM = do+  (pct1', arrOrCol', ty') <- markArrOrCol (markEpToken pct1) arrOrCol tyM+  return (HsLinearAnn (EpPct1 pct1' arrOrCol'), ty')+markMultAnnOf (HsLinearAnn (EpLolly arr)) tyM = do+  ty' <- tyM+  arr' <- markEpToken arr+  return (HsLinearAnn (EpLolly arr'), ty')+markMultAnnOf (HsExplicitMult (pct, arrOrCol) t) tyM = do+  ((pct', t'), arrOrCol', ty') <- markArrOrCol ((,) <$> markEpToken pct <*> markAnnotated t) arrOrCol tyM+  return (HsExplicitMult (pct', arrOrCol') t', ty')++markArrOrCol :: (Monad m, Monoid w) => EP w m a -> EpArrowOrColon -> EP w m b -> EP w m (a, EpArrowOrColon, b)+markArrOrCol multM (EpArrow arr) tyM = do+  ty' <- tyM+  mult' <- multM+  arr' <- markEpUniToken arr+  return (mult', EpArrow arr', ty')+markArrOrCol multM (EpColon col) tyM = do+  mult' <- multM+  col' <- markEpUniToken col+  ty' <- tyM+  return (mult', EpColon col', ty')+markArrOrCol multM EpPatBind patM = do+  mult' <- multM+  pat' <- patM+  return (mult', EpPatBind, pat')++exactBang :: (Monoid w, Monad m) => XConDeclField GhcPs -> SrcStrictness -> EP w m (XConDeclField GhcPs)+exactBang ((o,c,tk), mt) str = do+  (o',c') <-+    case mt of+      NoSourceText -> return (o,c)+      SourceText src -> do+        debugM $ "HsBangTy: src=" ++ showAst src+        o' <- printStringAtAA o (unpackFS src)+        c' <- markEpToken c+        return (o',c')+  tk' <-+    case str of+      SrcLazy     -> printStringAtAA tk "~"+      SrcStrict   -> printStringAtAA tk "!"+      NoSrcStrict -> return tk+  return ((o',c',tk'), mt)++-- ---------------------------------------------------------------------++instance ExactPrint (LocatedP CType) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn++  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType stp mh (stct,ct))) = do+    o' <- markAnnOpen'' o stp "{-# CTYPE"+    l1' <- case mh of+             Nothing -> return l1+             Just (Header srcH _h) ->+               printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")+    l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "")+    c' <- markEpToken c+    return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType stp mh (stct,ct)))++-- ---------------------------------------------------------------------++instance ExactPrint (SourceText, RuleName) where+  -- We end up at the right place from the Located wrapper+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (st, rn)+    = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "")+      >> return (st, rn)+++-- =====================================================================+-- LocatedL instances start --+--+-- Each is dealt with specifically, as they have+-- different wrapping annotations in the al_rest zone.+--+-- In future, the annotation could perhaps be improved, with an+-- 'al_pre' and 'al_post' set of annotations to be simply sorted and+-- applied.+-- ---------------------------------------------------------------------++instance ExactPrint (LocatedLI [LocatedA (IE GhcPs)]) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn++  exact (L an ies) = do+    debugM $ "LocatedL [LIE"+    an0 <- markLensFun' an (lal_rest . lfst) markEpToken+    p <- getPosP+    debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p+    (an1, ies') <- markAnnList an0 (markAnnotated (filter notIEDoc ies))+    return (L an1 ies')++instance (ExactPrint (Match GhcPs (LocatedA body)))+   => ExactPrint (LocatedLW [LocatedA (Match GhcPs (LocatedA body))]) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn+  exact (L an a) = do+    debugM $ "LocatedL [LMatch"+    -- TODO: markAnnList?+    an0 <- markLensFun' an lal_rest markEpToken+    an1 <- markLensBracketsO an0 lal_brackets+    an2 <- markEpAnnAllLT an1 lal_semis+    a' <- markAnnotated a+    an3 <- markLensBracketsC an2 lal_brackets+    return (L an3 a')++instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn+  exact (L an stmts) = do+    debugM $ "LocatedL [ExprLStmt"+    (an'', stmts') <- markAnnList an $ do+      case snocView stmts of+        Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do+          debugM $ "LocatedL [ExprLStmt: snocView"+          ls' <- markAnnotated ls+          initStmts' <- markAnnotated initStmts+          return (initStmts' ++ [ls'])+        _ -> do+          markAnnotated stmts+    return (L an'' stmts')++instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn+  exact (L ann es) = do+    debugM $ "LocatedL [CmdLStmt"+    an0 <- markLensBracketsO ann lal_brackets+    es' <- mapM markAnnotated es+    an1 <- markLensBracketsC an0 lal_brackets+    return (L an1 es')++instance ExactPrint (LocatedL [LocatedA (HsConDeclRecField GhcPs)]) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn+  exact (L an fs) = do+    debugM $ "LocatedL [LHsConDeclRecField"+    (an', fs') <- markAnnList an (markAnnotated fs)+    return (L an' fs')++instance ExactPrint (LocatedL (BF.BooleanFormula GhcPs)) where+  getAnnotationEntry = entryFromLocatedA+  setAnnotationAnchor = setAnchorAn+  exact (L an bf) = do+    debugM $ "LocatedL [LBooleanFormula"+    (an', bf') <- markAnnList an (markAnnotated bf)+    return (L an' bf')++-- ---------------------------------------------------------------------+-- LocatedL instances end --+-- =====================================================================++instance ExactPrint (IE GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (IEVar depr ln doc) = do+    depr' <- markAnnotated depr+    ln' <- markAnnotated ln+    doc' <- markAnnotated doc+    return (IEVar depr' ln' doc')+  exact (IEThingAbs depr thing doc) = do+    depr' <- markAnnotated depr+    thing' <- markAnnotated thing+    doc' <- markAnnotated doc+    return (IEThingAbs depr' thing' doc')+  exact (IEThingAll (depr, (op,dd,cp)) thing doc) = do+    depr' <- markAnnotated depr+    thing' <- markAnnotated thing+    op' <- markEpToken op+    dd' <- markEpToken dd+    cp' <- markEpToken cp+    doc' <- markAnnotated doc+    return (IEThingAll (depr', (op',dd',cp')) thing' doc')++  exact (IEThingWith (depr, (op,dd,c,cp)) thing wc withs doc) = do+    depr' <- markAnnotated depr+    thing' <- markAnnotated thing+    op' <- markEpToken op+    (dd',c', wc', withs') <-+      case wc of+        NoIEWildcard -> do+          withs'' <- markAnnotated withs+          return (dd, c, wc, withs'')+        IEWildcard pos -> do+          let (bs, as) = splitAt pos withs+          bs' <- markAnnotated bs+          dd' <- markEpToken dd+          c' <- markEpToken c+          as' <- markAnnotated as+          return (dd',c', wc, bs'++as')+    cp' <- markEpToken cp+    doc' <- markAnnotated doc+    return (IEThingWith (depr', (op',dd',c',cp')) thing' wc' withs' doc')++  exact (IEModuleContents (depr, an) m) = do+    depr' <- markAnnotated depr+    an0 <- markEpToken an+    m' <- markAnnotated m+    return (IEModuleContents (depr', an0) m')++  -- These three exist to not error out, but are no-ops The contents+  -- appear as "normal" comments too, which we process instead.+  exact (IEGroup x lev doc) = do+    return (IEGroup x lev doc)+  exact (IEDoc x doc) = do+    return (IEDoc x doc)+  exact (IEDocNamed x str) = do+    return (IEDocNamed x str)++-- ---------------------------------------------------------------------++instance ExactPrint (IEWrappedName GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (IEName x n) = do+    n' <- markAnnotated n+    return (IEName x n')+  exact (IEDefault r n) = do+    r' <- markEpToken r+    n' <- markAnnotated n+    return (IEDefault r' n')+  exact (IEPattern r n) = do+    r' <- markEpToken r+    n' <- markAnnotated n+    return (IEPattern r' n')+  exact (IEType r n) = do+    r' <- markEpToken r+    n' <- markAnnotated n+    return (IEType r' n')+  exact (IEData r n) = do+    r' <- markEpToken r+    n' <- markAnnotated n+    return (IEData r' n')++-- ---------------------------------------------------------------------++instance ExactPrint (Pat GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (WildPat w) = do+    anchor' <- getAnchorU+    debugM $ "WildPat:anchor'=" ++ show anchor'+    _ <- printStringAtRs anchor' "_"+    return (WildPat w)+  exact (VarPat x n) = do+    -- The parser inserts a placeholder value for a record pun rhs. This must be+    -- filtered.+    let pun_RDR = "pun-right-hand-side"+    n' <- if (showPprUnsafe n /= pun_RDR)+      then markAnnotated n+      else return n+    return (VarPat x n')+  exact (LazyPat an pat) = do+    an0 <- markEpToken an+    pat' <- markAnnotated pat+    return (LazyPat an0 pat')+  exact (AsPat at n pat) = do+    n' <- markAnnotated n+    at' <- markEpToken at+    pat' <- markAnnotated pat+    return (AsPat at' n' pat')+  exact (ParPat (lpar, rpar) pat) = do+    lpar' <- markEpToken lpar+    pat' <- markAnnotated pat+    rpar' <- markEpToken rpar+    return (ParPat (lpar', rpar') pat')++  exact (BangPat an pat) = do+    an0 <- markEpToken an+    pat' <- markAnnotated pat+    return (BangPat an0 pat')++  exact (ListPat an pats) = do+    (an', pats') <- markAnnList' an (markAnnotated pats)+    return (ListPat an' pats')++  exact (TuplePat (o,c) pats boxity) = do+    o0 <- case boxity of+             Boxed   -> printStringAtAA o "("+             Unboxed -> printStringAtAA o "(#"+    pats' <- markAnnotated pats+    c0 <- case boxity of+             Boxed   -> printStringAtAA c ")"+             Unboxed -> printStringAtAA c "#)"+    return (TuplePat (o0,c0) pats' boxity)++  exact (SumPat an pat alt arity) = do+    an0 <- markLensFun an (lsumPatParens . lfst) (\loc -> printStringAtAA loc "(#")+    an1 <- markLensFun an0 lsumPatVbarsBefore (\locs -> mapM markEpToken locs)+    pat' <- markAnnotated pat+    an2 <- markLensFun an1 lsumPatVbarsAfter (\locs -> mapM markEpToken locs)+    an3 <- markLensFun an2 (lsumPatParens . lsnd)  (\loc -> printStringAtAA loc "#)")+    return (SumPat an3 pat' alt arity)++  exact (OrPat an pats) = do+    pats' <- markAnnotated (NE.toList pats)+    return (OrPat an (NE.fromList pats'))++  exact (ConPat an con details) = do+    (an', con', details') <- exactUserCon an con details+    return (ConPat an' con' details')+  exact (ViewPat tokarr expr pat) = do+    expr' <- markAnnotated expr+    an0 <- markEpUniToken tokarr+    pat' <- markAnnotated pat+    return (ViewPat an0 expr' pat')+  exact (SplicePat x splice) = do+    splice' <- markAnnotated splice+    return (SplicePat x splice')+  exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p+  exact (NPat an ol mn z) = do+    an0 <- if (isJust mn)+      then markEpToken an+      else return an+    ol' <- markAnnotated ol+    return (NPat an0 ol' mn z)++  exact (NPlusKPat an n k lit2 a b) = do+    n' <- markAnnotated n+    an' <- markEpToken an+    k' <- markAnnotated k+    return (NPlusKPat an' n' k' lit2 a b)++  exact (SigPat an pat sig) = do+    pat' <- markAnnotated pat+    an0 <- markEpUniToken an+    sig' <- markAnnotated sig+    return (SigPat an0 pat' sig')++  exact (EmbTyPat toktype tp) = do+    toktype' <- markEpToken toktype+    tp' <- markAnnotated tp+    return (EmbTyPat toktype' tp')++  exact (InvisPat (tokat, spec) tp) = do+    tokat' <- markEpToken tokat+    tp' <- markAnnotated tp+    pure (InvisPat (tokat', spec) tp')++-- ---------------------------------------------------------------------++instance ExactPrint (HsPatSigType GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsPS an ty) = do+    ty' <- markAnnotated ty+    return (HsPS an ty')++instance ExactPrint (HsTyPat GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact (HsTP an ty) = do+    ty' <- markAnnotated ty+    return (HsTP an ty')++-- ---------------------------------------------------------------------++instance ExactPrint (HsOverLit GhcPs) where+  getAnnotationEntry = const NoEntryVal+  setAnnotationAnchor a _ _ _ = a++  exact ol =+    let str = case ol_val ol of+                HsIntegral   (IL src _ _) -> src+                HsFractional (FL{ fl_text = src }) -> src+                HsIsString src _ -> src+    in+      case str of+        SourceText s -> printStringAdvance (unpackFS s) >> return ol+        NoSourceText -> return ol++-- ---------------------------------------------------------------------++hsLit2String :: HsLit GhcPs -> String+hsLit2String lit =+  case lit of+    HsChar       src v   -> toSourceTextWithSuffix src v ""+    HsCharPrim   src p   -> toSourceTextWithSuffix src p ""+    HsString     src v   -> toSourceTextWithSuffix src v ""+    HsMultilineString src v -> toSourceTextWithSuffix src v ""+    HsStringPrim src v   -> toSourceTextWithSuffix src v ""+    HsInt        _ (IL src _ v)   -> toSourceTextWithSuffix src v ""+    HsIntPrim    src v   -> toSourceTextWithSuffix src v ""+    HsWordPrim   src v   -> toSourceTextWithSuffix src v ""+    HsInt8Prim   src v   -> toSourceTextWithSuffix src v ""+    HsInt16Prim  src v   -> toSourceTextWithSuffix src v ""+    HsInt32Prim  src v   -> toSourceTextWithSuffix src v ""+    HsInt64Prim  src v   -> toSourceTextWithSuffix src v ""+    HsWord8Prim  src v   -> toSourceTextWithSuffix src v ""+    HsWord16Prim src v   -> toSourceTextWithSuffix src v ""+    HsWord32Prim src v   -> toSourceTextWithSuffix src v ""+    HsWord64Prim src v   -> toSourceTextWithSuffix src v ""+    HsFloatPrim  _ fl@(FL{fl_text = src })   -> toSourceTextWithSuffix src fl "#"+    HsDoublePrim _ fl@(FL{fl_text = src })   -> toSourceTextWithSuffix src fl "##"++toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String+toSourceTextWithSuffix (NoSourceText)    alt suffix = show alt ++ suffix+toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix++sourceTextToString :: SourceText -> String -> String+sourceTextToString NoSourceText alt   = alt+sourceTextToString (SourceText txt) _ = unpackFS txt++-- ---------------------------------------------------------------------++exactUserCon :: (Monad m, Monoid w, ExactPrint con)+  => (Maybe (EpToken "{"), Maybe (EpToken "}")) -> con -> HsConPatDetails GhcPs+  -> EP w m ((Maybe (EpToken "{"), Maybe (EpToken "}")), con, HsConPatDetails GhcPs)+exactUserCon an c (InfixCon p1 p2) = do+  p1' <- markAnnotated p1+  c' <- markAnnotated c+  p2' <- markAnnotated p2+  return (an, c', InfixCon p1' p2')+exactUserCon (open,close) c details = do+  c' <- markAnnotated c+  open' <- mapM markEpToken open+  details' <- exactConArgs details+  close' <- mapM markEpToken close+  return ((open', close'), c', details')++exactConArgs :: (Monad m, Monoid w)+  => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs)+exactConArgs (PrefixCon pats) = do+  pats' <- markAnnotated pats+  return (PrefixCon pats')+exactConArgs (InfixCon p1 p2) = do+  p1' <- markAnnotated p1+  p2' <- markAnnotated p2+  return (InfixCon p1' p2')+exactConArgs (RecCon rpats) = do+  rpats' <- markAnnotated rpats+  return (RecCon rpats')++-- ---------------------------------------------------------------------++entryFromLocatedA :: (HasTrailing ann) => LocatedAn ann a -> Entry+entryFromLocatedA (L la _) = fromAnn la++-- =====================================================================+-- Utility stuff+-- ---------------------------------------------------------------------++-- |This should be the final point where things are mode concrete,+-- before output.+-- NOTE: despite the name, this is the ghc-exactprint final output for+-- the PRINT phase.+printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m ()+printStringAtLsDelta cl s = do+  p <- getPosP+  colOffset <- getLayoutOffsetP+  if isGoodDeltaWithOffset cl colOffset+    then do+      printStringAt (undelta p cl colOffset) s+      p' <- getPosP+      d <- getPriorEndD+      debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',d,s)+    else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s))++-- ---------------------------------------------------------------------++isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool+isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c)+  where (l,c) = undelta (0,0) dp colOffset++-- | Print a comment, using the current layout offset to convert the+-- @DeltaPos@ to an absolute position.+printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()+printQueuedComment Comment{commentContents} dp = do+  p <- getPosP+  d <- getPriorEndD+  colOffset <- getLayoutOffsetP+  let (dr,dc) = undelta (0,0) dp colOffset+  -- do not lose comments against the left margin+  when (isGoodDelta (deltaPos dr (max 0 dc))) $ do+    printCommentAt (undelta p dp colOffset) commentContents+  p' <- getPosP+  d' <- getPriorEndD+  debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d')+  debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset)++------------------------------------------------------------------------++setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a+setLayoutBoth k = do+  oldLHS <- getLayoutOffsetD+  oldAnchorOffset <- getLayoutOffsetP+  debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)+  modify (\a -> a { dMarkLayout = True+                  , pMarkLayout = True } )+  let reset = do+        debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)+        modify (\a -> a { dMarkLayout = False+                        , dLHS = oldLHS+                        , pMarkLayout = False+                        , pLHS = oldAnchorOffset} )+  k <* reset++------------------------------------------------------------------------++getPosP :: (Monad m, Monoid w) => EP w m Pos+getPosP = gets epPos++setPosP :: (Monad m, Monoid w) => Pos -> EP w m ()+setPosP l = do+  debugM $ "setPosP:" ++ show l+  modify (\s -> s {epPos = l})++getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe EpaLocation)+getExtraDP = gets uExtraDP++setExtraDP :: (Monad m, Monoid w) => Maybe EpaLocation -> EP w m ()+setExtraDP md = do+  debugM $ "setExtraDP:" ++ show md+  modify (\s -> s {uExtraDP = md})++getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe (SrcSpan, DeltaPos))+getExtraDPReturn = gets uExtraDPReturn++setExtraDPReturn :: (Monad m, Monoid w) => Maybe (SrcSpan, DeltaPos) -> EP w m ()+setExtraDPReturn md = do+  debugM $ "setExtraDPReturn:" ++ show md+  modify (\s -> s {uExtraDPReturn = md})++getPriorEndD :: (Monad m, Monoid w) => EP w m Pos+getPriorEndD = gets dPriorEndPosition++getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan+getAnchorU = gets uAnchorSpan++getAcceptSpan ::(Monad m, Monoid w) => EP w m Bool+getAcceptSpan = gets pAcceptSpan++setAcceptSpan ::(Monad m, Monoid w) => Bool -> EP w m ()+setAcceptSpan f =+  modify (\s -> s { pAcceptSpan = f })++setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m ()+setPriorEndD pe = do+  setPriorEndNoLayoutD pe++setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m ()+setPriorEndNoLayoutD pe = do+  debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe+  modify (\s -> s { dPriorEndPosition = pe })++setPriorEndASTD :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+setPriorEndASTD pe = setPriorEndASTPD (rs2range pe)++setPriorEndASTPD :: (Monad m, Monoid w) => (Pos,Pos) -> EP w m ()+setPriorEndASTPD pe@(fm,to) = do+  debugM $ "setPriorEndASTD:pe=" ++ show pe+  setLayoutStartD (snd fm)+  modify (\s -> s { dPriorEndPosition = to } )++setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m ()+setLayoutStartD p = do+  EPState{dMarkLayout} <- get+  when dMarkLayout $ do+    debugM $ "setLayoutStartD: setting dLHS=" ++ show p+    modify (\s -> s { dMarkLayout = False+                    , dLHS = LayoutStartCol p})++getLayoutOffsetD :: (Monad m, Monoid w) => EP w m LayoutStartCol+getLayoutOffsetD = gets dLHS++setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+setAnchorU rss = do+  debugM $ "setAnchorU:" ++ show (rs2range rss)+  modify (\s -> s { uAnchorSpan = rss })++getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan))+getEofPos = gets epEof++setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m ()+setEofPos l = modify (\s -> s {epEof = l})++-- ---------------------------------------------------------------------++getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment]+getUnallocatedComments = gets epComments++putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m ()+putUnallocatedComments !cs = modify (\s -> s { epComments = cs } )++-- | Push a fresh stack frame for the applied comments gatherer+pushAppliedComments  :: (Monad m, Monoid w) => EP w m ()+pushAppliedComments = modify (\s -> s { epCommentsApplied = []:(epCommentsApplied s) })++-- | Return the comments applied since the last call+-- takeAppliedComments, and clear them, not popping the stack+takeAppliedComments :: (Monad m, Monoid w) => EP w m [Comment]+takeAppliedComments = do+  !ccs <- gets epCommentsApplied+  case ccs of+    [] -> do+      modify (\s -> s { epCommentsApplied = [] })+      return []+    h:t -> do+      modify (\s -> s { epCommentsApplied = []:t })+      return (reverse h)++-- | Return the comments applied since the last call+-- takeAppliedComments, and clear them, popping the stack+takeAppliedCommentsPop :: (Monad m, Monoid w) => EP w m [Comment]+takeAppliedCommentsPop = do+  !ccs <- gets epCommentsApplied+  case ccs of+    [] -> do+      modify (\s -> s { epCommentsApplied = [] })+      return []+    h:t -> do+      modify (\s -> s { epCommentsApplied = t })+      return (reverse h)++-- | Mark a comment as being applied.  This is used to update comments+-- when doing delta processing+applyComment :: (Monad m, Monoid w) => Comment -> EP w m ()+applyComment c = do+  !ccs <- gets epCommentsApplied+  case ccs of+    []    -> modify (\s -> s { epCommentsApplied = [[c]] } )+    (h:t) -> modify (\s -> s { epCommentsApplied = (c:h):t } )++getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol+getLayoutOffsetP = gets pLHS++setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m ()+setLayoutOffsetP c = do+  debugM $ "setLayoutOffsetP:" ++ show c+  modify (\s -> s { pLHS = c })+++-- ---------------------------------------------------------------------++advance :: (Monad m, Monoid w) => DeltaPos -> EP w m ()+advance dp = do+  p <- getPosP+  colOffset <- getLayoutOffsetP+  debugM $ "advance:(p,dp,colOffset,ws)=" ++ show (p,dp,colOffset,undelta p dp colOffset)+  if isGoodDelta dp+    then do+      printWhitespace (undelta p dp colOffset)+      -- Sync point. We only call advance as we start the sub-span+      -- processing, so force the dPriorEndPosition to ???+      p0 <- getPosP+      d <- getPriorEndD+      r <- getAnchorU+      setPriorEndD (fst $ rs2range r)+      debugM $ "advance:after: (posp, posd, posd')=" ++ show (p0,d,fst $ rs2range r)+    else+      return ()++-- ---------------------------------------------------------------------++adjustDeltaForOffsetM :: (Monad m, Monoid w) => DeltaPos -> EP w m DeltaPos+adjustDeltaForOffsetM dp = do+  colOffset <- getLayoutOffsetD+  return (adjustDeltaForOffset colOffset dp)++-- ---------------------------------------------------------------------+-- Printing functions++printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()+printString layout str = do+  EPState{epPos = (_,c), pMarkLayout} <- get+  EPOptions{epTokenPrint, epWhitespacePrint} <- ask+  when (pMarkLayout && layout) $ do+    debugM $ "printString: setting pLHS to " ++ show c+    modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } )++  -- Advance position, taking care of any newlines in the string+  let strDP = dpFromString str+      cr = getDeltaLine strDP+  p <- getPosP+  d <- getPriorEndD+  colOffsetP <- getLayoutOffsetP+  colOffsetD <- getLayoutOffsetD+  -- debugM $ "printString:(p,colOffset,strDP,cr)="  ++ show (p,colOffset,strDP,cr)+  if cr == 0+    then do+      setPosP      (undelta p strDP colOffsetP)+      setPriorEndD (undelta d strDP colOffsetD)+    else do+      setPosP      (undelta p strDP 1)+      setPriorEndD (undelta d strDP 1)++  -- Debug stuff+  -- pp <- getPosP+  -- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str)+  -- Debug end++  --+  if not layout && c == 0+    then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s}+    else lift (epTokenPrint      str) >>= \s -> tell EPWriter { output = s}++--------------------------------------------------------++printStringAdvance :: (Monad m, Monoid w) => String -> EP w m ()+printStringAdvance str = do+  ss <- getAnchorU+  _ <- printStringAtRs ss str+  return ()++--------------------------------------------------------++newLine :: (Monad m, Monoid w) => EP w m ()+newLine = do+    (l,_) <- getPosP+    (ld,_) <- getPriorEndD+    printString False "\n"+    setPosP (l+1,1)+    setPriorEndNoLayoutD (ld+1,1)++padUntil :: (Monad m, Monoid w) => Pos -> EP w m ()+padUntil (l,c) = do+    (l1,c1) <- getPosP+    if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' '+       | l1 < l             -> newLine >> padUntil (l,c)+       | otherwise          -> return ()++printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m ()+printWhitespace = padUntil++printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()+printCommentAt p str = do+  debugM $ "printCommentAt: (pos,str)" ++ show (p,str)+  printWhitespace p >> printString False str++printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()+printStringAt p str = printWhitespace p >> printString True str
− src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}--- functions from GHC copied here until they can be exported in the next version.--module Language.Haskell.GHC.ExactPrint.GhcInterim where--import ApiAnnotation-import Lexer-import SrcLoc---- ----------------------------------------------------------------------#if __GLASGOW_HASKELL__ > 800-#else--- From Lexer.x-commentToAnnotation :: Located Token -> Located AnnotationComment-commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)-commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)-commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)-commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)-commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)-#if __GLASGOW_HASKELL__ < 801-commentToAnnotation (L l (ITdocOptionsOld s))   = L l (AnnDocOptionsOld s)-#endif-commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)-commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)-commentToAnnotation _ = error $ "commentToAnnotation called for non-comment:" -- ++ show x-#endif
− src/Language/Haskell/GHC/ExactPrint/Lookup.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE CPP #-}-module Language.Haskell.GHC.ExactPrint.Lookup-  (-    keywordToString-#if __GLASGOW_HASKELL__ <= 710-  , unicodeString-#endif-  ) where--import Language.Haskell.GHC.ExactPrint.Types-import qualified GHC (AnnKeywordId(..))-#if __GLASGOW_HASKELL__ <= 710-import Data.Maybe-#endif---- | Maps `AnnKeywordId` to the corresponding String representation.--- There is no specific mapping for the following constructors.--- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`,--- `AnnInfix`-keywordToString :: KeywordId -> String-keywordToString kw =-  let mkErr x = error $ "keywordToString: missing case for:" ++ show x-  in-  case kw of-      -- Specifically handle all cases so that there are pattern match-      -- warnings if new constructors are added.-      AnnComment _      -> mkErr kw-      AnnString _       -> mkErr kw-#if __GLASGOW_HASKELL__ <= 710-      AnnUnicode kw'    -> keywordToString (G kw')-#endif-      AnnSemiSep        -> ";"-#if __GLASGOW_HASKELL__ >= 801-      (G GHC.AnnAnyclass) -> "anyclass"-#endif-      (G GHC.AnnOpen  ) -> mkErr kw-      (G GHC.AnnClose ) -> mkErr kw-      (G GHC.AnnVal   ) -> mkErr kw-      (G GHC.AnnPackageName) -> mkErr kw-      (G GHC.AnnHeader ) -> mkErr kw-      (G GHC.AnnFunId  ) -> mkErr kw-      (G GHC.AnnInfix  ) -> mkErr kw-      (G GHC.AnnValStr ) -> mkErr kw-      (G GHC.AnnName   ) -> mkErr kw-      (G GHC.AnnAs     ) -> "as"-      (G GHC.AnnAt     ) -> "@"-      (G GHC.AnnBang   ) -> "!"-      (G GHC.AnnBackquote ) -> "`"-      (G GHC.AnnBy     ) -> "by"-      (G GHC.AnnCase   ) -> "case"-      (G GHC.AnnClass   ) -> "class"-#if __GLASGOW_HASKELL__ >= 801-      (G GHC.AnnCloseB  ) -> "|)"-      (G GHC.AnnCloseBU ) -> "⦈"-#endif-      (G GHC.AnnCloseC  ) -> "}"-      (G GHC.AnnCloseP  ) -> ")"-#if __GLASGOW_HASKELL__ >= 801-      (G GHC.AnnCloseQ  ) -> "|]"-      (G GHC.AnnCloseQU ) -> "⟧"-#endif-      (G GHC.AnnCloseS  ) -> "]"-      (G GHC.AnnColon   ) -> ":"-      (G GHC.AnnComma   ) -> ","-      (G GHC.AnnCommaTuple ) -> ","-      (G GHC.AnnDarrow  ) -> "=>"-      (G GHC.AnnData    ) -> "data"-      (G GHC.AnnDcolon  ) -> "::"-      (G GHC.AnnDefault ) -> "default"-      (G GHC.AnnDeriving ) -> "deriving"-      (G GHC.AnnDo       ) -> "do"-      (G GHC.AnnDot      ) -> "."-      (G GHC.AnnDotdot   ) -> ".."-      (G GHC.AnnElse     ) -> "else"-      (G GHC.AnnEqual    ) -> "="-      (G GHC.AnnExport   ) -> "export"-      (G GHC.AnnFamily   ) -> "family"-      (G GHC.AnnForall   ) -> "forall"-      (G GHC.AnnForeign  ) -> "foreign"-      (G GHC.AnnGroup    ) -> "group"-      (G GHC.AnnHiding   ) -> "hiding"-      (G GHC.AnnIf       ) -> "if"-      (G GHC.AnnImport   ) -> "import"-      (G GHC.AnnIn       ) -> "in"-      (G GHC.AnnInstance ) -> "instance"-      (G GHC.AnnLam      ) -> "\\"-      (G GHC.AnnLarrow   ) -> "<-"-      (G GHC.AnnLet      ) -> "let"-      (G GHC.AnnMdo      ) -> "mdo"-      (G GHC.AnnMinus    ) -> "-"-      (G GHC.AnnModule   ) -> "module"-      (G GHC.AnnNewtype  ) -> "newtype"-      (G GHC.AnnOf       ) -> "of"-#if __GLASGOW_HASKELL__ >= 801-      (G GHC.AnnOpenB    ) -> "(|"-      (G GHC.AnnOpenBU   ) ->  "⦇"-#endif-      (G GHC.AnnOpenC    ) -> "{"-#if __GLASGOW_HASKELL__ > 710-      (G GHC.AnnOpenE    ) -> "[e|"-#endif-#if __GLASGOW_HASKELL__ >= 801-      (G GHC.AnnOpenEQ   ) -> "[|"-      (G GHC.AnnOpenEQU  ) ->  "⟦"-#endif-      (G GHC.AnnOpenP    ) -> "("-      (G GHC.AnnOpenPE   ) -> "$("-      (G GHC.AnnOpenPTE  ) -> "$$("-      (G GHC.AnnOpenS    ) -> "["-      (G GHC.AnnPattern  ) -> "pattern"-      (G GHC.AnnProc     ) -> "proc"-      (G GHC.AnnQualified ) -> "qualified"-      (G GHC.AnnRarrow   ) -> "->"-      (G GHC.AnnRec      ) -> "rec"-      (G GHC.AnnRole     ) -> "role"-      (G GHC.AnnSafe     ) -> "safe"-      (G GHC.AnnSemi     ) -> ";"-#if __GLASGOW_HASKELL__ >= 801-      (G GHC.AnnSignature) -> "signature"-      (G GHC.AnnStock    ) -> "stock"-#endif-      (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"-      (G GHC.AnnVbar     ) -> "|"-      (G GHC.AnnWhere    ) -> "where"-      (G GHC.Annlarrowtail ) -> "-<"-      (G GHC.Annrarrowtail ) -> ">-"-      (G GHC.AnnLarrowtail ) -> "-<<"-      (G GHC.AnnRarrowtail ) -> ">>-"-      (G GHC.AnnSimpleQuote ) -> "'"-      (G GHC.AnnThTyQuote   ) -> "''"-      (G GHC.AnnThIdSplice  ) -> "$"-      (G GHC.AnnThIdTySplice ) -> "$$"-      (G GHC.AnnEofPos       ) -> ""-#if __GLASGOW_HASKELL__ > 710-      (G GHC.AnnDarrowU) -> "⇒"-      (G GHC.AnnDcolonU) -> "∷"-      (G GHC.AnnForallU) -> "∀"-      (G GHC.AnnLarrowU) -> "←"-      (G GHC.AnnLarrowtailU) -> "⤛"-      (G GHC.AnnRarrowU) -> "→"-      (G GHC.AnnRarrowtailU) -> "⤜"-      (G GHC.AnnlarrowtailU) -> "⤙"-      (G GHC.AnnrarrowtailU) -> "⤚"-#endif-#if __GLASGOW_HASKELL__ >= 800-      AnnTypeApp             -> "@"-#endif-#if __GLASGOW_HASKELL__ > 804-      (G GHC.AnnVia) -> "via"-#endif--#if __GLASGOW_HASKELL__ <= 710--- | Tries to find a unicode equivalent to a 'KeywordId'.--- If none exists then fall back to find the ASCII version.-unicodeString :: KeywordId -> String-unicodeString kw =-  fromMaybe (keywordToString kw) (lookup kw unicodeChars)--unicodeChars :: [(KeywordId, String)]-unicodeChars =-    -- AZ:TODO:make this a Data.Map, doing linear scan each time-      [ (G GHC.AnnDarrow, "⇒")-      , (G GHC.AnnDcolon, "∷")-      , (G GHC.AnnForall, "∀")-      , (G GHC.AnnLarrow, "←")-      , (G GHC.AnnLarrowtail, "⤛")-      , (G GHC.AnnRarrow, "→")-      , (G GHC.AnnRarrowtail, "⤜")-      , (G GHC.Annlarrowtail, "⤙")-      , (G GHC.Annrarrowtail, "⤚")-      ]--{--From Lexer.x--       ,("∷",   ITdcolon, unicodeSyntaxEnabled)-       ,("⇒",   ITdarrow, unicodeSyntaxEnabled)-       ,("∀",   ITforall, unicodeSyntaxEnabled)-       ,("→",   ITrarrow, unicodeSyntaxEnabled)-       ,("←",   ITlarrow, unicodeSyntaxEnabled)--       ,("⤙",   ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)-       ,("⤚",   ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)-       ,("⤛",   ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)-       ,("⤜",   ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)--       ,("★", ITstar, unicodeSyntaxEnabled)---}--#endif
src/Language/Haskell/GHC/ExactPrint/Parsers.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -11,9 +11,11 @@ module Language.Haskell.GHC.ExactPrint.Parsers (         -- * Utility           Parser+        , ParseResult         , withDynFlags         , CppOptions(..)         , defaultCppOptions+        , LibDir          -- * Module Parsers         , parseModule@@ -38,63 +40,60 @@         , initDynFlags         , initDynFlagsPure         , parseModuleFromStringInternal-        , parseModuleApiAnnsWithCpp-        , parseModuleApiAnnsWithCppInternal+        , parseModuleEpAnnsWithCpp+        , parseModuleEpAnnsWithCppInternal         , postParseTransform         ) where -import Language.Haskell.GHC.ExactPrint.Annotate-import Language.Haskell.GHC.ExactPrint.Delta import Language.Haskell.GHC.ExactPrint.Preprocess-import Language.Haskell.GHC.ExactPrint.Types -import Control.Monad.RWS--import GHC.Paths (libdir)+import Data.Functor (void) -import qualified ApiAnnotation as GHC-import qualified DynFlags      as GHC-import qualified FastString    as GHC-import qualified GHC           as GHC hiding (parseModule)-import qualified HeaderInfo    as GHC-import qualified Lexer         as GHC-import qualified MonadUtils    as GHC-import qualified Outputable    as GHC-import qualified Parser        as GHC-import qualified SrcLoc        as GHC-import qualified StringBuffer  as GHC+import qualified GHC hiding (parseModule)+import qualified Control.Monad.IO.Class as GHC+import qualified GHC.Data.FastString    as GHC+import qualified GHC.Data.StringBuffer  as GHC+import qualified GHC.Driver.Config.Parser as GHC+import qualified GHC.Driver.Errors.Types as GHC+import qualified GHC.Driver.Session     as GHC+import qualified GHC.Parser             as GHC+import qualified GHC.Parser.Header      as GHC+import qualified GHC.Parser.Lexer       as GHC+import qualified GHC.Parser.PostProcess as GHC+import qualified GHC.Types.SrcLoc       as GHC -#if __GLASGOW_HASKELL__ <= 710-import qualified OrdList as OL-#else import qualified GHC.LanguageExtensions as LangExt-#endif -import qualified Data.Map as Map--{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Redundant do" #-}-{-# ANN module "HLint: ignore Reduce duplication" #-} -- ---------------------------------------------------------------------  -- | Wrapper function which returns Annotations along with the parsed -- element.-parseWith :: Annotate w-          => GHC.DynFlags+parseWith :: GHC.DynFlags           -> FilePath-          -> GHC.P (GHC.Located w)+          -> GHC.P w           -> String-          -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)+          -> ParseResult w parseWith dflags fileName parser s =   case runParser parser dflags fileName s of-#if __GLASGOW_HASKELL__ >= 804-    GHC.PFailed _ ss m                    -> Left (ss, GHC.showSDoc dflags m)-#else-    GHC.PFailed ss m                    -> Left (ss, GHC.showSDoc dflags m)-#endif-    GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod)-      where as = relativiseApiAnns pmod apianns+    GHC.PFailed pst+      -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)+    GHC.POk _ pmod+      -> Right pmod ++parseWithECP :: (GHC.DisambECP w)+          => GHC.DynFlags+          -> FilePath+          -> GHC.P GHC.ECP+          -> String+          -> ParseResult (GHC.LocatedA w)+parseWithECP dflags fileName parser s =+    case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of+      GHC.PFailed pst+        -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)+      GHC.POk _ pmod+        -> Right pmod+ -- ---------------------------------------------------------------------  runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a@@ -102,7 +101,7 @@     where       location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1       buffer = GHC.stringToStringBuffer str-      parseState = GHC.mkPState flags buffer location+      parseState = GHC.initParserState (GHC.initParserOpts flags) buffer location  -- --------------------------------------------------------------------- @@ -112,44 +111,43 @@ -- @ -- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr) -- @-withDynFlags :: (GHC.DynFlags -> a) -> IO a-withDynFlags action = ghcWrapper $ do+withDynFlags :: LibDir -> (GHC.DynFlags -> a) -> IO a+withDynFlags libdir action = ghcWrapper libdir $ do   dflags <- GHC.getSessionDynFlags   void $ GHC.setSessionDynFlags dflags   return (action dflags)  -- --------------------------------------------------------------------- -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs))+parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) parseFile = runParser GHC.parseModule  -- --------------------------------------------------------------------- +type LibDir = FilePath++type ParseResult a = Either GHC.ErrorMessages a+ type Parser a = GHC.DynFlags -> FilePath -> String-                -> Either (GHC.SrcSpan, String)-                          (Anns, a)+                -> ParseResult a -parseExpr :: Parser (GHC.LHsExpr GhcPs)-parseExpr df fp = parseWith df fp GHC.parseExpression+parseExpr :: Parser (GHC.LHsExpr GHC.GhcPs)+parseExpr df fp = parseWithECP df fp GHC.parseExpression -parseImport :: Parser (GHC.LImportDecl GhcPs)+parseImport :: Parser (GHC.LImportDecl GHC.GhcPs) parseImport df fp = parseWith df fp GHC.parseImport -parseType :: Parser (GHC.LHsType GhcPs)+parseType :: Parser (GHC.LHsType GHC.GhcPs) parseType df fp = parseWith df fp GHC.parseType  -- safe, see D1007-parseDecl :: Parser (GHC.LHsDecl GhcPs)-#if __GLASGOW_HASKELL__ <= 710-parseDecl df fp = parseWith df fp (head . OL.fromOL <$> GHC.parseDeclaration)-#else+parseDecl :: Parser (GHC.LHsDecl GHC.GhcPs) parseDecl df fp = parseWith df fp GHC.parseDeclaration-#endif -parseStmt :: Parser (GHC.ExprLStmt GhcPs)+parseStmt :: Parser (GHC.ExprLStmt GHC.GhcPs) parseStmt df fp = parseWith df fp GHC.parseStatement -parsePattern :: Parser (GHC.LPat GhcPs)+parsePattern :: Parser (GHC.LPat GHC.GhcPs) parsePattern df fp = parseWith df fp GHC.parsePattern  -- ---------------------------------------------------------------------@@ -163,9 +161,8 @@ -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs')-parseModule-  :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))-parseModule = parseModuleWithCpp defaultCppOptions normalLayout+parseModule :: LibDir -> FilePath -> IO (ParseResult GHC.ParsedSource)+parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file   -- | This entry point will work out which language extensions are@@ -174,89 +171,80 @@ -- string; the `FilePath` parameter solely exists to provide a name -- in source location annotations. parseModuleFromString-  :: FilePath+  :: LibDir -- GHC libdir+  -> FilePath   -> String-  -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))-parseModuleFromString fp s = ghcWrapper $ do+  -> IO (ParseResult GHC.ParsedSource)+parseModuleFromString libdir fp s = ghcWrapper libdir $ do   dflags <- initDynFlagsPure fp s   return $ parseModuleFromStringInternal dflags fp s  -- | Internal part of 'parseModuleFromString'.-parseModuleFromStringInternal-  :: GHC.DynFlags-  -> FilePath-  -> String-  -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)+parseModuleFromStringInternal :: Parser GHC.ParsedSource parseModuleFromStringInternal dflags fileName str =   let (str1, lp) = stripLinePragmas str       res        = case runParser GHC.parseModule dflags fileName str1 of-#if __GLASGOW_HASKELL__ >= 804-        GHC.PFailed _ ss m  -> Left (ss, GHC.showSDoc dflags m)-#else-        GHC.PFailed ss m    -> Left (ss, GHC.showSDoc dflags m)-#endif-        GHC.POk     x  pmod -> Right $ (mkApiAnns x, lp, dflags, pmod)-  in  postParseTransform res normalLayout+        GHC.PFailed pst+          -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)+        GHC.POk     _  pmod+          -> Right (lp, dflags, pmod)+  in  postParseTransform res -parseModuleWithOptions :: DeltaOptions+parseModuleWithOptions :: LibDir -- ^ GHC libdir                        -> FilePath-                       -> IO (Either (GHC.SrcSpan, String)-                                     (Anns, GHC.ParsedSource))-parseModuleWithOptions opts fp =-  parseModuleWithCpp defaultCppOptions opts fp+                       -> IO (ParseResult GHC.ParsedSource)+parseModuleWithOptions libdir fp =+  parseModuleWithCpp libdir defaultCppOptions fp   -- | Parse a module with specific instructions for the C pre-processor. parseModuleWithCpp-  :: CppOptions-  -> DeltaOptions-  -> FilePath-  -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))-parseModuleWithCpp cpp opts fp = do-  res <- parseModuleApiAnnsWithCpp cpp fp-  return $ postParseTransform res opts+  :: LibDir -- ^ GHC libdir+  -> CppOptions+  -> FilePath -- ^ File to be parsed+  -> IO (ParseResult GHC.ParsedSource)+parseModuleWithCpp libdir cpp fp = do+  res <- parseModuleEpAnnsWithCpp libdir cpp fp+  return $ postParseTransform res  -- ---------------------------------------------------------------------  -- | Low level function which is used in the internal tests. -- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of -- this function.-parseModuleApiAnnsWithCpp-  :: CppOptions-  -> FilePath+parseModuleEpAnnsWithCpp+  :: LibDir -- ^ GHC libdir+  -> CppOptions+  -> FilePath -- ^ File to be parsed   -> IO        ( Either-           (GHC.SrcSpan, String)-           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)+           GHC.ErrorMessages+           ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource)        )-parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do+parseModuleEpAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do   dflags <- initDynFlags file-  parseModuleApiAnnsWithCppInternal cppOptions dflags file+  parseModuleEpAnnsWithCppInternal cppOptions dflags file  -- | Internal function. Default runner of GHC.Ghc action in IO.-ghcWrapper :: GHC.Ghc a -> IO a-ghcWrapper =+ghcWrapper :: LibDir -> GHC.Ghc a -> IO a+ghcWrapper libdir a =   GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut-    . GHC.runGhc (Just libdir)+    $ GHC.runGhc (Just libdir) a  -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing.-parseModuleApiAnnsWithCppInternal+parseModuleEpAnnsWithCppInternal   :: GHC.GhcMonad m   => CppOptions   -> GHC.DynFlags   -> FilePath   -> m        ( Either-           (GHC.SrcSpan, String)-           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)+           GHC.ErrorMessages+           ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource)        )-parseModuleApiAnnsWithCppInternal cppOptions dflags file = do-#if __GLASGOW_HASKELL__ <= 710-  let useCpp = GHC.xopt GHC.Opt_Cpp dflags-#else+parseModuleEpAnnsWithCppInternal cppOptions dflags file = do   let useCpp = GHC.xopt LangExt.Cpp dflags-#endif   (fileContents, injectedComments, dflags') <-     if useCpp       then do@@ -269,25 +257,86 @@         return (contents1,lp,dflags)   return $     case parseFile dflags' file fileContents of-#if __GLASGOW_HASKELL__ >= 804-      GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m))-#else-      GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m))-#endif-      GHC.POk (mkApiAnns -> apianns) pmod  ->-        Right $ (apianns, injectedComments, dflags', pmod)+      GHC.PFailed pst+        -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)+      GHC.POk _ pmod+        -> Right $ (injectedComments, dflags', fixModuleComments pmod)  -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. postParseTransform-  :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)-  -> DeltaOptions-  -> Either a (Anns, GHC.ParsedSource)-postParseTransform parseRes opts = either Left mkAnns parseRes+  :: Either a ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource)+  -> Either a (GHC.ParsedSource)+postParseTransform parseRes = fmap mkAnns parseRes   where-    mkAnns (apianns, cs, _, m) =-      Right (relativiseApiAnnsWithOptions opts cs m apianns, m)+    mkAnns (_cs, _, m) = fixModuleComments m +fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource+fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p++fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource+fixModuleTrailingComments (GHC.L l p) = GHC.L l p'+  where+    an' = case GHC.hsmodAnn $ GHC.hsmodExt p of+      (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance ocs)+    p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' } }++    rebalance :: GHC.EpAnnComments -> GHC.EpAnnComments+    rebalance cs = cs'+      where+        cs' = case GHC.hsmodLayout $ GHC.hsmodExt p of+          GHC.EpExplicitBraces _ (GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan ss _))) ->+            let+              pc = GHC.priorComments cs+              fc = GHC.getFollowingComments cs+              bf (GHC.L anc _) = GHC.epaLocationRealSrcSpan anc > ss++              (prior,f) = break bf fc+              cs'' = GHC.EpaCommentsBalanced (pc <> prior) f+            in cs''+          _ -> cs++-- Deal with https://gitlab.haskell.org/ghc/ghc/-/issues/23984+-- The Lexer works bottom-up, so does not have module declaration info+-- when the first top decl processed+fixModuleHeaderComments :: GHC.ParsedSource -> GHC.ParsedSource+fixModuleHeaderComments (GHC.L l p) = GHC.L l p'+  where+    moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments+                 -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments)+    moveComments GHC.EpaDelta{} dd cs = (dd,cs)+    moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs)+    moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css)+      where+        -- Move any comments on the decl that occur prior to the location+        pc = GHC.priorComments csd+        fc = GHC.getFollowingComments csd+        bf (GHC.L anch _) = GHC.epaLocationRealSrcSpan anch > r+        (move,keep) = break bf pc+        csd' = GHC.EpaCommentsBalanced keep fc++        dd = GHC.L (GHC.EpAnn anc an csd') a+        css = cs <> GHC.EpaComments move++    (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p)+    p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' },+             GHC.hsmodDecls = ds'+           }++    rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)+              -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)+    rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs')+      where+        (ds1,cs') = case GHC.am_where an of+                     GHC.EpTok whereLoc ->+                           case GHC.hsmodDecls p of+                               (d:ds0) -> (d':ds0, cs0)+                                   where (d',cs0) = moveComments whereLoc d cs+                               ds0 -> (ds0,cs)+                     _ -> (ds,cs)+++ -- | Internal function. Initializes DynFlags value for parsing. -- -- Passes "-hide-all-packages" to the GHC API to prevent parsing of@@ -296,13 +345,17 @@ -- See ghc tickets #15513, #15541. initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags initDynFlags file = do+  -- Based on GHC backpack driver doBackPack   dflags0         <- GHC.getSessionDynFlags-  src_opts        <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file-  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts+  let parser_opts0 = GHC.initParserOpts dflags0+  logger <- GHC.getLogger+  (_, src_opts)   <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file+  (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts   -- Turn this on last to avoid T10942   let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream   -- Prevent parsing of .ghc.environment.* "package environment files"   (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine+    logger     dflags2     [GHC.noLoc "-hide-all-packages"]   _ <- GHC.setSessionDynFlags dflags3@@ -319,24 +372,23 @@ -- See ghc tickets #15513, #15541. initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags initDynFlagsPure fp s = do+  -- AZ Note: "I" below appears to be Lennart Spitzner   -- I was told we could get away with using the unsafeGlobalDynFlags.   -- as long as `parseDynamicFilePragma` is impure there seems to be   -- no reason to use it.   dflags0 <- GHC.getSessionDynFlags-  let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp-  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo+  logger <- GHC.getLogger+  let parser_opts0 = GHC.initParserOpts dflags0+  let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (GHC.stringToStringBuffer $ s) fp+  (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 pragmaInfo   -- Turn this on last to avoid T10942   let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream   -- Prevent parsing of .ghc.environment.* "package environment files"   (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine+    logger     dflags2     [GHC.noLoc "-hide-all-packages"]   _ <- GHC.setSessionDynFlags dflags3   return dflags3  -- -----------------------------------------------------------------------mkApiAnns :: GHC.PState -> GHC.ApiAnns-mkApiAnns pstate-  = ( Map.fromListWith (++) . GHC.annotations $ pstate-    , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate))
src/Language/Haskell/GHC/ExactPrint/Preprocess.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} -- | This module provides support for CPP, interpreter directives and line -- pragmas. module Language.Haskell.GHC.ExactPrint.Preprocess@@ -14,28 +14,30 @@    , defaultCppOptions    ) where -import qualified Bag            as GHC-import qualified DriverPhases   as GHC-import qualified DriverPipeline as GHC-import qualified DynFlags       as GHC-import qualified ErrUtils       as GHC-import qualified FastString     as GHC import qualified GHC            as GHC hiding (parseModule)-import qualified HscTypes       as GHC-import qualified Lexer          as GHC-import qualified MonadUtils     as GHC-import qualified SrcLoc         as GHC-import qualified StringBuffer   as GHC -import SrcLoc (mkSrcSpan, mkSrcLoc)-import FastString (mkFastString)+import qualified Control.Monad.IO.Class as GHC+import qualified GHC.Data.FastString   as GHC+import qualified GHC.Data.StringBuffer as GHC+import qualified GHC.Driver.Config.Parser as GHC+import qualified GHC.Driver.Env        as GHC+import qualified GHC.Driver.Errors.Types as GHC+import qualified GHC.Driver.Phases     as GHC+import qualified GHC.Driver.Pipeline   as GHC+import qualified GHC.Parser.Lexer      as GHC+import qualified GHC.Settings          as GHC+import qualified GHC.Types.Error       as GHC+import qualified GHC.Types.SourceError as GHC+import qualified GHC.Types.SourceFile  as GHC+import qualified GHC.Types.SrcLoc      as GHC+import qualified GHC.Utils.Error       as GHC+import qualified GHC.Utils.Fingerprint as GHC+import qualified GHC.Utils.Outputable  as GHC+import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)+import GHC.Data.FastString (mkFastString) -import Control.Exception-import Data.List hiding (find)+import Data.List (isPrefixOf) import Data.Maybe-#if __GLASGOW_HASKELL__ <= 800-import Language.Haskell.GHC.ExactPrint.GhcInterim (commentToAnnotation)-#endif import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Data.Set as Set@@ -43,9 +45,6 @@  -- import Debug.Trace ---{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}-{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}  -- --------------------------------------------------------------------- @@ -59,30 +58,29 @@ defaultCppOptions = CppOptions [] [] []  -- ------------------------------------------------------------------------ | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments.-stripLinePragmas :: String -> (String, [Comment])+-- | Remove GHC style line pragmas (@{-# LINE .. #-}@) and convert them into comments.+stripLinePragmas :: String -> (String, [GHC.LEpaComment]) stripLinePragmas = unlines' . unzip . findLines . lines   where     unlines' (a, b) = (unlines a, catMaybes b) -findLines :: [String] -> [(String, Maybe Comment)]+findLines :: [String] -> [(String, Maybe GHC.LEpaComment)] findLines = zipWith checkLine [1..] -checkLine :: Int -> String -> (String, Maybe Comment)+checkLine :: Int -> String -> (String, Maybe GHC.LEpaComment) checkLine line s   |  "{-# LINE" `isPrefixOf` s =        let (pragma, res) = getPragma s            size   = length pragma            mSrcLoc = mkSrcLoc (mkFastString "LINE")            ss     = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))-       in (res, Just $ mkComment pragma ss)+       in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))   -- Deal with shebang/cpp directives too-  -- x |  "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)   |  "#!" `isPrefixOf` s =     let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG")         ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))     in-    ("",Just $ mkComment s ss)+    ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))   | otherwise = (s, Nothing)  getPragma :: String -> (String, String)@@ -101,36 +99,38 @@ getCppTokensAsComments :: GHC.GhcMonad m                        => CppOptions  -- ^ Preprocessor Options                        -> FilePath    -- ^ Path to source file-                       -> m [Comment]+                       -> m [GHC.LEpaComment] getCppTokensAsComments cppOptions sourceFile = do   source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile   let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1-  (_txt,strSrcBuf,flags2) <- getPreprocessedSrcDirectPrim cppOptions sourceFile-  -- #ifdef tokens+  (_txt,strSrcBuf,flags2') <- getPreprocessedSrcDirectPrim cppOptions sourceFile+  let flags2 = GHC.initParserOpts flags2'+  -- hash-ifdef tokens   directiveToks <- GHC.liftIO $ getPreprocessorAsComments sourceFile-  -- Tokens without #ifdef+  -- Tokens without hash-ifdef   nonDirectiveToks <- tokeniseOriginalSrc startLoc flags2 source-  case GHC.lexTokenStream strSrcBuf startLoc flags2 of+  case GHC.lexTokenStream flags2 strSrcBuf startLoc of         GHC.POk _ ts ->                do                   let toks = GHC.addSourceToTokens startLoc source ts                       cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks                   return $ filter goodComment-#if __GLASGOW_HASKELL__ > 800-                         $  map (tokComment . GHC.commentToAnnotation . fst) cppCommentToks-#else-                         $  map (tokComment . commentToAnnotation . fst) cppCommentToks-#endif-#if __GLASGOW_HASKELL__ >= 804-        GHC.PFailed _ sspan err -> parseError flags2 sspan err-#else-        GHC.PFailed sspan err -> parseError flags2 sspan err-#endif+                         $  map (GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks+        GHC.PFailed pst -> parseError pst -goodComment :: Comment -> Bool-goodComment (Comment "" _ _) = False-goodComment _              = True +goodComment :: GHC.LEpaComment -> Bool+goodComment c = isGoodComment (tokComment c)+  where+    isGoodComment :: [Comment] -> Bool+    isGoodComment []                 = False+    isGoodComment [Comment "" _ _ _] = False+    isGoodComment _                  = True++toRealLocated :: GHC.Located a -> GHC.RealLocated a+toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s              x+toRealLocated (GHC.L _ x)                     = GHC.L badRealSrcSpan x+ -- ---------------------------------------------------------------------  -- | Combine the three sets of tokens to produce a single set that@@ -150,23 +150,23 @@   -> [(GHC.Located GHC.Token, String)] getCppTokens directiveToks origSrcToks postCppToks = toks   where-    locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare l1 l2+    locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare (rs l1) (rs l2)     m1Toks = mergeBy locFn postCppToks directiveToks      -- We must now find the set of tokens that are in origSrcToks, but     -- not in m1Toks      -- GHC.Token does not have Ord, can't use a set directly-    origSpans = map (\(GHC.L l _,_) -> l) origSrcToks-    m1Spans = map (\(GHC.L l _,_) -> l) m1Toks+    origSpans = map (\(GHC.L l _,_) -> rs l) origSrcToks+    m1Spans = map (\(GHC.L l _,_) -> rs l) m1Toks     missingSpans = Set.fromList origSpans Set.\\ Set.fromList m1Spans -    missingToks = filter (\(GHC.L l _,_) -> Set.member l missingSpans) origSrcToks+    missingToks = filter (\(GHC.L l _,_) -> Set.member (rs l) missingSpans) origSrcToks      missingAsComments = map mkCommentTok missingToks       where         mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)-        mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s),s)+        mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s (makeBufSpan l)),s)      toks = mergeBy locFn directiveToks missingAsComments @@ -174,17 +174,13 @@  tokeniseOriginalSrc ::   GHC.GhcMonad m-  => GHC.RealSrcLoc -> GHC.DynFlags -> GHC.StringBuffer+  => GHC.RealSrcLoc -> GHC.ParserOpts -> GHC.StringBuffer   -> m [(GHC.Located GHC.Token, String)] tokeniseOriginalSrc startLoc flags buf = do   let src = stripPreprocessorDirectives buf-  case GHC.lexTokenStream src startLoc flags of+  case GHC.lexTokenStream flags src startLoc of     GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts-#if __GLASGOW_HASKELL__ >= 804-    GHC.PFailed _ sspan err -> parseError flags sspan err-#else-    GHC.PFailed sspan err -> parseError flags sspan err-#endif+    GHC.PFailed pst -> parseError pst  -- --------------------------------------------------------------------- @@ -194,7 +190,7 @@ stripPreprocessorDirectives buf = buf'   where     srcByLine = lines $ sbufToString buf-    noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine+    noDirectivesLines = map (\line -> case line of '#' : _ -> ""; _ -> line) srcByLine     buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines  -- ---------------------------------------------------------------------@@ -218,26 +214,49 @@   hsc_env <- GHC.getSession   let dfs = GHC.hsc_dflags hsc_env       new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }-  (dflags', hspp_fn) <--      GHC.liftIO $ GHC.preprocess new_env (src_fn, Just (GHC.Cpp GHC.HsSrcFile))-  buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn-  txt <- GHC.liftIO $ readFileGhc hspp_fn-  return (txt, buf, dflags')+  r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile))+  case r of+    Left err -> error $ showErrorMessages err+    Right (dflags', hspp_fn) -> do+      buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn+      txt <- GHC.liftIO $ readFileGhc hspp_fn+      return (txt, buf, dflags') +showErrorMessages :: GHC.Messages GHC.DriverMessage -> String+showErrorMessages msgs =+  GHC.renderWithContext GHC.defaultSDocContext+    $ GHC.vcat+    $ GHC.pprMsgEnvelopeBagWithLocDefault+    $ GHC.getMessages+    $ msgs+ injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags-injectCppOptions CppOptions{..} dflags =-  foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile)+injectCppOptions CppOptions{..} dflags = folded_opt   where     mkDefine = ("-D" ++)     mkIncludeDir = ("-I" ++)     mkInclude = ("-include" ++)-+    file_flags = map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile+    addFs = [addOptP, addOptJSP, addOptCmmP]+    folded_opt = foldr ($) dflags (addFs <*> file_flags)  addOptP :: String -> GHC.DynFlags -> GHC.DynFlags-addOptP   f = alterSettings (\s -> s { GHC.sOpt_P   = f : GHC.sOpt_P s})--alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags-alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) }+addOptP   f = alterToolSettings $ \s -> s+          { GHC.toolSettings_opt_P   = f : GHC.toolSettings_opt_P s+          , GHC.toolSettings_opt_P_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_P s)+          }+addOptJSP :: String -> GHC.DynFlags -> GHC.DynFlags+addOptJSP f = alterToolSettings $ \s -> s+          { GHC.toolSettings_opt_JSP   = f : GHC.toolSettings_opt_JSP s+          , GHC.toolSettings_opt_JSP_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_JSP s)+          }+addOptCmmP :: String -> GHC.DynFlags -> GHC.DynFlags+addOptCmmP f = alterToolSettings $ \s -> s+          { GHC.toolSettings_opt_CmmP = f : GHC.toolSettings_opt_CmmP s+          , GHC.toolSettings_opt_CmmP_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_CmmP s)+          }+alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags+alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) }  -- --------------------------------------------------------------------- @@ -246,10 +265,10 @@ getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)] getPreprocessorAsComments srcFile = do   fcontents <- readFileGhc srcFile-  let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')+  let directives = filter (\(_lineNum,line) -> case line of '#' : _ -> True; _ -> False)                     $ zip [1..] (lines fcontents) -  let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line),line)+  let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line (makeBufSpan l)),line)        where          start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1          end   = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line)@@ -258,11 +277,16 @@   let toks = map mkTok directives   return toks +makeBufSpan :: GHC.SrcSpan -> GHC.PsSpan+makeBufSpan ss = pspan+  where+    bl = GHC.BufPos 0+    pspan = GHC.PsSpan (GHC.realSrcSpan ss) (GHC.BufSpan bl bl)+ -- --------------------------------------------------------------------- -parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b-parseError dflags sspan err = do-     throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)+parseError :: (GHC.MonadIO m) => GHC.PState -> m b+parseError pst = GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst))  -- --------------------------------------------------------------------- @@ -294,4 +318,3 @@         -- Someone please put this code out of its misery.     | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally     | otherwise = y : mergeBy cmp allx ys-
− src/Language/Haskell/GHC/ExactPrint/Pretty.hs 
@@ -1,610 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.GHC.ExactPrint.Pretty------ This module adds default annotations to an AST fragment that does not have--- them, to be able to exactprint it in a way that preserves the orginal AST--- when re-parsed.-----------------------------------------------------------------------------------module Language.Haskell.GHC.ExactPrint.Pretty-        (-        addAnnotationsForPretty-        ) where--import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Utils-import Language.Haskell.GHC.ExactPrint.Annotate--import Control.Monad.RWS-import Control.Monad.Trans.Free-import Data.Generics-import Data.List-import Data.Ord (comparing)---#if __GLASGOW_HASKELL__ <= 710-import qualified BooleanFormula as GHC-import qualified Outputable     as GHC-#endif-import qualified GHC--import qualified Data.Map as Map-import qualified Data.Set as Set--{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Redundant do" #-}-{-# ANN module "HLint: ignore Reduce duplication" #-}---- ------------------------------------------------------------------------- |Add any missing annotations so that the full AST element will exactprint--- properly when done.-addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns-addAnnotationsForPretty cs ast ans-  = runPrettyWithComments opts cs (annotate ast) ans (0,0)-  where-    opts = prettyOptions NormalLayout---- --------------------------------------------------------------------------- | Type used in the Pretty Monad.-type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a--runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns-runPrettyWithComments opts cs action ans priorEnd =-  mkAnns . snd-  . (\next -> execRWS next opts (defaultPrettyState cs priorEnd ans))-  . prettyInterpret $ action-  where-    mkAnns :: PrettyWriter -> Anns-    mkAnns = f . dwAnns-    f :: Monoid a => Endo a -> a-    f = ($ mempty) . appEndo---- ------------------------------------------------------------------------- TODO: rename this, it is the R part of the RWS-data PrettyOptions = PrettyOptions-       {-         -- | Current `SrcSpan, part of current AnnKey`-         curSrcSpan  :: !GHC.SrcSpan--         -- | Constuctor of current AST element, part of current AnnKey-       , annConName       :: !AnnConName--        -- | Whether to use rigid or normal layout rules-       , drRigidity :: !Rigidity--       -- | Current higher level context. e.g. whether a Match is part of a-       -- LambdaExpr or a FunBind-       , prContext :: !AstContextSet-       } deriving Show--data PrettyWriter = PrettyWriter-       { -- | Final list of annotations, and sort keys-         dwAnns :: Endo (Map.Map AnnKey Annotation)--         -- | Used locally to pass Keywords, delta pairs relevant to a specific-         -- subtree to the parent.-       , annKds          :: ![(KeywordId, DeltaPos)]-       , sortKeys        :: !(Maybe [GHC.SrcSpan])-       , dwCapturedSpan  :: !(First AnnKey)-       , prLayoutContext :: !(ACS' AstContext)-       }--data PrettyState = PrettyState-       { -- | Position reached when processing the last element-         priorEndPosition    :: !Pos--         -- | Ordered list of comments still to be allocated-       , apComments :: ![Comment]--       , apMarkLayout  :: Bool-       , apLayoutStart :: LayoutStartCol--       , apNoPrecedingSpace :: Bool--       }--#if __GLASGOW_HASKELL__ >= 804-instance Semigroup PrettyWriter where-  (<>) = mappend-#endif--instance Monoid PrettyWriter where-  mempty = PrettyWriter mempty mempty mempty mempty mempty-  (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j)-    = PrettyWriter (a <> c) (b <> d) (e <> f) (g <> h) (i <> j)---- -----------------------------------------------------------------------prettyOptions :: Rigidity -> PrettyOptions-prettyOptions ridigity =-  PrettyOptions-    { curSrcSpan = GHC.noSrcSpan-    , annConName = annGetConstr ()-    , drRigidity = ridigity-    , prContext  = defaultACS-    }--defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState-defaultPrettyState injectedComments priorEnd _ans =-    PrettyState-      { priorEndPosition    = priorEnd-      , apComments = cs ++ injectedComments-      , apLayoutStart = 1-      , apMarkLayout = False-      , apNoPrecedingSpace = False-      }-  where-    cs :: [Comment]-    cs = []---- ------------------------------------------------------------------------ Free Monad Interpretation code--prettyInterpret :: Annotated a -> Pretty a-prettyInterpret = iterTM go-  where-    go :: AnnotationF (Pretty a) -> Pretty a-    go (MarkPrim kwid _ next)           = addPrettyAnnotation (G kwid) >> next-    go (MarkPPOptional _kwid _ next)    = next-    go (MarkEOF next)                   = addEofAnnotation >> next-    go (MarkExternal _ss akwid _ next)  = addPrettyAnnotation (G akwid) >> next-#if __GLASGOW_HASKELL__ >= 800-    go (MarkInstead akwid kwid next)    = addPrettyAnnotationsInstead akwid kwid >> next-#endif-    go (MarkOutside akwid kwid next)    = addPrettyAnnotationsOutside akwid kwid >> next-    -- go (MarkOutside akwid kwid next)    = addPrettyAnnotation kwid >> next-    go (MarkInside akwid next)          = addPrettyAnnotationsInside akwid >> next-    go (MarkMany akwid next)            = addPrettyAnnotation (G akwid) >> next-    go (MarkManyOptional _akwid next)   = next-    go (MarkOffsetPrim akwid n _ next)  = addPrettyAnnotationLs akwid n >> next-    go (MarkOffsetPrimOptional _akwid _n _ next)  = next-    go (WithAST lss prog next)          = withAST lss (prettyInterpret prog) >> next-    go (CountAnns kwid next)            = countAnnsPretty kwid >>= next-    go (WithSortKey             kws next) = withSortKey             kws >> next-    go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next-    go (SetLayoutFlag r action next)    = do-      rigidity <- asks drRigidity-      (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action)-      next-    go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next-    go (MarkAnnBeforeAnn _ann1 _ann2 next) = next-    go (GetSrcSpanForKw ss kw next)      = getSrcSpanForKw ss kw >>= next-#if __GLASGOW_HASKELL__ <= 710-    go (StoreString s ss next)           = storeString s ss >> next-#endif-    go (AnnotationsToComments kws next)       = annotationsToCommentsPretty kws >> next-#if __GLASGOW_HASKELL__ <= 710-    go (AnnotationsToCommentsBF bf kws next)  = annotationsToCommentsBFPretty bf kws >> next-    go (FinalizeBF l next)                    = finalizeBFPretty l >> next-#endif--    go (SetContextLevel ctxt lvl action next)  = setContextPretty ctxt lvl (prettyInterpret action) >> next-    go (UnsetContext    ctxt     action next)  = unsetContextPretty ctxt (prettyInterpret action) >> next-    go (IfInContext ctxt ia ea next)           = ifInContextPretty ctxt ia ea >> next-    go (TellContext c next)                    = tellContext c >> next---- -----------------------------------------------------------------------addEofAnnotation :: Pretty ()-addEofAnnotation = do-  tellKd (G GHC.AnnEofPos, DP (1,0))---- -----------------------------------------------------------------------addPrettyAnnotation :: KeywordId -> Pretty ()-addPrettyAnnotation ann = do-  noPrec <- gets apNoPrecedingSpace-  ctx <- asks prContext-  _ <- debugP ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext-  let-    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))-           (G GHC.AnnCase )        -> tellKd (ann,DP (0,1))-           (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))-           (G GHC.AnnElse)         -> tellKd (ann,DP (1,2))-           (G GHC.AnnEqual)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnExport)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnFamily)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnForall)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnGroup)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnHiding)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnIf)           -> tellKd (ann,DP (0,1))-           (G GHC.AnnImport)       -> tellKd (ann,DP (0,1))-           (G GHC.AnnIn)           -> tellKd (ann,DP (1,0))-           (G GHC.AnnInstance)     -> tellKd (ann,DP (0,1))-           (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))-           (G GHC.AnnOpenPTE)      -> tellKd (ann,DP (0,1))-           (G GHC.AnnQualified)    -> tellKd (ann,DP (0,1))-           (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))-           (G GHC.AnnThTyQuote)    -> tellKd (ann,DP (0,1))-           (G GHC.AnnThen)         -> tellKd (ann,DP (1,2))-           (G GHC.AnnTilde)        -> tellKd (ann,DP (0,1))-           (G GHC.AnnType)         -> tellKd (ann,DP (0,1))-           (G GHC.AnnUsing)        -> tellKd (ann,DP (0,1))-           (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))-#endif-           _ ->                tellKd (ann,DP (0,0))-  fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 800-addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty ()-addPrettyAnnotationsInstead _akwid AnnSemiSep = return ()-addPrettyAnnotationsInstead _akwid kwid = addPrettyAnnotation kwid-#endif---- -----------------------------------------------------------------------addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty ()-addPrettyAnnotationsOutside _akwid AnnSemiSep = return ()-addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid---- -----------------------------------------------------------------------addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty ()-addPrettyAnnotationsInside _ann = return ()---- -----------------------------------------------------------------------addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty ()-addPrettyAnnotationLs ann _off = addPrettyAnnotation (G ann)---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710-getUnallocatedComments :: Pretty [Comment]-getUnallocatedComments = gets apComments--putUnallocatedComments :: [Comment] -> Pretty ()-putUnallocatedComments cs = modify (\s -> s { apComments = cs } )-#endif---- -----------------------------------------------------------------------withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b-withSrcSpanPretty (GHC.L l a) action = do-  -- peek into the current state of the output, to extract the layout context-  -- flags passed up from subelements of the AST.-  (_,w) <- listen (return () :: Pretty ())--  _ <- debugP ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ())--  local (\s -> s { curSrcSpan = l-                 , annConName = annGetConstr a-                 -- , prContext  = pushAcs (prContext s)-                 , prContext  = (pushAcs (prContext s)) <> (prLayoutContext w)-                 })-        action---- ------------------------------------------------------------------------- | Enter a new AST element. Maintain SrcSpan stack-withAST :: Data a-        => GHC.Located a-        -> Pretty b -> Pretty b-withAST lss@(GHC.L ss t) action = do-  return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t)))-  -- Calculate offset required to get to the start of the SrcSPan-  -- off <- gets apLayoutStart-  withSrcSpanPretty lss $ do-    return () `debug` ("Pretty.withAST:enter:(ss)=" ++ showGhc (ss,showConstr (toConstr t)))--    let maskWriter s = s { annKds          = []-                         , sortKeys        = Nothing-                         , dwCapturedSpan  = mempty-                         -- , prLayoutContext = pushAcs (prLayoutContext s)-                         }--#if __GLASGOW_HASKELL__ <= 710-    let spanStart = ss2pos ss-    cs <- do-      if GHC.isGoodSrcSpan ss-        then-          commentAllocation (priorComment spanStart) return-        else-          return []-#else-    let cs = []-#endif--    -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext-    ctx <- asks prContext--    noPrec <- gets apNoPrecedingSpace-    edp <- debugP ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t-    -- edp <- entryDpFor ctx t--    let ctx1 = debugP ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx-    (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1-      then-           -- debugP ("Pretty.withAST:setNoPrecedingSpace") $-             censor maskWriter (listen (setNoPrecedingSpace action))-      else-           -- debugP ("Pretty.withAST:setNoPrecedingSpace") $-            censor maskWriter (listen action)--    let kds = annKds w-        an = Ann-               { annEntryDelta        = edp-               , annPriorComments     = cs-               , annFollowingComments = [] -- only used in Transform and Print-               , annsDP               = kds-               , annSortKey           = sortKeys w-               , annCapturedSpan      = getFirst $ dwCapturedSpan w-               }--    addAnnotationsPretty an-     `debug` ("Pretty.withAST:(annkey,an)=" ++ show (mkAnnKey lss,an))-    return res---- -----------------------------------------------------------------------entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos-entryDpFor ctx a = (def `extQ` grhs) a-  where-    lineDefault = if inAcs (Set.singleton AdvanceLine) ctx-                    then 1 else 0-    noAdvanceLine = inAcs (Set.singleton NoAdvanceLine) ctx &&-                    inAcs (Set.singleton ListStart) ctx--    def :: a -> Pretty DeltaPos-    def _ =-      debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $-        if noAdvanceLine-          then return (DP (0,1))-          else-            if listStart-              then return (DP (1,2))-              else if inList-                then if topLevel then return (DP (2,0)) else return (DP (1,0))-                else if topLevel then return (DP (2,0)) else return (DP (lineDefault,0))--    topLevel = inAcs (Set.singleton TopLevel) ctx-    listStart = inAcs (Set.singleton ListStart) ctx-              && not (inAcs (Set.singleton TopLevel) ctx)-    inList = inAcs (Set.singleton ListItem) ctx-    inLambda = inAcs (Set.singleton LambdaExpr) ctx--    grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos-    grhs _ = do-      if inLambda-        then return (DP (0,1))-        else return (DP (1,2))---- -----------------------------------------------------------------------fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a-fromNoPrecedingSpace def lay = do-  PrettyState{apNoPrecedingSpace} <- get-  -- ctx <- asks prContext-  if apNoPrecedingSpace-    then do-      modify (\s -> s { apNoPrecedingSpace = False-                      })-      debugP ("fromNoPrecedingSpace:def") def-      -- def-    else-      -- lay-      debugP ("fromNoPrecedingSpace:lay") lay----- ------------------------------------------------------------------------- |Add some annotation to the currently active SrcSpan-addAnnotationsPretty :: Annotation -> Pretty ()-addAnnotationsPretty ann = do-    l <- ask-    return () `debug` ("addAnnotationsPretty:=" ++ showGhc (curSrcSpan l,prContext l))-    tellFinalAnn (getAnnKey l,ann)--getAnnKey :: PrettyOptions -> AnnKey-getAnnKey PrettyOptions {curSrcSpan, annConName}-  = AnnKey curSrcSpan annConName---- -----------------------------------------------------------------------countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int-countAnnsPretty _ann = return 0---- -----------------------------------------------------------------------withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Pretty ()-withSortKey kws =-  let order = sortBy (comparing fst) kws-  in do-    tellSortKey (map fst order)-    mapM_ (prettyInterpret . snd) order--withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Pretty ()-withSortKeyContexts ctxts kws =-  let order = sortBy (comparing fst) kws-  in do-    tellSortKey (map fst order)-    withSortKeyContextsHelper prettyInterpret ctxts order---- -----------------------------------------------------------------------storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey-storeOriginalSrcSpanPretty _s key = do-  tellCapturedSpan key-  return key---- -----------------------------------------------------------------------getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan-getSrcSpanForKw ss _kw = return ss---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710-storeString :: String -> GHC.SrcSpan -> Pretty ()-storeString s _ss = addPrettyAnnotation (AnnString s)-#endif---- -----------------------------------------------------------------------setLayoutFlag :: Pretty () -> Pretty ()-setLayoutFlag action = do-  oldLay <- gets apLayoutStart-  modify (\s -> s { apMarkLayout = True } )-  let reset = modify (\s -> s { apMarkLayout = False-                              , apLayoutStart = oldLay })-  action <* reset---- -----------------------------------------------------------------------setNoPrecedingSpace :: Pretty a -> Pretty a-setNoPrecedingSpace action = do-  oldVal <- gets apNoPrecedingSpace-  modify (\s -> s { apNoPrecedingSpace = True } )-  let reset = modify (\s -> s { apNoPrecedingSpace = oldVal })-  action <* reset---- -----------------------------------------------------------------------setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty ()-setContextPretty ctxt lvl =-  local (\s -> s { prContext = setAcsWithLevel ctxt lvl (prContext s) } )--unsetContextPretty :: AstContext -> Pretty () -> Pretty ()-unsetContextPretty ctxt =-  local (\s -> s { prContext = unsetAcs ctxt (prContext s) } )---ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty ()-ifInContextPretty ctxt ifAction elseAction = do-  cur <- asks prContext-  let inContext = inAcs ctxt cur-  if inContext-    then prettyInterpret ifAction-    else prettyInterpret elseAction---- -----------------------------------------------------------------------annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty ()-annotationsToCommentsPretty _kws = return ()---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710-annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty ()-annotationsToCommentsBFPretty bf _kws = do-  -- cs <- gets apComments-  cs <- debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments-  -- return$ debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) ()-  -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf))-  let-    kws = makeBooleanFormulaAnns bf-    newComments = map (uncurry mkKWComment ) kws-  putUnallocatedComments (cs ++ newComments)---finalizeBFPretty :: GHC.SrcSpan -> Pretty ()-finalizeBFPretty _ss = do-  commentAllocation (const True) (mapM_ (uncurry addPrettyComment))-  return ()-#endif---- ----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710--- |Split the ordered list of comments into ones that occur prior to--- the give SrcSpan and the rest-priorComment :: Pos -> Comment -> Bool-priorComment start c = (ss2pos . commentIdentifier $ c) < start---- TODO:AZ: We scan the entire comment list here. It may be better to impose an--- invariant that the comments are sorted, and consume them as the pos--- advances. It then becomes a process of using `takeWhile p` rather than a full--- partition.-allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])-allocateComments = partition-#endif---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710-commentAllocation :: (Comment -> Bool)-                  -> ([(Comment, DeltaPos)] -> Pretty a)-                  -> Pretty a-commentAllocation p k = do-  cs <- getUnallocatedComments-  let (allocated,cs') = allocateComments p cs-  putUnallocatedComments cs'-  k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)--makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos)-makeDeltaComment c = do-  return (c, DP (0,1))--addPrettyComment :: Comment -> DeltaPos -> Pretty ()-addPrettyComment d p = do-  tellKd (AnnComment d, p)-#endif---- ------------------------------------------------------------------------- Writer helpers--tellFinalAnn :: (AnnKey, Annotation) -> Pretty ()-tellFinalAnn (k, v) =-  tell (mempty { dwAnns = Endo (Map.insert k v) })--tellCapturedSpan :: AnnKey -> Pretty ()-tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key })--tellKd :: (KeywordId, DeltaPos) -> Pretty ()-tellKd kd = tell (mempty { annKds = [kd] })--tellSortKey :: [GHC.SrcSpan] -> Pretty ()-tellSortKey xs = tell (mempty { sortKeys = Just xs } )--tellContext :: Set.Set AstContext -> Pretty ()-tellContext lc = tell (mempty { prLayoutContext = setAcsWithLevel lc 2 mempty} )
− src/Language/Haskell/GHC/ExactPrint/Print.hs 
@@ -1,546 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.GHC.ExactPrint.Print------ This module inverts the process performed by "Delta". Given 'Anns' and--- a corresponding AST we produce a source file based on this information.----------------------------------------------------------------------------------module Language.Haskell.GHC.ExactPrint.Print-        (-        exactPrint-        , exactPrintWithOptions--        -- * Configuration-        , PrintOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint)-        , stringOptions-        , printOptions--        ) where--import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Utils-import Language.Haskell.GHC.ExactPrint.Annotate-import Language.Haskell.GHC.ExactPrint.Lookup--import Control.Monad.Identity-import Control.Monad.RWS-import Control.Monad.Trans.Free-import Data.Data (Data)-import Data.List (sortBy, elemIndex)-import Data.Maybe (fromMaybe)-import Data.Ord (comparing)--import qualified Data.Set as Set--import qualified GHC--{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Redundant do" #-}-{-# ANN module "HLint: ignore Reduce duplication" #-}--- ------------------------------------------------------------------------ Printing of source elements---- | Print an AST with a map of potential modified `Anns`. The usual way to--- generate such a map is by using one of the parsers in--- "Language.Haskell.GHC.ExactPrint.Parsers".-exactPrint :: Annotate ast-                     => GHC.Located ast-                     -> Anns-                     -> String-exactPrint ast as = runIdentity (exactPrintWithOptions stringOptions ast as)---- | The additional option to specify the rigidity and printing--- configuration.-exactPrintWithOptions :: (Annotate ast, Monoid b, Monad m)-                      => PrintOptions m b-                      -> GHC.Located ast-                      -> Anns-                      -> m b-exactPrintWithOptions r ast as =-    runEP r (annotate ast) as----------------------------------------------------------- The EP monad and basic combinators--data PrintOptions m a = PrintOptions-            {-              epAnn :: !Annotation-            , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a-            , epTokenPrint :: String -> m a-            , epWhitespacePrint :: String -> m a-            , epRigidity :: Rigidity-            , epContext :: !AstContextSet-            }---- | Helper to create a 'PrintOptions'-printOptions ::-      (forall ast . Data ast => GHC.Located ast -> a -> m a)-      -> (String -> m a)-      -> (String -> m a)-      -> Rigidity-      -> PrintOptions m a-printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions-             {-               epAnn = annNone-             , epAstPrint = astPrint-             , epWhitespacePrint = wsPrint-             , epTokenPrint = tokenPrint-             , epRigidity = rigidity-             , epContext = defaultACS-             }---- | Options which can be used to print as a normal String.-stringOptions :: PrintOptions Identity String-stringOptions = printOptions (\_ b -> return b) return return NormalLayout--data EPWriter a = EPWriter-              { output :: !a }--#if __GLASGOW_HASKELL__ >= 804-instance Monoid w => Semigroup (EPWriter w) where-  (<>) = mappend-#endif--instance Monoid w => Monoid (EPWriter w) where-  mempty = EPWriter mempty-  (EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b)--data EPState = EPState-             { epPos    :: !Pos -- ^ Current output position-             , epAnns   :: !Anns-             , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local statE w mith suitable refactoring?-             , epMarkLayout :: Bool-             , epLHS :: LayoutStartCol-             }-------------------------------------------------------------type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a----runEP :: (Monad m, Monoid a)-      => PrintOptions m a-      -> Annotated () -> Anns -> m a-runEP epReader action ans =-  fmap (output . snd) .-    (\next -> execRWST next epReader-    (defaultEPState ans))-  . printInterpret $ action---- -----------------------------------------------------------------------defaultEPState :: Anns -> EPState-defaultEPState as = EPState-             { epPos    = (1,1)-             , epAnns   = as-             , epAnnKds = []-             , epLHS    = 1-             , epMarkLayout = False-             }----- -----------------------------------------------------------------------printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a-printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m)-  where-    go :: AnnotationF (EP w m a) -> EP w m a-    go (MarkEOF next) =-      printStringAtMaybeAnn (G GHC.AnnEofPos) (Just "") >> next-    go (MarkPrim kwid mstr next) =-      markPrim (G kwid) mstr >> next-    go (MarkPPOptional kwid mstr next) =-      markPrim (G kwid) mstr >> next-#if __GLASGOW_HASKELL__ >= 800-    go (MarkInstead _ kwid next) =-      printStringAtMaybeAnnAll kwid Nothing  >> next-#endif-    go (MarkOutside _ kwid next) =-      printStringAtMaybeAnnAll kwid Nothing  >> next-    go (MarkInside akwid next) =-      allAnns akwid >> next-    go (MarkMany akwid next) =-      allAnns akwid >> next-    go (MarkManyOptional akwid next) =-      allAnns akwid >> next-    go (MarkOffsetPrim kwid _ mstr next) =-      printStringAtMaybeAnn (G kwid) mstr >> next-    go (MarkOffsetPrimOptional kwid _ mstr next) =-      printStringAtMaybeAnn (G kwid) mstr >> next-    go (WithAST lss action next) =-      exactPC lss (printInterpret action) >> next-    go (CountAnns kwid next) =-      countAnnsEP (G kwid) >>= next-    go (SetLayoutFlag r action next) = do-      rigidity <- asks epRigidity-      (if r <= rigidity then setLayout else id) (printInterpret action)-      next--    go (MarkAnnBeforeAnn ann1 ann2 next) = printMarkAnnBeforeAnn (G ann1) (G ann2) >> next-    go (MarkExternal _ akwid s next) =-      printStringAtMaybeAnn (G akwid) (Just s) >> next-    go (StoreOriginalSrcSpan _ _ next) = storeOriginalSrcSpanPrint >>= next-    go (GetSrcSpanForKw _ _ next) = return GHC.noSrcSpan >>= next-#if __GLASGOW_HASKELL__ <= 710-    go (StoreString _ _ next) =-      printStoredString >> next-#endif-    go (AnnotationsToComments     _ next) = next-#if __GLASGOW_HASKELL__ <= 710-    go (AnnotationsToCommentsBF _ _ next) = next-    go (FinalizeBF _ next)                = next-#endif-    go (WithSortKey             ks next) = withSortKey             ks >> next-    go (WithSortKeyContexts ctx ks next) = withSortKeyContexts ctx ks >> next--    go (SetContextLevel ctxt lvl       action next) = setContextPrint ctxt lvl (printInterpret action) >> next-    go (UnsetContext   _ctxt           action next) = printInterpret action >> next-    go (IfInContext  ctxt ifAction elseAction next) = ifInContextPrint ctxt ifAction elseAction >> next-    go (TellContext _ next)                  = next-----------------------------------------------------------------------------storeOriginalSrcSpanPrint :: (Monad m, Monoid w) => EP w m AnnKey-storeOriginalSrcSpanPrint = do-  Ann{..} <- asks epAnn-  case annCapturedSpan of-    Nothing -> error "Missing captured SrcSpan"-    Just v  -> return v--#if __GLASGOW_HASKELL__ <= 710-printStoredString :: (Monad m, Monoid w) => EP w m ()-printStoredString = do-  kd <- gets epAnnKds--  let-    isAnnString (AnnString _,_) = True-    isAnnString _             = False--  case filter isAnnString (ghead "printStoredString" kd) of-    ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) (Just ss)-    _                    -> return ()-#endif--withSortKey :: (Monad m, Monoid w) => [(GHC.SrcSpan, Annotated ())] -> EP w m ()-withSortKey xs = do-  Ann{..} <- asks epAnn-  let ordered = case annSortKey of-                  Nothing   -> xs-                  Just keys -> orderByKey xs keys-                                `debug` ("withSortKey:" ++-                                         showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),-                                                 map fst xs,-                                                 keys)-                                         )-  mapM_ (printInterpret . snd) ordered--withSortKeyContexts :: (Monad m, Monoid w) => ListContexts -> [(GHC.SrcSpan, Annotated ())] -> EP w m ()-withSortKeyContexts ctxts xs = do-  Ann{..} <- asks epAnn-  let ordered = case annSortKey of-                  Nothing   -> xs-                  Just keys -> orderByKey xs keys-                                `debug` ("withSortKey:" ++-                                         showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),-                                                 map fst xs,-                                                 keys)-                                         )-  -- mapM_ printInterpret ordered-  withSortKeyContextsHelper printInterpret ctxts ordered---- -----------------------------------------------------------------------setContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Int -> EP w m () -> EP w m ()-setContextPrint ctxt lvl =-  local (\s -> s { epContext = setAcsWithLevel ctxt lvl (epContext s) } )--ifInContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Annotated () -> Annotated () -> EP w m ()-ifInContextPrint ctxt ifAction elseAction = do-  cur <- asks epContext-  let inContext = inAcs ctxt cur-  if inContext-    then printInterpret ifAction-    else printInterpret elseAction---- -----------------------------------------------------------------------allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m ()-allAnns kwid = printStringAtMaybeAnnAll (G kwid) Nothing------------------------------------------------------------------------------ |First move to the given location, then call exactP-exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a-exactPC ast action =-    do-      return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))-      ma <- getAndRemoveAnnotation ast-      let an@Ann{ annEntryDelta=edp-                , annPriorComments=comments-                , annFollowingComments=fcomments-                , annsDP=kds-                } = fromMaybe annNone ma-      PrintOptions{epAstPrint} <- ask-      r <- withContext kds an-       (mapM_ (uncurry printQueuedComment) comments-       >> advance edp-       >> censorM (epAstPrint ast) action-       <* mapM_ (uncurry printQueuedComment) fcomments)-      return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast))--censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a-censorM f m = passM (liftM (\x -> (x,f)) m)--passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a-passM m = RWST $ \r s -> do-      ~((a, f),s', EPWriter w) <- runRWST m r s-      w' <- f w-      return (a, s', EPWriter w')--advance :: (Monad m, Monoid w) => DeltaPos -> EP w m ()-advance cl = do-  p <- getPos-  colOffset <- getLayoutOffset-  printWhitespace (undelta p cl colOffset)--getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation)-getAndRemoveAnnotation a = gets (getAnnotationEP a . epAnns)--markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()-markPrim kwid mstr =-  printStringAtMaybeAnn kwid mstr--withContext :: (Monad m, Monoid w)-            => [(KeywordId, DeltaPos)]-            -> Annotation-            -> EP w m a -> EP w m a-withContext kds an x = withKds kds (withOffset an x)---- --------------------------------------------------------------------------- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous--- offset----withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a)-withOffset a =-  local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) })----- --------------------------------------------------------------------------- Necessary as there are destructive gets of Kds across scopes-withKds :: (Monad m, Monoid w) => [(KeywordId, DeltaPos)] -> EP w m a -> EP w m a-withKds kd action = do-  modify (\s -> s { epAnnKds = kd : epAnnKds s })-  r <- action-  modify (\s -> s { epAnnKds = tail (epAnnKds s) })-  return r----------------------------------------------------------------------------setLayout :: (Monad m, Monoid w) => EP w m () -> EP w m ()-setLayout k = do-  oldLHS <- gets epLHS-  modify (\a -> a { epMarkLayout = True } )-  let reset = modify (\a -> a { epMarkLayout = False-                              , epLHS = oldLHS } )-  k <* reset--getPos :: (Monad m, Monoid w) => EP w m Pos-getPos = gets epPos--setPos :: (Monad m, Monoid w) => Pos -> EP w m ()-setPos l = modify (\s -> s {epPos = l})---- |Get the current column offset-getLayoutOffset :: (Monad m, Monoid w) => EP w m LayoutStartCol-getLayoutOffset = gets epLHS---- ------------------------------------------------------------------------- |If the first annotation has a smaller SrcSpan than the second, then mark it.--- In the printer this means the first appearing before the second in the list--- of annotations remaining-printMarkAnnBeforeAnn :: (Monad m, Monoid w) => KeywordId -> KeywordId -> EP w m ()-printMarkAnnBeforeAnn annBefore annAfter = do-  kd <- gets epAnnKds-  case kd of-    []    -> return () -- Should never be triggered-    (k:_kds) -> do-      -- find the first ann, then the second. If found in that order, annotate.-      let find a = (\(kw,_) -> kw == a)-      case break (find annBefore) k of-        (_,[]) -> return () -- annBefore not present-        (_,rest) -> if null (snd $ break (find annAfter) rest)-                      then return ()-                      else markPrim annBefore (Nothing)---- -----------------------------------------------------------------------printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()-printStringAtMaybeAnn an mstr = printStringAtMaybeAnnThen an mstr (return ())--printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()-printStringAtMaybeAnnAll an mstr = go-  where-    go = printStringAtMaybeAnnThen an mstr go--printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -> EP w m ()-printStringAtMaybeAnnThen an mstr next = do-  let str = fromMaybe (keywordToString an) mstr-  annFinal <- getAnnFinal an-  case (annFinal, an) of-#if __GLASGOW_HASKELL__ <= 710-    -- Could be unicode syntax-    -- TODO: This is a bit fishy, refactor-    (Nothing, G kw) -> do-      res <- getAnnFinal (AnnUnicode kw)-      return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res))-      unless (null res) $ do-        forM_-          res-          (\(comments, ma) -> printStringAtLsDelta comments ma (unicodeString (G kw)))-        next-#else-    -- Could be unicode syntax-    -- TODO: This is a bit fishy, refactor-    (Nothing, G kw') -> do-      let kw = GHC.unicodeAnn kw'-      let str' = fromMaybe (keywordToString (G kw)) mstr-      res <- getAnnFinal (G kw)-      return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res))-      unless (null res) $ do-        forM_-          res-          (\(comments, ma) -> printStringAtLsDelta comments ma str')-        next-#endif-    (Just (comments, ma),_) -> printStringAtLsDelta comments ma str >> next-    (Nothing, _) -> return () `debug` ("printStringAtMaybeAnn:missed:(an)" ++ show an)-                    -- Note: do not call next, nothing to chain-    -- ++AZ++: Enabling the following line causes a very weird error associated with AnnPackageName. I suspect it is because it is forcing the evaluation of a non-existent an or str-    -- `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str))---- ------------------------------------------------------------------------- |destructive get, hence use an annotation once only-getAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe ([(Comment, DeltaPos)], DeltaPos))-getAnnFinal kw = do-  kd <- gets epAnnKds-  case kd of-    []    -> return Nothing -- Should never be triggered-    (k:kds) -> do-      let (res, kd') = destructiveGetFirst kw ([],k)-      modify (\s -> s { epAnnKds = kd' : kds })-      return res---- | Get and remove the first item in the (k,v) list for which the k matches.--- Return the value, together with any comments skipped over to get there.-destructiveGetFirst :: KeywordId-                    -> ([(KeywordId, v)],[(KeywordId,v)])-                    -> (Maybe ([(Comment, v)], v),[(KeywordId,v)])-destructiveGetFirst _key (acc,[]) = (Nothing, acc)-destructiveGetFirst  key (acc, (k,v):kvs )-  | k == key = (Just (skippedComments, v), others ++ kvs)-  | otherwise = destructiveGetFirst key (acc ++ [(k,v)], kvs)-  where-    (skippedComments, others) = foldr comments ([], []) acc-    comments (AnnComment comment , dp ) (cs, kws) = ((comment, dp) : cs, kws)-    comments kw (cs, kws)                        = (cs, kw : kws)----- ------------------------------------------------------------------------- |This should be the final point where things are mode concrete,--- before output. Hence the point where comments can be inserted-printStringAtLsDelta :: (Monad m, Monoid w) => [(Comment, DeltaPos)] -> DeltaPos -> String -> EP w m ()-printStringAtLsDelta cs cl s = do-  p <- getPos-  colOffset <- getLayoutOffset-  if isGoodDeltaWithOffset cl colOffset-    then do-      mapM_ (uncurry printQueuedComment) cs-      printStringAt (undelta p cl colOffset) s-        `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))-    else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s))---isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool-isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset))--printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()-printQueuedComment Comment{commentContents} dp = do-  p <- getPos-  colOffset <- getLayoutOffset-  let (dr,dc) = undelta (0,0) dp colOffset-  -- do not lose comments against the left margin-  when (isGoodDelta (DP (dr,max 0 dc))) $-    printCommentAt (undelta p dp colOffset) commentContents---- ------------------------------------------------------------------------- |non-destructive get-peekAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe DeltaPos)-peekAnnFinal kw = do-  (r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (ghead "peekAnnFinal" . epAnnKds)-  return (snd <$> r)--countAnnsEP :: (Monad m, Monoid w) => KeywordId -> EP w m Int-countAnnsEP an = length <$> peekAnnFinal an---- -------------------------------------------------------------------------- ------------------------------------------------------------------------ Printing functions--printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()-printString layout str = do-  EPState{epPos = (_,c), epMarkLayout} <- get-  PrintOptions{epTokenPrint, epWhitespacePrint} <- ask-  when (epMarkLayout && layout) $-    modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } )--  -- Advance position, taking care of any newlines in the string-  let strDP@(DP (cr,_cc)) = dpFromString str-  p <- getPos-  colOffset <- getLayoutOffset-  if cr == 0-    then setPos (undelta p strDP colOffset)-    else setPos (undelta p strDP 1)--  ---  if not layout && c == 0-    then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s}-    else lift (epTokenPrint      str) >>= \s -> tell EPWriter { output = s}---newLine :: (Monad m, Monoid w) => EP w m ()-newLine = do-    (l,_) <- getPos-    printString False "\n"-    setPos (l+1,1)--padUntil :: (Monad m, Monoid w) => Pos -> EP w m ()-padUntil (l,c) = do-    (l1,c1) <- getPos-    if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' '-       | l1 < l             -> newLine >> padUntil (l,c)-       | otherwise          -> return ()--printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m ()-printWhitespace = padUntil--printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()-printCommentAt p str = printWhitespace p >> printString False str--printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()-printStringAt p str = printWhitespace p >> printString True str
src/Language/Haskell/GHC/ExactPrint/Transform.hs view
@@ -1,1337 +1,1183 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.GHC.ExactPrint.Transform------ This module is currently under heavy development, and no promises are made--- about API stability. Use with care.------ We welcome any feedback / contributions on this, as it is the main point of--- the library.----------------------------------------------------------------------------------module Language.Haskell.GHC.ExactPrint.Transform-        (-        -- * The Transform Monad-          Transform-        , TransformT(..)-        , runTransform-        , runTransformFrom-        , runTransformFromT--        -- * Transform monad operations-        , logTr-        , logDataWithAnnsTr-        , getAnnsT, putAnnsT, modifyAnnsT-        , uniqueSrcSpanT--        , cloneT-        , graftT--        , getEntryDPT-        , setEntryDPT-        , transferEntryDPT-        , setPrecedingLinesDeclT-        , setPrecedingLinesT-        , addSimpleAnnT-        , addTrailingCommaT-        , removeTrailingCommaT--        -- ** Managing declarations, in Transform monad-        , HasTransform (..)-        , HasDecls (..)-        , hasDeclsSybTransform-        , hsDeclsGeneric-        , hsDeclsPatBind, hsDeclsPatBindD-        , replaceDeclsPatBind, replaceDeclsPatBindD-        , modifyDeclsT-        , modifyValD-        -- *** Utility, does not manage layout-        , hsDeclsValBinds, replaceDeclsValbinds--        -- ** Managing lists, Transform monad-        , insertAtStart-        , insertAtEnd-        , insertAfter-        , insertBefore--        -- *** Low level operations used in 'HasDecls'-        , balanceComments-        , balanceTrailingComments-        , moveTrailingComments--        -- ** Managing lists, pure functions-        , captureOrder-        , captureOrderAnnKey--        -- * Operations-        , isUniqueSrcSpan--        -- * Pure functions-        , mergeAnns-        , mergeAnnList-        , setPrecedingLinesDecl-        , setPrecedingLines-        , getEntryDP-        , setEntryDP-        , transferEntryDP-        , addTrailingComma-        , wrapSig, wrapDecl-        , decl2Sig, decl2Bind--        ) where--import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Utils--#if __GLASGOW_HASKELL__ > 804-import Control.Monad.Fail-#endif-import Control.Monad.RWS---import qualified Bag           as GHC-import qualified FastString    as GHC-import qualified GHC           as GHC hiding (parseModule)--import qualified Data.Generics as SYB--import Data.Data-import Data.List-import Data.Maybe--import qualified Data.Map as Map--import Data.Functor.Identity-import Control.Monad.State-import Control.Monad.Writer---- import Debug.Trace----------------------------------------------------------------------------------- Transformation of source elements---- | Monad type for updating the AST and managing the annotations at the same--- time. The W state is used to generate logging information if required.-type Transform = TransformT Identity---- |Monad transformer version of 'Transform' monad-newtype TransformT m a = TransformT { runTransformT :: RWST () [String] (Anns,Int) m a }-                deriving (Monad,Applicative,Functor-                         ,MonadReader ()-                         ,MonadWriter [String]-                         ,MonadState (Anns,Int)-                         ,MonadTrans-#if __GLASGOW_HASKELL__ > 804-                         ,MonadFail-#endif-                         )--#if __GLASGOW_HASKELL__ > 804-instance MonadFail Identity where-  fail x = Control.Monad.Fail.fail x-#endif---- | Run a transformation in the 'Transform' monad, returning the updated--- annotations and any logging generated via 'logTr'-runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])-runTransform ans f = runTransformFrom 0 ans f---- | Run a transformation in the 'Transform' monad, returning the updated--- annotations and any logging generated via 'logTr', allocating any new--- SrcSpans from the provided initial value.-runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String])-runTransformFrom seed ans f = runRWS (runTransformT f) () (ans,seed)---- |Run a monad transformer stack for the 'TransformT' monad transformer-runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])-runTransformFromT seed ans f = runRWST (runTransformT f) () (ans,seed)---- |Log a string to the output of the Monad-logTr :: (Monad m) => String -> TransformT m ()-logTr str = tell [str]---- |Log a representation of the given AST with annotations to the output of the--- Monad-logDataWithAnnsTr :: (Monad m) => (SYB.Data a) => String -> a -> TransformT m ()-logDataWithAnnsTr str ast = do-  anns <- getAnnsT-  logTr $ str ++ showAnnData anns 0 ast---- |Access the 'Anns' being modified in this transformation-getAnnsT :: (Monad m) => TransformT m Anns-getAnnsT = gets fst---- |Replace the 'Anns' after any changes-putAnnsT :: (Monad m) => Anns -> TransformT m ()-putAnnsT ans = do-  (_,col) <- get-  put (ans,col)---- |Change the stored 'Anns'-modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m ()-modifyAnnsT f = do-  ans <- getAnnsT-  putAnnsT (f ans)---- ------------------------------------------------------------------------- |Once we have 'Anns', a 'GHC.SrcSpan' is used purely as part of an 'AnnKey'--- to index into the 'Anns'. If we need to add new elements to the AST, they--- need their own 'GHC.SrcSpan' for this.-uniqueSrcSpanT :: (Monad m) => TransformT m GHC.SrcSpan-uniqueSrcSpanT = do-  (an,col) <- get-  put (an,col + 1 )-  let pos = GHC.mkSrcLoc (GHC.mkFastString "ghc-exactprint") (-1) col-  return $ GHC.mkSrcSpan pos pos---- |Test whether a given 'GHC.SrcSpan' was generated by 'uniqueSrcSpanT'-isUniqueSrcSpan :: GHC.SrcSpan -> Bool-isUniqueSrcSpan ss = srcSpanStartLine ss == -1---- ------------------------------------------------------------------------ |Make a copy of an AST element, replacing the existing SrcSpans with new--- ones, and duplicating the matching annotations.-cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(GHC.SrcSpan, GHC.SrcSpan)])-cloneT ast = do-  runWriterT $ SYB.everywhereM (return `SYB.ext2M` replaceLocated) ast-  where-    replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m)-                    => (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] (TransformT m) (GHC.GenLocated loc a)-    replaceLocated (GHC.L l t) = do-      case cast l :: Maybe GHC.SrcSpan of-        Just ss -> do-          newSpan <- lift uniqueSrcSpanT-          lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) anns of-                                  Nothing -> anns-                                  Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns)-          tell [(ss, newSpan)]-          return $ fromJust . cast  $ GHC.L newSpan t-        Nothing -> return (GHC.L l t)---- ------------------------------------------------------------------------ |Slightly more general form of cloneT-graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a-graftT origAnns = SYB.everywhereM (return `SYB.ext2M` replaceLocated)-  where-    replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m)-                    => GHC.GenLocated loc a -> TransformT m (GHC.GenLocated loc a)-    replaceLocated (GHC.L l t) = do-      case cast l :: Maybe GHC.SrcSpan of-        Just ss -> do-          newSpan <- uniqueSrcSpanT-          modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) origAnns of-                                  Nothing -> anns-                                  Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns)-          return $ fromJust $ cast $ GHC.L newSpan t-        Nothing -> return (GHC.L l t)---- ------------------------------------------------------------------------- |If a list has been re-ordered or had items added, capture the new order in--- the appropriate 'annSortKey' attached to the 'Annotation' for the first--- parameter.-captureOrder :: (Data a) => GHC.Located a -> [GHC.Located b] -> Anns -> Anns-captureOrder parent ls ans = captureOrderAnnKey (mkAnnKey parent) ls ans---- |If a list has been re-ordered or had items added, capture the new order in--- the appropriate 'annSortKey' item of the supplied 'AnnKey'-captureOrderAnnKey :: AnnKey -> [GHC.Located b] -> Anns -> Anns-captureOrderAnnKey parentKey ls ans = ans'-  where-    newList = map GHC.getLoc ls-    reList = Map.adjust (\an -> an {annSortKey = Just newList }) parentKey-    ans' = reList ans---- ------------------------------------------------------------------------- |Pure function to convert a 'GHC.LHsDecl' 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'-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---- ------------------------------------------------------------------------- |Create a simple 'Annotation' without comments, and attach it to the first--- parameter.-addSimpleAnnT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()-addSimpleAnnT ast dp kds = do-  let ann = annNone { annEntryDelta = dp-                    , annsDP = kds-                    }-  modifyAnnsT (Map.insert (mkAnnKey ast) ann)---- ------------------------------------------------------------------------- |Add a trailing comma annotation, unless there is already one-addTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m ()-addTrailingCommaT ast = do-  modifyAnnsT (addTrailingComma ast (DP (0,0)))---- ------------------------------------------------------------------------- |Remove a trailing comma annotation, if there is one one-removeTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m ()-removeTrailingCommaT ast = do-  modifyAnnsT (removeTrailingComma ast)---- ------------------------------------------------------------------------- |'Transform' monad version of 'getEntryDP'-getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos-getEntryDPT ast = do-  anns <- getAnnsT-  return (getEntryDP anns ast)---- ------------------------------------------------------------------------- |'Transform' monad version of 'getEntryDP'-setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m ()-setEntryDPT ast dp = do-  modifyAnnsT (setEntryDP ast dp)---- ------------------------------------------------------------------------- |'Transform' monad version of 'transferEntryDP'-transferEntryDPT :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m ()-transferEntryDPT a b =-  modifyAnnsT (transferEntryDP a b)---- ------------------------------------------------------------------------- |'Transform' monad version of 'setPrecedingLinesDecl'-setPrecedingLinesDeclT :: (Monad m) => GHC.LHsDecl GhcPs -> Int -> Int -> TransformT m ()-setPrecedingLinesDeclT ld n c =-  modifyAnnsT (setPrecedingLinesDecl ld n c)---- ------------------------------------------------------------------------- |'Transform' monad version of 'setPrecedingLines'-setPrecedingLinesT ::  (SYB.Data a,Monad m) => GHC.Located a -> Int -> Int -> TransformT m ()-setPrecedingLinesT ld n c =-  modifyAnnsT (setPrecedingLines ld n c)---- ------------------------------------------------------------------------- | Left bias pair union-mergeAnns :: Anns -> Anns -> Anns-mergeAnns-  = Map.union---- |Combine a list of annotations-mergeAnnList :: [Anns] -> Anns-mergeAnnList [] = error "mergeAnnList must have at lease one entry"-mergeAnnList (x:xs) = foldr mergeAnns x xs---- ------------------------------------------------------------------------- |Unwrap a HsDecl and call setPrecedingLines on it--- ++AZ++ TODO: get rid of this, it is a synonym only-setPrecedingLinesDecl :: GHC.LHsDecl GhcPs -> Int -> Int -> Anns -> Anns-setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans---- ------------------------------------------------------------------------- | Adjust the entry annotations to provide an `n` line preceding gap-setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns-setPrecedingLines ast n c anne = setEntryDP ast (DP (n,c)) anne---- ------------------------------------------------------------------------- |Return the true entry 'DeltaPos' from the annotation for a given AST--- element. This is the 'DeltaPos' ignoring any comments.-getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos-getEntryDP anns ast =-  case Map.lookup (mkAnnKey ast) anns of-    Nothing  -> DP (0,0)-    Just ann -> annTrueEntryDelta ann---- ------------------------------------------------------------------------- |Set the true entry 'DeltaPos' from the annotation for a given AST--- element. This is the 'DeltaPos' ignoring any comments.-setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns-setEntryDP ast dp anns =-  case Map.lookup (mkAnnKey ast) anns of-    Nothing  -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns-    Just ann -> Map.insert (mkAnnKey ast) (ann'    { annEntryDelta = annCommentEntryDelta ann' dp}) anns-      where-        ann' = setCommentEntryDP ann dp---- ------------------------------------------------------------------------- |When setting an entryDP, the leading comment needs to be adjusted too-setCommentEntryDP :: Annotation -> DeltaPos -> Annotation--- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann'-setCommentEntryDP ann dp = ann'-  where-    ann' = case (annPriorComments ann) of-      [] -> ann-      [(pc,_)]     -> ann { annPriorComments = [(pc,dp)] }-      ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) }---- ------------------------------------------------------------------------- |Take the annEntryDelta associated with the first item and associate it with the second.--- Also transfer any comments occuring before it.-transferEntryDP :: (SYB.Data a, SYB.Data b) => GHC.Located a -> GHC.Located b -> Anns -> Anns-transferEntryDP a b anns = (const anns2) anns-  where-    maybeAnns = do -- Maybe monad-      anA <- Map.lookup (mkAnnKey a) anns-      anB <- Map.lookup (mkAnnKey b) anns-      let anB'  = Ann-            { annEntryDelta        = DP (0,0) -- Need to adjust for comments after-            , annPriorComments     = annPriorComments     anB-            , annFollowingComments = annFollowingComments anB-            , annsDP               = annsDP          anB-            , annSortKey           = annSortKey      anB-            , annCapturedSpan      = annCapturedSpan anB-            }-      return ((Map.insert (mkAnnKey b) anB' anns),annLeadingCommentEntryDelta anA)-    (anns',dp) = fromMaybe-                  (error $ "transferEntryDP: lookup failed (a,b)=" ++ show (mkAnnKey a,mkAnnKey b))-                  maybeAnns-    anns2 = setEntryDP b dp anns'---- -----------------------------------------------------------------------addTrailingComma :: (SYB.Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns-addTrailingComma a dp anns =-  case Map.lookup (mkAnnKey a) anns of-    Nothing -> anns-    Just an ->-      case find isAnnComma (annsDP an) of-        Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G GHC.AnnComma,dp)]}) anns-        Just _  -> anns-      where-        isAnnComma (G GHC.AnnComma,_) = True-        isAnnComma _                  = False---- -----------------------------------------------------------------------removeTrailingComma :: (SYB.Data a) => GHC.Located a -> Anns -> Anns-removeTrailingComma a anns =-  case Map.lookup (mkAnnKey a) anns of-    Nothing -> anns-    Just an ->-      case find isAnnComma (annsDP an) of-        Nothing -> anns-        Just _  -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns-      where-        isAnnComma (G GHC.AnnComma,_) = True-        isAnnComma _                  = False---- ------------------------------------------------------------------------- |The relatavise phase puts all comments appearing between the end of one AST--- item and the beginning of the next as 'annPriorComments' for the second one.--- This function takes two adjacent AST items and moves any 'annPriorComments'--- from the second one to the 'annFollowingComments' of the first if they belong--- to it instead. This is typically required before deleting or duplicating--- either of the AST elements.-balanceComments :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m ()-balanceComments first second = do-  -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM-  -- logTr $ "balanceComments entered"-  -- logDataWithAnnsTr "first" first-  case cast first :: Maybe (GHC.LHsDecl GhcPs) of-#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-        balanceCommentsFB fb' second-      _ -> balanceComments' first second---- |Prior to moving an AST element, make sure any trailing comments belonging to--- it are attached to it, and not the following element. Of necessity this is a--- heuristic process, to be tuned later. Possibly a variant should be provided--- with a passed-in decision function.-balanceComments' :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m ()-balanceComments' first second = do-  let-    k1 = mkAnnKey first-    k2 = mkAnnKey second-    moveComments p ans = ans'-      where-        an1 = gfromJust "balanceComments' k1" $ Map.lookup k1 ans-        an2 = gfromJust "balanceComments' k2" $ Map.lookup k2 ans-        cs1f = annFollowingComments an1-        cs2b = annPriorComments an2-        (move,stay) = break p cs2b-        an1' = an1 { annFollowingComments = cs1f ++ move}-        an2' = an2 { annPriorComments = stay}-        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans--    simpleBreak (_,DP (r,_c)) = r > 0--  modifyAnnsT (moveComments simpleBreak)---- |Once 'balanceComments' has been called to move trailing comments to a--- '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__ > 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-balanceCommentsFB f s = balanceComments' f s---- -------------------------------------------------------------------------- |After moving an AST element, make sure any comments that may belong--- with the following element in fact do. Of necessity this is a heuristic--- process, to be tuned later. Possibly a variant should be provided with a--- passed-in decision function.-balanceTrailingComments :: (Monad m) => (Data a,Data b) => GHC.Located a -> GHC.Located b-                        -> TransformT m [(Comment, DeltaPos)]-balanceTrailingComments first second = do-  let-    k1 = mkAnnKey first-    k2 = mkAnnKey second-    moveComments p ans = (ans',move)-      where-        an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans-        an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans-        cs1f = annFollowingComments an1-        (move,stay) = break p cs1f-        an1' = an1 { annFollowingComments = stay }-        ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans--    simpleBreak (_,DP (r,_c)) = r > 0--  ans <- getAnnsT-  let (ans',mov) = moveComments simpleBreak ans-  putAnnsT ans'-  return mov---- ------------------------------------------------------------------------- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for--- |Move any 'annFollowingComments' values from the 'Annotation' associated to--- the first parameter to that of the second.-moveTrailingComments :: (Data a,Data b)-                     => GHC.Located a -> GHC.Located b -> Transform ()-moveTrailingComments first second = do-  let-    k1 = mkAnnKey first-    k2 = mkAnnKey second-    moveComments ans = ans'-      where-        an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans-        an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans-        cs1f = annFollowingComments an1-        cs2f = annFollowingComments an2-        an1' = an1 { annFollowingComments = [] }-        an2' = an2 { annFollowingComments = cs1f ++ cs2f }-        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans--  modifyAnnsT moveComments---- ------------------------------------------------------------------------- |Insert a declaration into an AST element having sub-declarations--- (@HasDecls@) according to the given location function.-insertAt :: (HasDecls (GHC.Located ast))-              => (GHC.LHsDecl GhcPs-                  -> [GHC.LHsDecl GhcPs]-                  -> [GHC.LHsDecl GhcPs])-              -> GHC.Located ast-              -> GHC.LHsDecl GhcPs-              -> Transform (GHC.Located ast)-insertAt f t decl = do-  oldDecls <- hsDecls t-  replaceDecls t (f decl oldDecls)---- |Insert a declaration at the beginning or end of the subdecls of the given--- AST item-insertAtStart, insertAtEnd :: (HasDecls (GHC.Located ast))-              => GHC.Located ast-              -> GHC.LHsDecl GhcPs-              -> Transform (GHC.Located ast)--insertAtStart = insertAt (:)-insertAtEnd   = insertAt (\x xs -> xs ++ [x])---- |Insert a declaration at a specific location in the subdecls of the given--- AST item-insertAfter, insertBefore :: (HasDecls (GHC.Located ast))-                          => GHC.Located old-                          -> GHC.Located ast-                          -> GHC.LHsDecl GhcPs-                          -> Transform (GHC.Located ast)-insertAfter (GHC.getLoc -> k) = insertAt findAfter-  where-    findAfter x xs =-      let (fs, b:bs) = span (\(GHC.L l _) -> l /= k) xs-      in fs ++ (b : x : bs)-insertBefore (GHC.getLoc -> k) = insertAt findBefore-  where-    findBefore x xs =-      let (fs, bs) = span (\(GHC.L l _) -> l /= k) xs-      in fs ++ (x : bs)---- =====================================================================--- start of HasDecls instances--- =====================================================================---- |Provide a means to get and process the immediate child declartions of a--- given AST element.-class (Data t) => HasDecls t where--- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent--    -- | Return the 'GHC.HsDecl's that are directly enclosed in the-    -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl'-    -- form, even if orginating in local decls. This is safe, as annotations-    -- never attach to the wrapper, only to the wrapped item.-    hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs]--    -- | Replace the directly enclosed decl list by the given-    --  decl list. Runs in the 'Transform' monad to be able to update list order-    --  annotations, and rebalance comments and other layout changes as needed.-    ---    -- For example, a call on replaceDecls for a wrapped 'GHC.FunBind' having no-    -- where clause will convert-    ---    -- @-    -- -- |This is a function-    -- foo = x -- comment1-    -- @-    -- in to-    ---    -- @-    -- -- |This is a function-    -- foo = x -- comment1-    --   where-    --     nn = 2-    -- @-    replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GhcPs] -> TransformT m t---- -----------------------------------------------------------------------instance HasDecls GHC.ParsedSource where-  hsDecls (GHC.L _ (GHC.HsModule _mn _exps _imps decls _ _)) = return decls-  replaceDecls m@(GHC.L l (GHC.HsModule mn exps imps _decls deps haddocks)) decls-    = do-        logTr "replaceDecls LHsModule"-        modifyAnnsT (captureOrder m decls)-        return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks))---- -----------------------------------------------------------------------instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where-#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-#elif __GLASGOW_HASKELL__ >= 710-  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do-#else-  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do-#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-  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))) []-#endif-    = do-        logTr "replaceDecls LMatch"-        let-          noWhere (G GHC.AnnWhere,_) = False-          noWhere _                  = True--          removeWhere mkds =-            case Map.lookup (mkAnnKey m) mkds of-              Nothing -> error "wtf"-              Just ann -> Map.insert (mkAnnKey m) ann1 mkds-                where-                  ann1 = ann { annsDP = filter noWhere (annsDP ann)-                                 }-        modifyAnnsT removeWhere--#if __GLASGOW_HASKELL__ <= 710-        binds' <- replaceDeclsValbinds binds []-#else-        binds'' <- replaceDeclsValbinds (GHC.unLoc binds) []-        let binds' = GHC.L (GHC.getLoc binds) binds''-#endif-#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 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-#endif-    = do-        logTr "replaceDecls LMatch"-        -- Need to throw in a fresh where clause if the binds were empty,-        -- in the annotations.-#if __GLASGOW_HASKELL__ <= 710-        case binds of-#else-        case GHC.unLoc binds of-#endif-#if __GLASGOW_HASKELL__ > 804-          GHC.EmptyLocalBinds{} -> do-#else-          GHC.EmptyLocalBinds -> do-#endif-            let-              addWhere mkds =-                case Map.lookup (mkAnnKey m) mkds of-                  Nothing -> error "wtf"-                  Just ann -> Map.insert (mkAnnKey m) ann1 mkds-                    where-                      ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]-                                 }-            modifyAnnsT addWhere-            modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4)--            -- only move the comment if the original where clause was empty.-            toMove <- balanceTrailingComments m m-            insertCommentBefore (mkAnnKey m) toMove (matchApiAnn GHC.AnnWhere)-          _ -> return ()--        modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds)-#if __GLASGOW_HASKELL__ <= 710-        binds' <- replaceDeclsValbinds binds newBinds-#else-        binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newBinds-        let binds' = GHC.L (GHC.getLoc binds) binds''-#endif-        -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'-#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__ > 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)-#if __GLASGOW_HASKELL__ <= 710-        decls' <- replaceDeclsValbinds decls newDecls-#else-        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---- ------------------------------------------------------------------------- | Extract the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This--- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent--- 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--- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent--- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is--- idempotent.-hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]-#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-hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x---- ----------------------------------------- | Replace the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This--- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent--- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is--- 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--- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent--- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is--- 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,-        -- in the annotations.-#if __GLASGOW_HASKELL__ <= 710-        case binds of-#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-                  Nothing -> error "wtf"-                  Just ann -> Map.insert (mkAnnKey p) ann1 mkds-                    where-                      ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]-                                 }-            modifyAnnsT addWhere-            modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4)--          _ -> return ()--        modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)-#if __GLASGOW_HASKELL__ <= 710-        binds' <- replaceDeclsValbinds binds newDecls-#else-        binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls-        let binds' = GHC.L (GHC.getLoc binds) binds''-#endif-#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__ > 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__ > 804-  hsDecls (GHC.L _ (GHC.LastStmt _ e _ _))    = hsDecls e-#elif __GLASGOW_HASKELL__ >= 804-  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e-#elif __GLASGOW_HASKELL__ > 800-  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e-#elif __GLASGOW_HASKELL__ > 710-  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e-#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-        lb' <- replaceDeclsValbinds lb newDecls-#else-        lb'' <- replaceDeclsValbinds (GHC.unLoc lb) newDecls-        let lb' = GHC.L (GHC.getLoc lb) lb''-#endif-#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 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__ > 804-  replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls-    = do-      e' <- replaceDecls e newDecls-      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---- =====================================================================--- end of HasDecls instances--- =====================================================================---- ------------------------------------------------------------------------- |Do a transformation on an AST fragment by providing a function to process--- the general case and one specific for a 'GHC.LHsBind'. This is required--- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot--- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.-hasDeclsSybTransform :: (SYB.Data t2,Monad m)-       => (forall t. HasDecls t => t -> m t)-             -- ^Worker function for the general case-       -> (GHC.LHsBind GhcPs -> m (GHC.LHsBind GhcPs))-             -- ^Worker function for FunBind/PatBind-       -> t2 -- ^Item to be updated-       -> m t2-hasDeclsSybTransform workerHasDecls workerBind t = trf t-  where-    trf = SYB.mkM   parsedSource-         `SYB.extM` lmatch-         `SYB.extM` lexpr-         `SYB.extM` lstmt-         `SYB.extM` lhsbind-         `SYB.extM` lvald--    parsedSource (p::GHC.ParsedSource) = workerHasDecls p--    lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs))-      = workerHasDecls lm--    lexpr (le::GHC.LHsExpr GhcPs)-      = workerHasDecls le--    lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs))-      = workerHasDecls d--    lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GhcPs)-      = workerBind b-    lhsbind b@(GHC.L _ GHC.PatBind{})-      = 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---- ------------------------------------------------------------------------- |A 'GHC.FunBind' wraps up one or more 'GHC.Match' items. 'hsDecls' cannot--- return anything for these as there is not meaningful 'replaceDecls' for it.--- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind'--- decls too, where they are needed for analysis only.-hsDeclsGeneric :: (SYB.Data t,Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs]-hsDeclsGeneric t = q t-  where-    q = return []-        `SYB.mkQ`  parsedSource-        `SYB.extQ` lmatch-        `SYB.extQ` lexpr-        `SYB.extQ` lstmt-        `SYB.extQ` lhsbind-        `SYB.extQ` lhsbindd-        `SYB.extQ` llocalbinds-        `SYB.extQ` localbinds--    parsedSource (p::GHC.ParsedSource) = hsDecls p--    lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) = hsDecls lm--    lexpr (le::GHC.LHsExpr GhcPs) = hsDecls le--    lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) = hsDecls d--    -- -----------------------------------    lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]-#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)-    lhsbind p@(GHC.L _ (GHC.PatBind{})) = do-      hsDeclsPatBind p-    lhsbind _ = return []--    -- -----------------------------------#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 []--    -- -----------------------------------    llocalbinds :: (Monad m) => GHC.Located (GHC.HsLocalBinds GhcPs) -> TransformT m [GHC.LHsDecl GhcPs]-    llocalbinds (GHC.L _ ds) = localbinds ds--    -- -----------------------------------    localbinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs]-    localbinds d = hsDeclsValBinds d---- ------------------------------------------------------------------------- |Look up the annotated order and sort the decls accordingly-orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GhcPs] -> TransformT m [GHC.LHsDecl GhcPs]-orderedDecls parent decls = do-  ans <- getAnnsT-  case getAnnotationEP parent ans of-    Nothing -> error $ "orderedDecls:no annotation for:" ++ showAnnData emptyAnns 0 parent-    Just ann -> case annSortKey ann of-      Nothing -> do-        return decls-      Just keys -> do-        let ds = map (\s -> (GHC.getLoc s,s)) decls-            ordered = map snd $ orderByKey ds keys-        return ordered---- ------------------------------------------------------------------------- | Utility function for extracting decls from 'GHC.HsLocalBinds'. Use with--- care, as this does not necessarily return the declarations in order, the--- ordering should be done by the calling function from the 'GHC.HsLocalBinds'--- 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)-        sds = map wrapSig sigs-      return (bds ++ sds)-    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--- ordering should be done by the calling function from the 'GHC.HsLocalBinds'--- context in the AST.-replaceDeclsValbinds :: (Monad m)-                     => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]-                     -> TransformT m (GHC.HsLocalBinds GhcPs)-replaceDeclsValbinds _ [] = do-#if __GLASGOW_HASKELL__ > 804-  return (GHC.EmptyLocalBinds GHC.noExt)-#else-  return (GHC.EmptyLocalBinds)-#endif-#if __GLASGOW_HASKELL__ > 804-replaceDeclsValbinds (GHC.HsValBinds _ _b) new-#else-replaceDeclsValbinds (GHC.HsValBinds _b) new-#endif-    = do-        logTr "replaceDecls HsLocalBinds"-        let decs = GHC.listToBag $ concatMap decl2Bind new-        let sigs = concatMap decl2Sig new-#if __GLASGOW_HASKELL__ > 804-        return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))-#else-        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))-#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---- -----------------------------------------------------------------------type Decl  = GHC.LHsDecl GhcPs-type Match = GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)---- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the--- declarations are extracted and returned after modification. For a--- 'GHC.FunBind' the supplied 'GHC.SrcSpan' is used to identify the specific--- 'GHC.Match' to be transformed, for when there are multiple of them.-modifyValD :: forall m t. (HasTransform m)-                => GHC.SrcSpan-                -> 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-       (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds-       pb' <- liftT $ replaceDeclsPatBindD pb ds'-       return (pb',r)-     else return (pb,Nothing)-modifyValD p ast f = do-  (ast',r) <- runStateT (SYB.everywhereM (SYB.mkM doModLocal) ast) Nothing-  return (ast',r)-  where-    doModLocal :: Match -> StateT (Maybe t) m Match-    doModLocal  (match@(GHC.L ss _) :: Match) = do-         let-         if ss == p-           then do-             ds <- lift $ liftT $ hsDecls match-             (ds',r) <- lift $ f match ds-             put r-             match' <- lift $ liftT $ replaceDecls match ds'-             return match'-           else return match---- ------------------------------------------------------------------------- |Used to integrate a @Transform@ into other Monad stacks-class (Monad m) => (HasTransform m) where-  liftT :: Transform a -> m a--instance HasTransform (TransformT Identity) where-  liftT = id---- ------------------------------------------------------------------------- | Apply a transformation to the decls contained in @t@-modifyDeclsT :: (HasDecls t,HasTransform m)-             => ([GHC.LHsDecl GhcPs] -> m [GHC.LHsDecl GhcPs])-             -> t -> m t-modifyDeclsT action t = do-  decls <- liftT $ hsDecls t-  decls' <- action decls-  liftT $ replaceDecls t decls'---- -----------------------------------------------------------------------matchApiAnn :: GHC.AnnKeywordId -> (KeywordId,DeltaPos) -> Bool-matchApiAnn mkw (kw,_)-  = case kw of-     (G akw) -> mkw == akw-     _       -> False----- We comments extracted from annPriorComments or annFollowingComments, which--- need to move to just before the item identified by the predicate, if it--- fires, else at the end of the annotations.-insertCommentBefore :: (Monad m) => AnnKey -> [(Comment, DeltaPos)]-                    -> ((KeywordId, DeltaPos) -> Bool) -> TransformT m ()-insertCommentBefore key toMove p = do-  let-    doInsert ans =-      case Map.lookup key ans of-        Nothing -> error $ "insertCommentBefore:no AnnKey for:" ++ showGhc key-        Just ann -> Map.insert key ann' ans-          where-            (before,after) = break p (annsDP ann)-            ann' = ann { annsDP = before ++ (map comment2dp toMove) ++ after}--  modifyAnnsT doInsert+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.GHC.ExactPrint.Transform+--+-- This module is currently under heavy development, and no promises are made+-- about API stability. Use with care.+--+-- We welcome any feedback / contributions on this, as it is the main point of+-- the library.+--+-----------------------------------------------------------------------------+module Language.Haskell.GHC.ExactPrint.Transform+        (+        -- * The Transform Monad+          Transform+        , TransformT(..)+        , hoistTransform+        , runTransform+        , runTransformT+        , runTransformFrom+        , runTransformFromT++        -- * Transform monad operations+        , logTr+        , logDataWithAnnsTr+        , uniqueSrcSpanT++        -- ** Managing declarations, in Transform monad+        , HasTransform (..)+        , HasDecls (..)+        , hsDeclsPatBind, hsDeclsPatBindD+        , replaceDeclsPatBind, replaceDeclsPatBindD+        , modifyDeclsT+        , modifyValD+        -- *** Utility, does not manage layout+        , hsDeclsValBinds, replaceDeclsValbinds+        , WithWhere(..)++        -- ** New gen functions+        , noAnnSrcSpanDP+        , noAnnSrcSpanDP0+        , noAnnSrcSpanDP1+        , noAnnSrcSpanDPn+        , d0, d1, dn+        , addComma++        -- ** Managing lists, Transform monad+        , insertAt+        , insertAtStart+        , insertAtEnd+        , insertAfter+        , insertBefore++        -- *** Low level operations used in 'HasDecls'+        , balanceComments+        , balanceCommentsList+        , balanceCommentsListA+        , anchorEof++        -- ** Managing lists, pure functions+        , captureOrderBinds+        , captureLineSpacing+        , captureMatchLineSpacing+        , captureTypeSigSpacing++        -- * Operations+        , isUniqueSrcSpan++        -- * Pure functions+        , setEntryDP, setEntryDPDecl+        , getEntryDP+        , transferEntryDP+        , transferEntryDP'+        , wrapSig, wrapDecl+        , decl2Sig, decl2Bind+        ) where++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils++import Control.Monad.RWS+import qualified Control.Monad.Fail as Fail++import GHC  hiding (parseModule, parsedSource)+import GHC.Data.FastString+import GHC.Types.SrcLoc++import Data.Data+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Generics++import Data.Functor.Identity+import Control.Monad.State++------------------------------------------------------------------------------+-- Transformation of source elements++-- | Monad type for updating the AST and managing the annotations at the same+-- time. The W state is used to generate logging information if required.+type Transform = TransformT Identity++-- |Monad transformer version of 'Transform' monad+newtype TransformT m a = TransformT { unTransformT :: RWST () [String] Int m a }+                deriving (Monad,Applicative,Functor+                         ,MonadReader ()+                         ,MonadWriter [String]+                         ,MonadState Int+                         ,MonadTrans+                         )++instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where+    fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg++-- | Run a transformation in the 'Transform' monad, returning the updated+-- annotations and any logging generated via 'logTr'+runTransform :: Transform a -> (a,Int,[String])+runTransform f = runTransformFrom 0 f++runTransformT :: TransformT m a -> m (a,Int,[String])+runTransformT f = runTransformFromT 0 f++-- | Run a transformation in the 'Transform' monad, returning the updated+-- annotations and any logging generated via 'logTr', allocating any new+-- SrcSpans from the provided initial value.+runTransformFrom :: Int -> Transform a -> (a,Int,[String])+runTransformFrom seed f = runRWS (unTransformT f) () seed++-- |Run a monad transformer stack for the 'TransformT' monad transformer+runTransformFromT :: Int -> TransformT m a -> m (a,Int,[String])+runTransformFromT seed f = runRWST (unTransformT f) () seed++-- | Change inner monad of 'TransformT'.+hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a+hoistTransform nt (TransformT m) = TransformT (mapRWST nt m)++-- |Log a string to the output of the Monad+logTr :: (Monad m) => String -> TransformT m ()+logTr str = tell [str]++-- |Log a representation of the given AST with annotations to the output of the+-- Monad+logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m ()+logDataWithAnnsTr str ast = do+  logTr $ str ++ showAst ast++-- ---------------------------------------------------------------------++-- |If we need to add new elements to the AST, they need their own+-- 'SrcSpan' for this.+-- This should no longer be needed, we use an @EpaDelta@ location instead.+uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan+uniqueSrcSpanT = do+  col <- get+  put (col + 1 )+  let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col+  return $ mkSrcSpan pos pos++-- |Test whether a given 'SrcSpan' was generated by 'uniqueSrcSpanT'+isUniqueSrcSpan :: SrcSpan -> Bool+isUniqueSrcSpan ss = srcSpanStartLine' ss == -1++srcSpanStartLine' :: SrcSpan -> Int+srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s+srcSpanStartLine' _ = 0++-- ---------------------------------------------------------------------++captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs+captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )))))+                       = L l (ValD x (FunBind a b (MG c (L d ms'))))+    where+      ms' :: [LMatch GhcPs (LHsExpr GhcPs)]+      ms' = captureLineSpacing ms+captureMatchLineSpacing d = d++captureLineSpacing :: [LocatedA e] -> [LocatedA e]+captureLineSpacing [] = []+captureLineSpacing [d] = [d]+captureLineSpacing ds = map (\(_,_,x) -> x) $ go (map to ds)+  where+    to :: LocatedA e -> (Int, Int, LocatedA e)+    to d = (fst $ ss2pos rss, fst $ ss2posEnd rss,d)+      where+        rss = rs $ getHasLoc d++    go :: [(Int, Int, LocatedA e)] -> [(Int, Int, LocatedA e)]+    go [] = []+    go [d] = [d]+    go ((ls1,le1,de1):(ls2,le2,d2):ds0) = (ls1,le1,de1):go ((ls2,le2,d2'):ds0)+         `debug` ("captureLineSpacing: (le1,ls2,getLoc d2,getLoc d2')=" ++ showAst (le1,ls2,getLoc d2,getLoc d2'))+      where+        d2' = setEntryDP d2 (deltaPos (ls2-le1) 0)++-- ---------------------------------------------------------------------++captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs+captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig NoEpUniTok mp md) ns (HsWC xw ty))))+  = (L l (SigD x (TypeSig (AnnSig NoEpUniTok mp md) ns (HsWC xw ty))))+captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (HsWC xw ty))))+  = (L l (SigD x (TypeSig (AnnSig (EpUniTok dca' u) mp md) ns (HsWC xw ty'))))+  where+    -- we want DPs for the distance from the end of the ns to the+    -- AnnDColon, and to the start of the ty+    rd = case last ns of+      L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc'+    dca' = case dca of+          EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) [])+          _                            -> dca++    -- ---------------------------------++    ty' :: LHsSigType GhcPs+    ty' = case ty of+      (L (EpAnn anc0 a c) b)+        -> let+              anc' = case anc0 of+                EpaDelta _ _ _ -> anc0+                _ -> case dca of+                  EpaSpan ss -> EpaDelta ss (SameLine 1) []+                  EpaDelta ss _ cs0 -> EpaDelta ss (SameLine 1) cs0+           in (L (EpAnn anc' a c) b)++captureTypeSigSpacing s = s++-- ---------------------------------------------------------------------++setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs+setEntryDPDecl decl@(L _  (ValD x (FunBind a b (MG c (L d ms ))))) dp+                   = L l' (ValD x (FunBind a b (MG c (L d ms'))))+    where+      L l' _ = setEntryDP decl dp+      ms' :: [LMatch GhcPs (LHsExpr GhcPs)]+      ms' = case ms of+        [] -> []+        (m0':ms0) -> setEntryDP m0' dp : ms0+setEntryDPDecl d dp = setEntryDP d dp++-- ---------------------------------------------------------------------++-- |Set the true entry 'DeltaPos' from the annotation for a given AST+-- element. This is the 'DeltaPos' ignoring any comments.+setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a+setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp+  = L (EpAnn (EpaDelta ss dp []) an cs) a+setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp+  = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a+setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp+  = L (EpAnn (EpaDelta ss d' csd') an cs') a+  where+    -- I suspect we should assume the comments are already in the+    -- right place, and just set the entry DP for this case. This+    -- avoids surprises from the caller.+    (d', csd', cs') = case cs of+      EpaComments (h:t) ->+        let+          (dp0,c') = go h+        in+          (dp0, csd, EpaComments (c':t))+      EpaComments [] ->+          (dp, csd, cs)+      EpaCommentsBalanced (h:t) ts ->+        let+          (dp0,c') = go h+        in+          (dp0, c':t++csd, EpaCommentsBalanced [] ts)+      EpaCommentsBalanced [] ts ->+           case csd of+             [] -> (d, csd, EpaCommentsBalanced [] ts)+             (h:t) ->+                let+                  (dp0,c') = go h+                in+                  (dp0, c':t, EpaCommentsBalanced [] ts)+    go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e)+    go (L (EpaDelta ss0 _ c0) c) = (d,  L (EpaDelta ss0 dp c0) c)+    go (L (EpaSpan ss0)       c) = (d,  L (EpaDelta ss0 dp NoComments) c)+setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp+  = case sortEpaComments (priorComments cs) of+      [] ->+        L (EpAnn (EpaDelta ss dp []) an cs) a+      (L ca c:cs') ->+        L (EpAnn (EpaDelta ss edp csd) an cs'') a+              where+                cs'' = setPriorComments cs []+                csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs'+                lc = last $ (L ca c:cs')+                delta = case getLoc lc of+                          EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r+                          EpaSpan _ -> (SameLine 0)+                          EpaDelta _ _dp _ -> DifferentLine 1 0+                line = getDeltaLine delta+                col = deltaColumn delta+                edp' = if line == 0 then SameLine col+                                    else DifferentLine line (col - 1)+                                         -- At the top level the layout offset is 1, adjust for it+                                         -- TODO: what about the layout offset for nested items?+                edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ epaLocationRealSrcSpan $ getLoc lc), r))+++-- ---------------------------------------------------------------------++getEntryDP :: LocatedAn t a -> DeltaPos+getEntryDP (L (EpAnn (EpaDelta _ dp _) _ _) _) = dp+getEntryDP _ = SameLine 1++-- ---------------------------------------------------------------------++addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation+addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs+addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) []+addEpaLocationDelta  off  anc (EpaSpan ss@(RealSrcSpan r _))+  = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) []++-- Set the entry DP for an element coming after an existing keyword annotation+setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t+setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a+setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a+setEntryDPFromAnchor  off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp'+  where+    dp' = case la of+      (EpAnn (EpaSpan (RealSrcSpan r' _)) _ _) -> adjustDeltaForOffset off (ss2deltaEnd anc r')+      (EpAnn (EpaSpan _) _ _)                  -> adjustDeltaForOffset off (SameLine 0)+      (EpAnn (EpaDelta _ dp _) _ _)            -> adjustDeltaForOffset off dp++-- ---------------------------------------------------------------------++-- |Take the annEntryDelta associated with the first item and+-- associate it with the second. Also transfer any comments occurring+-- before it.+transferEntryDP :: (Typeable t1, Typeable t2)+  => LocatedAn t1 a -> LocatedAn t2 b -> (LocatedAn t2 b)+transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn anc2 an2 cs2) b) =+  -- Note: the EpaDelta version of an EpaLocation contains the original+  -- SrcSpan. We must preserve that.+  let anc1' = case (anc1,anc2) of+          (EpaDelta _ dp cs, EpaDelta ss2 _ _) -> EpaDelta ss2 dp cs+          (_, _) -> anc1+  -- Problem: if the original had preceding comments, blindly+  -- transferring the location is not correct+  in case priorComments cs1 of+    [] -> (L (EpAnn anc1' (combine an1 an2) cs2) b)+    -- TODO: what happens if the receiving side already has comments?+    (L _ _:_) -> (L (EpAnn anc1' (combine an1 an2) (cs1 <> cs2)) b)+++-- |If a and b are the same type return first arg, else return second+combine :: (Typeable a, Typeable b) => a -> b -> b+combine x y = fromMaybe y (cast x)++-- |Take the annEntryDelta associated with the first item and associate it with the second.+-- Also transfer any comments occurring before it.+-- TODO: call transferEntryDP, and use pushDeclDP+transferEntryDP' :: LHsDecl GhcPs -> LHsDecl GhcPs -> (LHsDecl GhcPs)+transferEntryDP' la lb =+  let+    (L l2 b) = transferEntryDP la lb+  in (L l2 (pushDeclDP b (SameLine 0)))+++pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs+pushDeclDP (ValD x (FunBind a b (MG c (L d  ms )))) dp+          = ValD x (FunBind a b (MG c (L d' ms')))+    where+      L d' _ = setEntryDP (L d ms) dp+      ms' :: [LMatch GhcPs (LHsExpr GhcPs)]+      ms' = case ms of+        [] -> []+        (m0':ms0) -> setEntryDP m0' dp : ms0+pushDeclDP d _dp = d++-- ---------------------------------------------------------------------++-- | If we compile in haddock mode, the haddock processing inserts+-- DocDecls to carry the Haddock Documentation. We ignore these in+-- exact printing, as all the comments are also available in their+-- normal location, and the haddock processing is lossy, in that it+-- does not preserve all haddock-like comments. When we balance+-- comments in a list, we migrate some to preceding or following+-- declarations in the list. We must make sure we do not move any to+-- these DocDecls, which are not printed.+balanceCommentsList :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]+balanceCommentsList decls = balanceCommentsList' (filter notDocDecl decls)++balanceCommentsList' :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]+balanceCommentsList' [] = []+balanceCommentsList' [x] = [x]+balanceCommentsList' (a:b:ls) = (a':r)+  where+    (a',b') = balanceComments a b+    r = balanceCommentsList' (b':ls)++-- |The GHC parser puts all comments appearing between the end of one AST+-- item and the beginning of the next as 'annPriorComments' for the second one.+-- This function takes two adjacent AST items and moves any 'annPriorComments'+-- from the second one to the 'annFollowingComments' of the first if they belong+-- to it instead. This is typically required before deleting or duplicating+-- either of the AST elements.+balanceComments :: LHsDecl GhcPs -> LHsDecl GhcPs+                -> (LHsDecl GhcPs, LHsDecl GhcPs)+balanceComments first second =+  case first of+    (L l (ValD x fb@(FunBind{}))) ->+      let+        (L l' fb',second') = balanceCommentsFB (L l fb) second+      in (L l' (ValD x fb'), second')+    _ -> balanceCommentsA first second++-- |Once 'balanceCommentsA has been called to move trailing comments to a+-- 'FunBind', these need to be pushed down from the top level to the last+-- 'Match' if that 'Match' needs to be manipulated.+balanceCommentsFB :: LHsBind GhcPs -> LocatedA b -> (LHsBind GhcPs, LocatedA b)+balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second+  = balanceCommentsA (packFunBind bind) second'+  -- There are comments on lf.  We need to+  -- + Keep the prior ones here+  -- + move the interior ones to the first match,+  -- + move the trailing ones to the last match.+  where+    (before,middle,after) = case entry lf of+        EpaSpan (RealSrcSpan ss _) ->+          let+            split = splitCommentsEnd ss (comments lf)+            split2 = splitCommentsStart ss  (EpaComments (sortEpaComments $ priorComments split))++            before0 = sortEpaComments $ priorComments split2+            middle0 = sortEpaComments $ getFollowingComments split2+            after0  = sortEpaComments $ getFollowingComments split+          in (before0,middle0,after0)+        _ -> (priorComments $ comments lf,+              [],+              getFollowingComments $ comments lf)++    lf' = setCommentsEpAnn lf (EpaComments before)+    matches' :: [LocatedA (Match GhcPs (LHsExpr GhcPs))]+    matches' = case matches of+                  (L lm' m0:ms') ->+                    (L (addCommentsToEpAnn lm' (EpaComments middle )) m0:ms')+                  _ -> error "balanceCommentsFB"+    matches'' = balanceCommentsListA matches'+    (m,ms) = case reverse matches'' of+               (L lm' m0:ms') ->+                 (L (addCommentsToEpAnn lm' (EpaCommentsBalanced [] after)) m0,ms')+               _ -> error "balanceCommentsFB4"+    (m',second') = balanceCommentsA m second+    m'' = balanceCommentsMatch m'+    (m''',lf'') = case ms of+      [] -> moveLeadingComments m'' lf'+      _  -> (m'',lf')+    bind = L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))+balanceCommentsFB f s = balanceCommentsA f s++-- | Move comments on the same line as the end of the match into the+-- GRHS, prior to the binds+balanceCommentsMatch :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))+balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds)))+  = (L l'' (Match am mctxt pats (GRHSs xg grhss' binds')))+  where+    simpleBreak (r,_) = r /= 0+    an1 = l+    anc1 = comments an1+    cs1f = getFollowingComments anc1+    (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f)+    move = map snd move'+    stay = map snd stay'+    (l'', grhss', binds', _logInfo)+      = case NE.reverse grhss of+          L lg (GRHS ag grs rhs):|gs ->+            let+              anc1' = setFollowingComments anc1 stay+              an1' = setCommentsEpAnn l anc1'++              -- ---------------------------------+              (moved,bindsm) = pushTrailingComments WithWhere (EpaCommentsBalanced [] move) binds+              -- ---------------------------------++              (EpAnn anc an lgc) = ag+              lgc' = splitCommentsEnd (realSrcSpan $ locA lg) lgc+              ag' = if moved+                      then EpAnn anc an lgc'+                      else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move))++            in (an1', (NE.reverse $ L lg (GRHS ag' grs rhs):|gs), bindsm, (anc1',an1'))++pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs)+pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b)+pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds"+pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb)+  where+    decls = hsDeclsLocalBinds lb+    (an', decls') = case reverse decls of+      [] -> (addCommentsToEpAnn an cs, decls)+      (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds)+    vb = case replaceDeclsValbinds w lb (reverse decls') of+      (HsValBinds _ vb') -> vb'+      _ -> ValBinds NoAnnSortKey [] []+++balanceCommentsListA :: [LocatedA a] -> [LocatedA a]+balanceCommentsListA [] = []+balanceCommentsListA [x] = [x]+balanceCommentsListA (a:b:ls) = (a':r)+  where+    (a',b') = balanceCommentsA a b+    r = balanceCommentsListA (b':ls)++-- |Prior to moving an AST element, make sure any trailing comments belonging to+-- it are attached to it, and not the following element. Of necessity this is a+-- heuristic process, to be tuned later. Possibly a variant should be provided+-- with a passed-in decision function.+-- The initial situation is that all comments for a given anchor appear as prior comments+-- Many of these should in fact be following comments for the previous anchor+balanceCommentsA :: LocatedA a -> LocatedA b -> (LocatedA a, LocatedA b)+balanceCommentsA la1 la2 = (la1', la2')+  where+    simpleBreak n (r,_) = r > n+    L an1 f = la1+    L an2 s = la2+    anc1 = comments an1+    anc2 = comments an2++    (p1,m1,f1) = splitComments (anchorFromLocatedA la1) anc1+    cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1++    -- Split cs1 following comments into those before any+    -- TrailingAnn's on an1, and any after+    cs1f = splitCommentsEnd (fullSpanFromLocatedA la1) $ EpaComments f1+    cs1fp = priorCommentsDeltas    (anchorFromLocatedA la1) (priorComments        cs1f)+    cs1ff = trailingCommentsDeltas (anchorFromLocatedA la1) (getFollowingComments cs1f)++    -- Split cs1ff into those that belong on an1 and ones that must move to an2+    (cs1move,cs1stay) = break (simpleBreak 1) cs1ff++    (p2,m2,f2) = splitComments (anchorFromLocatedA la2) anc2+    cs2p = priorCommentsDeltas    (anchorFromLocatedA la2) p2+    cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) f2++    (stay'',move') = break (simpleBreak 1) cs2p+    -- Need to also check for comments more closely attached to la1,+    -- ie trailing on the same line+    (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay''))+    move = sortEpaComments $ map snd (cs1fp ++ cs1move ++ move'' ++ move')+    stay = sortEpaComments $ m2 ++ map snd (cs1stay ++ stay')++    an1' = setCommentsEpAnn (getLoc la1) (epaCommentsBalanced (m1 ++ map snd cs1p) move)+    an2' = setCommentsEpAnn (getLoc la2) (epaCommentsBalanced stay (map snd cs2f))+    la1' = L an1' f+    la2' = L an2' s++-- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start+trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment]+               -> [(Int, LEpaComment)]+trailingCommentsDeltas _ [] = []+trailingCommentsDeltas r (la@(L (EpaDelta _ dp _) _):las)+  = (getDeltaLine dp, la): trailingCommentsDeltas r las+trailingCommentsDeltas r (la@(L l _):las)+  = deltaComment r la : trailingCommentsDeltas (epaLocationRealSrcSpan l) las+  where+    deltaComment rs' (L loc c) = (abs(ll - al), L loc c)+      where+        (al,_) = ss2posEnd rs'+        (ll,_) = ss2pos (epaLocationRealSrcSpan loc)++priorCommentsDeltas :: RealSrcSpan -> [LEpaComment]+                    -> [(Int, LEpaComment)]+priorCommentsDeltas r cs = go r (sortEpaComments cs)+  where+    go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]+    go _   [] = []+    go _   (la@(L l@(EpaDelta _ dp _) _):las) = (getDeltaLine dp, la) : go (epaLocationRealSrcSpan l) las+    go rs' (la@(L l _):las) = deltaComment rs' la : go (epaLocationRealSrcSpan l) las++    deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment)+    deltaComment rs' (L loc c) = (abs(ll - al), L loc c)+      where+        (al,_) = ss2pos rs'+        (ll,_) = ss2pos (epaLocationRealSrcSpan loc)+++-- ---------------------------------------------------------------------++-- | Split comments into ones occurring before the end of the reference+-- span, and those after it.+splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])+splitComments p cs = (before, middle, after)+  where+    cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p+    cmpe (L _ _) = True++    cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p+    cmpb (L _ _) = True++    (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))+    (before, middle) = break cmpb beforeEnd+++-- | Split comments into ones occurring before the end of the reference+-- span, and those after it.+splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments+splitCommentsEnd p (EpaComments cs) = cs'+  where+    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p+    cmp (L _ _) = True+    (before, after) = break cmp cs+    cs' = case after of+      [] -> EpaComments cs+      _ -> epaCommentsBalanced before after+splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'+  where+    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p+    cmp (L _ _) = True+    (before, after) = break cmp cs+    cs' = before+    ts' = after <> ts++-- | Split comments into ones occurring before the start of the reference+-- span, and those after it.+splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments+splitCommentsStart p (EpaComments cs) = cs'+  where+    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p+    cmp (L _ _) = True+    (before, after) = break cmp cs+    cs' = case after of+      [] -> EpaComments cs+      _ -> epaCommentsBalanced before after+splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'+  where+    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p+    cmp (L _ _) = True+    (before, after) = break cmp cs+    cs' = before+    ts' = after <> ts++moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)+  => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)+moveLeadingComments (L la a) lb = (L la' a, lb')+  `debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb'))+  where+    split = splitCommentsEnd (realSrcSpan $ locA la) (comments la)+    before = sortEpaComments $ priorComments split+    after = sortEpaComments $ getFollowingComments split++    -- TODO: need to set an entry delta on lb' to zero, and move the+    -- original spacing to the first comment.++    la' = setCommentsEpAnn la (epaCommentsBalanced [] after)+    lb' = addCommentsToEpAnn lb (epaCommentsBalanced before [])++-- | A GHC comment includes the span of the preceding (non-comment)+-- token.  Takes an original list of comments, and converts the+-- 'Anchor's to have a have a `MovedAnchor` operation based on the+-- original locations.+commentOrigDeltas :: [LEpaComment] -> [LEpaComment]+commentOrigDeltas [] = []+commentOrigDeltas lcs = map commentOrigDelta lcs++addCommentOrigDeltas :: EpAnnComments -> EpAnnComments+addCommentOrigDeltas (EpaComments cs) = EpaComments (commentOrigDeltas cs)+addCommentOrigDeltas (EpaCommentsBalanced pcs fcs)+  = EpaCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs)++addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a)+addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)++-- TODO: this is replicating functionality in ExactPrint. Sort out the+-- import loop`+anchorFromLocatedA :: LocatedA a -> RealSrcSpan+anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc++-- | Get the full span of interest for comments from a LocatedA.+-- This extends up to the last TrailingAnn+fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan+fullSpanFromLocatedA (L (EpAnn anc (AnnListItem tas)  _) _) = rr+  where+    r = epaLocationRealSrcSpan anc+    trailing_loc ta = case ta_location ta of+        EpaSpan (RealSrcSpan s _) -> [s]+        _ -> []+    rr = case reverse (concatMap trailing_loc tas) of+        [] -> r+        (s:_) -> combineRealSrcSpans r s++-- ---------------------------------------------------------------------++balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))+balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb)))+  = (L la' (Match anm mctxt pats (GRHSs x grhss' lb)))+  where+    simpleBreak n (r,_) = r > n+    (la',grhss', _logInfo) = case NE.reverse grhss of+      L lg (GRHS ga gs rhs):|grs -> (la'',NE.reverse $ L lg (GRHS ga' gs rhs):|grs,[(gac,(csp,csf))])+        where+          anc1 = comments la+          (EpAnn anc an _) = ga :: EpAnn GrhsAnn+          (csp,csf) = case anc1 of+            EpaComments cs -> ([],cs)+            EpaCommentsBalanced p f -> (p,f)+          (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (epaLocationRealSrcSpan anc) csf)+          move = map snd move'+          stay = map snd stay'+          cs1 = epaCommentsBalanced csp stay++          gac = epAnnComments ga+          gfc = getFollowingComments gac+          gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move)+          ga' = (EpAnn anc an gac')++          la'' = setCommentsEpAnn la cs1++-- ---------------------------------------------------------------------++anchorEof :: ParsedSource -> ParsedSource+anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })+  where+    an' = addCommentOrigDeltasAnn an++-- ---------------------------------------------------------------------++-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the+-- given @DeltaPos@.+noAnnSrcSpanDP :: (NoAnn ann) => DeltaPos -> EpAnn ann+noAnnSrcSpanDP dp = EpAnn (EpaDelta noSrcSpan dp []) noAnn emptyComments++noAnnSrcSpanDP0 :: (NoAnn ann) => EpAnn ann+noAnnSrcSpanDP0 = noAnnSrcSpanDP (SameLine 0)++noAnnSrcSpanDP1 :: (NoAnn ann) => EpAnn ann+noAnnSrcSpanDP1 = noAnnSrcSpanDP (SameLine 1)++noAnnSrcSpanDPn :: (NoAnn ann) => Int -> EpAnn ann+noAnnSrcSpanDPn s = noAnnSrcSpanDP (SameLine s)++d0 :: EpaLocation+d0 = EpaDelta noSrcSpan (SameLine 0) []++d1 :: EpaLocation+d1 = EpaDelta noSrcSpan (SameLine 1) []++dn :: Int -> EpaLocation+dn n = EpaDelta noSrcSpan (SameLine n) []++addComma :: SrcSpanAnnA -> SrcSpanAnnA+addComma (EpAnn anc (AnnListItem as) cs)+  = EpAnn anc (AnnListItem (AddCommaAnn (EpTok d0):as)) cs++-- ---------------------------------------------------------------------++-- | Insert a declaration into an AST element having sub-declarations+-- (@HasDecls@) according to the given location function.+insertAt :: (HasDecls ast)+         => (LHsDecl GhcPs+              -> [LHsDecl GhcPs]+              -> [LHsDecl GhcPs])+         -> ast+         -> LHsDecl GhcPs+         -> ast+insertAt f t decl = replaceDecls t (f decl oldDecls')+  where+    oldDecls = hsDecls t+    oldDeclsb = balanceCommentsList oldDecls+    oldDecls' = oldDeclsb++-- |Insert a declaration at the beginning or end of the subdecls of the given+-- AST item+insertAtStart, insertAtEnd :: HasDecls ast => ast -> LHsDecl GhcPs -> ast++insertAtEnd   = insertAt (\x xs -> xs ++ [x])++insertAtStart = insertAt insertFirst+  where+    insertFirst x xs =+      case xs of+        [] -> [x]+        (h:t) -> x:setEntryDP h (DifferentLine 2 0):t+                   `debug` ("insertAtStart:h=" ++ showAst h)+++-- |Insert a declaration at a specific location in the subdecls of the given+-- AST item+insertAfter, insertBefore :: HasDecls (LocatedA ast)+                          => LocatedA old+                          -> LocatedA ast+                          -> LHsDecl GhcPs+                          -> LocatedA ast+insertAfter (getLocA -> k) = insertAt findAfter+  where+    findAfter x xs =+      case span (\(L l _) -> locA l /= k) xs of+        ([],[]) -> [x]+        (fs,[]) -> fs++[x]+        (fs, b:bs) -> fs ++ (b : x : bs)+insertBefore (getLocA -> k) = insertAt findBefore+  where+    findBefore x xs =+      let (fs, bs) = span (\(L l _) -> locA l /= k) xs+      in fs ++ (x : bs)++-- =====================================================================+-- start of HasDecls instances+-- =====================================================================++-- |Provide a means to get and process the immediate child declarations of a+-- given AST element.+class (Data t) => HasDecls t where+-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent++    -- | Return the 'HsDecl's that are directly enclosed in the+    -- given syntax phrase. They are always returned in the wrapped 'HsDecl'+    -- form, even if orginating in local decls. This is safe, as annotations+    -- never attach to the wrapper, only to the wrapped item.+    hsDecls :: t -> [LHsDecl GhcPs]++    -- | Replace the directly enclosed decl list by the given+    --  decl list. As part of replacing it will update list order+    --  annotations, and rebalance comments and other layout changes as needed.+    --+    -- For example, a call on replaceDecls for a wrapped 'FunBind' having no+    -- where clause will convert+    --+    -- @+    -- -- |This is a function+    -- foo = x -- comment1+    -- @+    -- in to+    --+    -- @+    -- -- |This is a function+    -- foo = x -- comment1+    --   where+    --     nn = 2+    -- @+    replaceDecls :: t -> [LHsDecl GhcPs] -> t++-- ---------------------------------------------------------------------++instance HasDecls ParsedSource where+  hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = decls++  replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls+    = (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls))++-- ---------------------------------------------------------------------++instance HasDecls (LocatedA (HsDecl GhcPs)) where+  hsDecls (L _ (TyClD _ c@ClassDecl{}))  = hsDeclsClassDecl c+  hsDecls decl = error $ "hsDecls:decl=" ++ showAst decl+  replaceDecls (L l (TyClD e dec@ClassDecl{})) decls =+    let+        decl' = replaceDeclsClassDecl dec decls+    in (L l (TyClD e decl'))+  replaceDecls decl _decls+      = error $ "replaceDecls:decl=" ++ showAst decl++-- ---------------------------------------------------------------------++instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where+  hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsLocalBinds lb++  replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) []+    = let+        binds'' = replaceDeclsValbinds WithoutWhere binds []+      in (L l (Match xm c p (GRHSs xr rhs binds'')))++  replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds+    = let+        -- Need to throw in a fresh where clause if the binds were empty,+        -- in the annotations.+        (l', rhs') = case binds of+          EmptyLocalBinds{} ->+            let+              L l0 m' = balanceSameLineComments m+            in (l0, grhssGRHSs $ m_grhss m')+          _ -> (l, rhs)+        binds'' = replaceDeclsValbinds WithWhere binds newBinds+      in (L l' (Match xm c p (GRHSs xr rhs' binds'')))++-- ---------------------------------------------------------------------++instance HasDecls (LocatedA (HsExpr GhcPs)) where+  hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsLocalBinds decls+  hsDecls _                         = []++  replaceDecls (L ll (HsLet (tkLet, tkIn) binds ex)) newDecls+    = let+        lastAnc = realSrcSpan $ spanHsLocaLBinds binds+        -- TODO: may be an intervening comment, take account for lastAnc+        (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of+          (EpTok l, EpTok i) ->+            let+              off = case l of+                      (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r+                      (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0+                      (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0+                      (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c+              ex'' = setEntryDPFromAnchor off i ex+              newDecls'' = case newDecls of+                [] -> newDecls+                (d:ds) -> setEntryDPDecl d (SameLine 0) : ds+            in ( EpTok l+               , EpTok (addEpaLocationDelta off lastAnc i)+               , ex''+               , newDecls'')+          (_,_) -> (tkLet, tkIn, ex, newDecls)+        binds' = replaceDeclsValbinds WithoutWhere binds newDecls'+      in (L ll (HsLet (tkLet', tkIn') binds' ex'))++  -- TODO: does this make sense? Especially as no hsDecls for HsPar+  replaceDecls (L l (HsPar x e)) newDecls+    = let+        e' = replaceDecls e newDecls+      in (L l (HsPar x e'))+  replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old++-- ---------------------------------------------------------------------++-- | Extract the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is+-- idempotent.+hsDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs]+hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d)+hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x++-- | Extract the immediate declarations for a 'PatBind'. This+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is+-- idempotent.+hsDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs]+hsDeclsPatBind (L _ (PatBind _ _ _ (GRHSs _ _grhs lb))) = hsDeclsLocalBinds lb+hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x++-- -------------------------------------++-- | Replace the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is+-- idempotent.+replaceDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> (LHsDecl GhcPs)+replaceDeclsPatBindD (L l (ValD x d)) newDecls =+  let+    (L _ d') = replaceDeclsPatBind (L l d) newDecls+  in (L l (ValD x d'))+replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x++-- | Replace the immediate declarations for a 'PatBind'. This+-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is+-- idempotent.+replaceDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs)+replaceDeclsPatBind (L l (PatBind x a p (GRHSs xr rhss binds))) newDecls+  =  (L l (PatBind x a p (GRHSs xr rhss binds'')))+  where+    binds'' = replaceDeclsValbinds WithWhere binds newDecls+replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x++-- ---------------------------------------------------------------------++instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where+  hsDecls (L _ (LetStmt _ lb))      = hsDeclsLocalBinds lb+  hsDecls (L _ (LastStmt _ e _ _))  = hsDecls e+  hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e+  hsDecls (L _ (BodyStmt _ e _ _))  = hsDecls e+  hsDecls _                         = []++  replaceDecls (L l (LetStmt x lb)) newDecls+    = let+        lb'' = replaceDeclsValbinds WithWhere lb newDecls+      in (L l (LetStmt x lb''))+  replaceDecls (L l (LastStmt x e d se)) newDecls+    = let+        e' = replaceDecls e newDecls+      in (L l (LastStmt x e' d se))+  replaceDecls (L l (BindStmt x pat e)) newDecls+    = let+        e' = replaceDecls e newDecls+      in (L l (BindStmt x pat e'))++  replaceDecls (L l (BodyStmt x e a b)) newDecls+    = let+        e' = replaceDecls e newDecls+      in (L l (BodyStmt x e' a b))+  replaceDecls x _newDecls = x++-- =====================================================================+-- end of HasDecls instances+-- =====================================================================++-- ---------------------------------------------------------------------+-- A @FunBind@ is a container for @[LMatch GhcPs]@+--+-- When being used as a Bind (or Decl), the surrounding context+-- annotations must appear at the FunBind level, so it can be+-- manipulated in the context of other Binds or Decls.+--+-- Surrounding context annotations are specifically prior comments,+-- following comments and trailing annotations.+--+-- But when we unpack the container, by calling @hsDecls@ on a+-- @FunBind@, we must make sure that the component parts fully+-- represent the relationship between them and the surrounding+-- declarations.+--+-- This means pushing the prior context annotations into the first+-- match, and the following ones into the last match when returning+-- @hsDecls@, and undoing this for @replaceDecls@.++-- |Push leading and trailing top level annotations into the @[LMatch GhcPs]@+unpackFunBind :: LHsBind GhcPs -> LHsBind GhcPs+unpackFunBind (L loc (FunBind x1 fid (MG x2 (L lg (L lm m:matches)))))+  = (L loc'' (FunBind x1 fid (MG x2 (L lg (reverse (L llm' lmtch:ms))))))+     -- `debug` ("unpackFunBind: ="+     --          ++ showAst (("loc",loc), ("loc'",loc'), ("loc''",loc''),+     --                      ("lm'",lm'), ("llm",llm), ("llm'", llm')))+  where+    (loc', lm') = transferPriorCommentsA loc lm+    matches' = reverse $ L lm' m:matches+    (L llm lmtch, ms) = case matches' of+                      mm:ms0 -> (mm,ms0)+                      _ -> error "unpackFunBind"++    (loc'', llm') = transferFollowingA loc' llm++unpackFunBind d = d++-- |Pull leading and trailing annotations from the @[LMatch GhcPs]@ to+-- the top level.+packFunBind :: LHsBind GhcPs -> LHsBind GhcPs+packFunBind (L loc (FunBind x1 fid (MG x2 (L lg (L lm m:matches)))))+  = (L loc'' (FunBind x1 fid (MG x2 (L lg (reverse (L llm' lmtch:ms))))))+     -- `debug` ("packFunBind: ="+     --          ++ showAst (("loc",loc), ("loc'",loc'), ("loc''",loc''),+     --                      ("lm'",lm'), ("llm",llm), ("llm'", llm')))+  where+    (lm', loc') = transferPriorCommentsA lm loc+    matches' = reverse $ L lm' m:matches+    (L llm lmtch, ms) = case matches' of+                      mm:ms0 -> (mm,ms0)+                      _ -> error "packFunBind"+    (llm', loc'') = transferFollowingA llm loc'+packFunBind d = d++packFunDecl :: LHsDecl GhcPs -> LHsDecl GhcPs+packFunDecl (L l (ValD x b)) = L l' (ValD x b')+  where+    L l' b' = packFunBind (L l b)+packFunDecl x = x++unpackFunDecl :: LHsDecl GhcPs -> LHsDecl GhcPs+unpackFunDecl (L l (ValD x b)) = L l' (ValD x b')+  where+    L l' b' = unpackFunBind (L l b)+unpackFunDecl x = x++-- ---------------------------------------------------------------------++data WithWhere = WithWhere+               | WithoutWhere+               deriving (Eq,Show)++-- | Utility function for returning decls to 'HsLocalBinds'. Use with+-- care, as this does not manage the declaration order, the+-- ordering should be done by the calling function from the 'HsLocalBinds'+-- context in the AST.+replaceDeclsValbinds :: WithWhere+                     -> HsLocalBinds GhcPs -> [LHsDecl GhcPs]+                     -> HsLocalBinds GhcPs+replaceDeclsValbinds _ _ [] = EmptyLocalBinds NoExtField+replaceDeclsValbinds w b@(HsValBinds a _) new+    = let+        oldSpan = spanHsLocaLBinds b+        an = oldWhereAnnotation a w (realSrcSpan oldSpan)+        decs = concatMap decl2Bind new+        sigs = concatMap decl2Sig new+        sortKey = captureOrderBinds new+      in (HsValBinds an (ValBinds sortKey decs sigs))+replaceDeclsValbinds _ (HsIPBinds {}) _new    = error "undefined replaceDecls HsIPBinds"+replaceDeclsValbinds w (EmptyLocalBinds _) new+    = let+        an = newWhereAnnotation w+        decs = concatMap decl2Bind new+        sigs = concatMap decl2Sig  new+        sortKey = captureOrderBinds new+      in (HsValBinds an (ValBinds sortKey decs sigs))++oldWhereAnnotation :: EpAnn (AnnList (EpToken "where"))+  -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where")))+oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an'+  -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation,+  -- change the AnnList anchor to have the correct DP too+  where+    (AnnList ancl p s _r t) = an+    w = case ww of+      WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) [])+      WithoutWhere -> NoEpTok+    (anc', ancl') =+          case ww of+            WithWhere -> (anc, ancl)+            WithoutWhere -> (anc, ancl)+    an' = EpAnn anc'+                (AnnList ancl' p s w t)+                cs++newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where")))+newWhereAnnotation ww = an+  where+  anc  = EpaDelta noSrcSpan (DifferentLine 1 2) []+  anc2 = EpaDelta noSrcSpan (DifferentLine 1 4) []+  w = case ww of+    WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) [])+    WithoutWhere -> NoEpTok+  an = EpAnn anc+              (AnnList (Just anc2) ListNone [] w [])+              emptyComments++-- ---------------------------------------------------------------------++type Decl  = LHsDecl GhcPs+type PMatch = LMatch GhcPs (LHsExpr GhcPs)++-- |Modify a 'LHsBind' wrapped in a 'ValD'. For a 'PatBind' the+-- declarations are extracted and returned after modification. For a+-- 'FunBind' the supplied 'SrcSpan' is used to identify the specific+-- 'Match' to be transformed, for when there are multiple of them.+modifyValD :: forall t.+                   SrcSpan+                -> Decl+                -> (PMatch -> [Decl] -> ([Decl], Maybe t))+                -> (Decl,Maybe t)+modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f =+  if (locA ss) == p+     then+       let+           ds = hsDeclsPatBindD pb+           (ds',r) = f (error "modifyValD.PatBind should not touch Match") ds+           pb' = replaceDeclsPatBindD pb ds'+       in (pb',r)+     else (pb,Nothing)+modifyValD p decl f = (packFunDecl decl', r)+  where+    (decl',r) = runState (everywhereM (mkM doModLocal) (unpackFunDecl decl)) Nothing+    doModLocal :: PMatch -> State (Maybe t) PMatch+    doModLocal  (match@(L ss _) :: PMatch) = do+         if (locA ss) == p+           then do+             let+               ds = hsDecls match+               (ds',r0) = f match ds+             put r0+             let match' = replaceDecls match ds'+             return match'+           else return match++-- ---------------------------------------------------------------------++-- |Used to integrate a @Transform@ into other Monad stacks+class (Monad m) => (HasTransform m) where+  liftT :: Transform a -> m a++instance Monad m => HasTransform (TransformT m) where+  liftT = hoistTransform (return . runIdentity)++-- ---------------------------------------------------------------------++-- | Apply a transformation to the decls contained in @t@+modifyDeclsT :: (HasDecls t,HasTransform m)+             => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs])+             -> t -> m t+modifyDeclsT action t = do+  let decls = hsDecls t+  decls' <- action decls+  return $ replaceDecls t decls'
src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -1,57 +1,23 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf           #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE StandaloneDeriving   #-} {-# LANGUAGE TypeSynonymInstances #-}-module Language.Haskell.GHC.ExactPrint.Types-  ( -- * Core Types-   Anns-  , emptyAnns-  , Annotation(..)-  , annNone--  , KeywordId(..)-  , Comment(..)-  -- * Positions-  , Pos-  , DeltaPos(..)-  , deltaRow, deltaColumn-  -- * AnnKey-  , AnnKey(..)-  , mkAnnKey-  , AnnConName(..)-  , annGetConstr--  -- * Other--  , Rigidity(..)-  , AstContext(..),AstContextSet,defaultACS-  , ACS'(..)-  , ListContexts(..)--  -- * GHC version compatibility-  , GhcPs-  , GhcRn-  , GhcTc--  -- * Internal Types-  , LayoutStartCol(..)-  , declFun+{-# LANGUAGE ViewPatterns         #-} -  ) where+module Language.Haskell.GHC.ExactPrint.Types+  where -import Data.Data (Data, Typeable, toConstr,cast)+import Data.Data hiding (Fixity)+import GHC hiding (EpaComment)+import GHC.Utils.Outputable hiding ( (<>) ) -import qualified DynFlags      as GHC-import qualified GHC-import qualified Outputable    as GHC+-- --------------------------------------------------------------------- -import qualified Data.Map as Map-import qualified Data.Set as Set+type Pos = (Int,Int)  -- --------------------------------------------------------------------- @@ -61,29 +27,26 @@ data Comment = Comment     {       commentContents   :: !String -- ^ The contents of the comment including separators--    -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is-    -- the thing we use to decide where in the output stream the comment should-    -- go.-    , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents-    , commentOrigin     :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.+    , commentLoc :: !NoCommentsLocation+    , commentPriorTok :: !RealSrcSpan+    , commentOrigin :: !(Maybe String) -- ^ We sometimes turn syntax into comments in order to process them properly.     }-  deriving (Eq,Typeable,Data,Ord)-instance Show Comment where-  show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"--instance GHC.Outputable Comment where-  ppr x = GHC.text (show x)--type Pos = (Int,Int)+  deriving (Data, Eq) --- | A relative positions, row then column-newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)+instance Show Comment where+  show (Comment cs ss r o)+    = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show r ++ " " ++ show o ++ ")" -deltaRow, deltaColumn :: DeltaPos -> Int-deltaRow (DP (r, _)) = r-deltaColumn (DP (_, c)) = c+instance Ord Comment where+  -- When we have CPP injected comments with a fake filename, or LINE+  -- pragma, the file name changes, so we need to compare the+  -- locations only, with out the filename.+  compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ epaLocationRealSrcSpan ss1) (ss2pos $ epaLocationRealSrcSpan ss2)+    where+      ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) +instance Outputable Comment where+  ppr x = text (show x)  -- | Marks the start column of a layout block. newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }@@ -92,314 +55,8 @@ instance Show LayoutStartCol where   show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" --annNone :: Annotation-annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing--data Annotation = Ann-  {-    -- The first three fields relate to interfacing up into the AST-    annEntryDelta      :: !DeltaPos-    -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior-    -- output was, including all annPriorComments (field below).-  , annPriorComments   :: ![(Comment,  DeltaPos)]-    -- ^ Comments coming after the last non-comment output of the preceding-    -- element but before the SrcSpan being annotated by this Annotation. If-    -- these are changed then annEntryDelta (field above) must also change to-    -- match.-  , annFollowingComments   :: ![(Comment,  DeltaPos)]-    -- ^ Comments coming after the last output for the element subject to this-    -- Annotation. These will only be added by AST transformations, and care-    -- must be taken not to disturb layout of following elements.--  -- The next three fields relate to interacing down into the AST-  , annsDP             :: ![(KeywordId, DeltaPos)]-    -- ^ Annotations associated with this element.-  , annSortKey         :: !(Maybe [GHC.SrcSpan])-    -- ^ Captures the sort order of sub elements. This is needed when the-    -- sub-elements have been split (as in a HsLocalBind which holds separate-    -- binds and sigs) or for infix patterns where the order has been-    -- re-arranged. It is captured explicitly so that after the Delta phase a-    -- SrcSpan is used purely as an index into the annotations, allowing-    -- transformations of the AST including the introduction of new Located-    -- items or re-arranging existing ones.-  , annCapturedSpan    :: !(Maybe AnnKey)-    -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of-    -- elements which we must remember for the Print phase. e.g. the statements-    -- in a HsLet or HsDo. These must be managed as a group because they all-    -- need eo be vertically aligned for the Haskell layout rules, and this-    -- guarantees this property in the presence of AST edits.--  } deriving (Typeable,Eq)--instance Show Annotation where-  show (Ann dp comments fcomments ans sk csp)-    = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " "-        ++ show fcomments ++ " "-        ++ show ans ++ " " ++ showGhc sk ++ " "-        ++ showGhc csp ++ ")"----- | This structure holds a complete set of annotations for an AST-type Anns = Map.Map AnnKey Annotation--emptyAnns :: Anns-emptyAnns = Map.empty---- | For every @Located a@, use the @SrcSpan@ and constructor name of--- a as the key, to store the standard annotation.--- These are used to maintain context in the AP and EP monads-data AnnKey   = AnnKey GHC.SrcSpan AnnConName-                  deriving (Eq, Ord, Data)---- More compact Show instance-instance Show AnnKey where-  show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn--mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey-mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a)---#if __GLASGOW_HASKELL__ <= 802-type GhcPs = GHC.RdrName-type GhcRn = GHC.Name-type GhcTc = GHC.Id-#else-type GhcPs = GHC.GhcPs-type GhcRn = GHC.GhcRn-type GhcTc = GHC.GhcTc-#endif---- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.-mkAnnKey :: (Data a) => GHC.Located a -> AnnKey-mkAnnKey ld =-  case cast ld :: Maybe (GHC.LHsDecl GhcPs) of-    Just d -> declFun mkAnnKeyPrim d-    Nothing -> mkAnnKeyPrim ld---- Holds the name of a constructor-data AnnConName = CN { unConName :: String }-                 deriving (Eq, Ord, Data)---- More compact show instance-instance Show AnnConName where-  show (CN s) = "CN " ++ show s--annGetConstr :: (Data a) => a -> AnnConName-annGetConstr a = CN (show $ toConstr a)---- | The different syntactic elements which are not represented in the--- AST.-data KeywordId = G GHC.AnnKeywordId  -- ^ A normal keyword-               | AnnSemiSep          -- ^ A separating comma-#if __GLASGOW_HASKELL__ >= 800-               | AnnTypeApp          -- ^ Visible type application annotation-#endif-               | AnnComment Comment-               | AnnString String    -- ^ Used to pass information from-                                     -- Delta to Print when we have to work-                                     -- out details from the original-                                     -- SrcSpan.-#if __GLASGOW_HASKELL__ <= 710-               | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible.-#endif-               deriving (Eq, Ord, Data)--instance Show KeywordId where-  show (G gc)          = "(G " ++ show gc ++ ")"-  show AnnSemiSep      = "AnnSemiSep"-#if __GLASGOW_HASKELL__ >= 800-  show AnnTypeApp      = "AnnTypeApp"-#endif-  show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"-  show (AnnString s)   = "(AnnString " ++ s ++ ")"-#if __GLASGOW_HASKELL__ <= 710-  show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")"-#endif- -- --------------------------------------------------------------------- -instance GHC.Outputable KeywordId where-  ppr k     = GHC.text (show k)--instance GHC.Outputable AnnConName where-  ppr tr     = GHC.text (show tr)--instance GHC.Outputable Annotation where-  ppr a     = GHC.text (show a)--instance GHC.Outputable AnnKey where-  ppr a     = GHC.text (show a)--instance GHC.Outputable DeltaPos where-  ppr a     = GHC.text (show a)---- --------------------------------------------------------------------------- Flag used to control whether we use rigid or normal layout rules.--- NOTE: check is done via comparison of enumeration order, be careful with any changes-data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)-{---Rigidity logic. The same type is used for two different things--1. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies-   NormalLayout - Layout should be captured unconditionally--   RigidLayout - Layout should be captured or not depending on a parameter kept-                 in the interpreter Read state--2. As the controlling parameter for the optional (Rigid) layout--The nett effect is the following, where flag is the hard-coded flag value in-Annotate, and param is the interpreter param set when the interpreter is run--   flag         |  param       | result-   -------------+--------------+---------------------   NormalLayout |  either      | layout captured-   RigidLayout  | NormalLayout | layout NOT captured-   RigidLayout  | RigidLayout  | layout captured--The flag is only used on HsIf and HsCase--So--   state                       | HsCase    | HsIf-   ----------------------------|-----------+-------   before rigidity flag (AZ)   | no layout | layout-   param NormalLayout          | no layout | no layout-   param RigidLayout           | layout    | layout-   ----------------------------+-----------+--------   desired future HaRe         | no layout | layout-   desired future apply-refact | layout    | layout--}---- -----------------------------------------------------------------------data ACS' a = ACS-  { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should-                            -- propagate down the AST. Removed when it hits zero-  } deriving (Show)--#if __GLASGOW_HASKELL__ >= 804-instance Semigroup (ACS' AstContext) where-  (<>) = mappend-#endif--instance Monoid (ACS' AstContext) where-  mempty = ACS mempty-  -- ACS a `mappend` ACS b = ACS (a `mappend` b)-  ACS a `mappend` ACS b = ACS (Map.unionWith max a b)-  -- For Data.Map, mappend == union, which is a left-biased replace for key collisions--type AstContextSet = ACS' AstContext--- data AstContextSet = ACS---   { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should---                                      -- propagate down the AST. Removed when it---                                      -- hits zero---   } deriving (Show)--defaultACS :: AstContextSet-defaultACS = ACS Map.empty---- instance GHC.Outputable AstContextSet where-instance (Show a) => GHC.Outputable (ACS' a) where-  ppr x = GHC.text $ show x--data AstContext = LambdaExpr-                | CaseAlt-                | NoPrecedingSpace-                | HasHiding-                | AdvanceLine-                | NoAdvanceLine-                | Intercalate -- This item may have a list separator following-                | InIE -- possible 'type' or 'pattern'-                | PrefixOp-                | PrefixOpDollar-                | InfixOp -- RdrName may be used as an infix operator-                | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently-                | ListItem -- Identifies subsequent elements of a list in layout-                | TopLevel -- top level declaration-                | NoDarrow-                | AddVbar-                | Deriving-                | Parens -- TODO: Not currently used?-                | ExplicitNeverActive-                | InGadt-                | InRecCon-                | InClassDecl-                | InSpliceDecl-                | LeftMost -- Is this the leftmost operator in a chain of OpApps?--                -- Next four used to identify current list context-                | CtxOnly-                | CtxFirst-                | CtxMiddle-                | CtxLast-                | CtxPos Int -- 0 for first, increasing for subsequent--                -- Next are used in tellContext to push context up the tree-                | FollowingLine-                deriving (Eq, Ord, Show)---data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) }-  deriving (Eq,Show)---- ------------------------------------------------------------------------- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD---                                    -- should not have blank lines after it---                 deriving (Eq, Ord, Show)---- -----------------------------------------------------------------------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)-      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.VectD 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)-#if __GLASGOW_HASKELL__ < 711-      GHC.QuasiQuoteD d -> f (GHC.L l d)-#endif-#endif---- ---------------------------------------------------------------------- -- Duplicated here so it can be used in show instances-showGhc :: (GHC.Outputable a) => a -> String-showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags---- ----------------------------------------------------------------------+showGhc :: (Outputable a) => a -> String+showGhc = showPprUnsafe
src/Language/Haskell/GHC/ExactPrint/Utils.hs view
@@ -1,624 +1,756 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Haskell.GHC.ExactPrint.Utils-  (-   -- * Manipulating Positons-    ss2pos-  , ss2posEnd-  , undelta-  , isPointSrcSpan-  , pos2delta-  , ss2delta-  , addDP-  , spanLength-  , isGoodDelta--  -- * Manipulating Comments-  , mkComment-  , mkKWComment-  , dpFromString-  , comment2dp-  , extractComments--    -- * GHC Functions-  , srcSpanStartLine-  , srcSpanEndLine-  , srcSpanStartColumn-  , srcSpanEndColumn-  , rdrName2String-  , isSymbolRdrName-  , tokComment-  , isListComp-  , isGadt-  , isExactName---  -- * Manipulating Annotations-  , getAnnotationEP-  , annTrueEntryDelta-  , annCommentEntryDelta-  , annLeadingCommentEntryDelta--  -- * General Utility-  , orderByKey---  -- * AST Context management-  , setAcs, setAcsWithLevel-  , unsetAcs-  , inAcs-  , pushAcs-  , bumpAcs--#if __GLASGOW_HASKELL__ <= 710-  -- * for boolean formulas in GHC 7.10.3-  -- ,LBooleanFormula, BooleanFormula(..)-  , makeBooleanFormulaAnns-#endif--  -- * For tests-  , debug-  , debugP-  , debugM-  , warn-  , showGhc-  , showAnnData-  , occAttributes--  , showSDoc_,  showSDocDebug_-  -- AZ's baggage-  , ghead,glast,gtail,gfromJust-  ) where---import Control.Monad.State-import qualified Data.ByteString as B-import Data.Generics-import Data.Ord (comparing)--import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Lookup--import qualified Bag            as GHC-#if __GLASGOW_HASKELL__ <= 710-import qualified BooleanFormula as GHC-#endif-import qualified DynFlags       as GHC-import qualified FastString     as GHC-import qualified GHC-import qualified Name           as GHC-import qualified NameSet        as GHC-import qualified Outputable     as GHC-import qualified RdrName        as GHC-import qualified SrcLoc         as GHC-import qualified Var            as GHC--import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief)--import Control.Arrow--import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.List--import Debug.Trace--{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Redundant do" #-}-{-# ANN module "HLint: ignore Reduce duplication" #-}--- ------------------------------------------------------------------------- |Global switch to enable debug tracing in ghc-exactprint Delta / Print-debugEnabledFlag :: Bool--- debugEnabledFlag = True-debugEnabledFlag = False---- |Global switch to enable debug tracing in ghc-exactprint Pretty-debugPEnabledFlag :: Bool--- debugPEnabledFlag = True-debugPEnabledFlag = False---- |Provide a version of trace that comes at the end of the line, so it can--- easily be commented out when debugging different things.-debug :: c -> String -> c-debug c s = if debugEnabledFlag-              then trace s c-              else c---- |Provide a version of trace for the Pretty module, which can be enabled--- separately from 'debug' and 'debugM'-debugP :: String -> c -> c-debugP s c = if debugPEnabledFlag-               then trace s c-               else c--debugM :: Monad m => String -> m ()-debugM s = when debugEnabledFlag $ traceM s---- | Show a GHC.Outputable structure-showGhc :: (GHC.Outputable a) => a -> String-showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags---- -----------------------------------------------------------------------warn :: c -> String -> c--- warn = flip trace-warn c _ = c---- | A good delta has no negative values.-isGoodDelta :: DeltaPos -> Bool-isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0----- | Create a delta from the current position to the start of the given--- @SrcSpan@.-ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos-ss2delta ref ss = pos2delta ref (ss2pos ss)---- | Convert the start of the second @Pos@ to be an offset from the--- first. The assumption is the reference starts before the second @Pos@-pos2delta :: Pos -> Pos -> DeltaPos-pos2delta (refl,refc) (l,c) = DP (lo,co)-  where-    lo = l - refl-    co = if lo == 0 then c - refc-                    else c---- | Apply the delta to the current position, taking into account the--- current column offset if advancing to a new line-undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos-undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc)-  where-    fl = l + dl-    fc = if dl == 0 then c  + dc-                    else co + dc---- | Add together two @DeltaPos@ taking into account newlines------ > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3)--- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5)--- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3)-addDP :: DeltaPos -> DeltaPos -> DeltaPos-addDP (DP (a, b)) (DP (c, d)) =-  if c >= 1 then DP (a+c, d)-            else DP (a,   b+d)---- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the--- remaining delta for the second after the first has been applied.--- invariant : if c = a `addDP` b---             then a `stepDP` c == b------ Cases where first DP is <= than second--- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1)--- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0)--- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1)--- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4)------ Cases where first DP is > than second--- > DP (0,  3) `addDP` DP (0, 2) == DP (0,1)  -- advance one at least--- > DP (3,  3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col--- > DP (3,  3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least--- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col-stepDP :: DeltaPos -> DeltaPos -> DeltaPos-stepDP (DP (a,b)) (DP (c,d))-  | (a,b) == (c,d) = DP (a,b)-  | a == c = if b < d then DP (0,d - b)-                      else if d == 0-                             then DP (1,0)-                             -- else DP (0,1)-                             else DP (c,d)-  | a < c = DP (c - a,d)-  | otherwise = DP (1,d)---- -----------------------------------------------------------------------ss2pos :: GHC.SrcSpan -> Pos-ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss)--ss2posEnd :: GHC.SrcSpan -> Pos-ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss)--srcSpanEndColumn :: GHC.SrcSpan -> Int-srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s-srcSpanEndColumn _ = 0--srcSpanStartColumn :: GHC.SrcSpan -> Int-srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s-srcSpanStartColumn _ = 0--srcSpanEndLine :: GHC.SrcSpan -> Int-srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s-srcSpanEndLine _ = 0--srcSpanStartLine :: GHC.SrcSpan -> Int-srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s-srcSpanStartLine _ = 0--spanLength :: GHC.SrcSpan -> Int-spanLength = (-) <$> srcSpanEndColumn <*> srcSpanStartColumn---- ------------------------------------------------------------------------ | Checks whether a SrcSpan has zero length.-isPointSrcSpan :: GHC.SrcSpan -> Bool-isPointSrcSpan ss = spanLength ss == 0-                  && srcSpanStartLine ss == srcSpanEndLine ss---- ------------------------------------------------------------------------- |Given a list of items and a list of keys, returns a list of items--- ordered by their position in the list of keys.-orderByKey :: [(GHC.SrcSpan,a)] -> [GHC.SrcSpan] -> [(GHC.SrcSpan,a)]-orderByKey keys order-    -- AZ:TODO: if performance becomes a problem, consider a Map of the order-    -- SrcSpan to an index, and do a lookup instead of elemIndex.--    -- Items not in the ordering are placed to the start- = sortBy (comparing (flip elemIndex order . fst)) keys---- -----------------------------------------------------------------------isListComp :: GHC.HsStmtContext name -> Bool-isListComp cts = case cts of-          GHC.ListComp  -> True-          GHC.MonadComp -> True-#if __GLASGOW_HASKELL__ <= 804-          GHC.PArrComp  -> True-#endif--          GHC.DoExpr       -> False-          GHC.MDoExpr      -> False-          GHC.ArrowExpr    -> False-          GHC.GhciStmtCtxt -> False--          GHC.PatGuard {}      -> False-          GHC.ParStmtCtxt {}   -> False-          GHC.TransStmtCtxt {} -> False---- -----------------------------------------------------------------------isGadt :: [GHC.LConDecl name] -> Bool-isGadt [] = False-#if __GLASGOW_HASKELL__ <= 710-isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True-#else-isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True-#endif-isGadt _ = False---- ------------------------------------------------------------------------- Is a RdrName of type Exact? SYB query, so can be extended to other types too-isExactName :: (Data name) => name -> Bool-isExactName = False `mkQ` GHC.isExact---- -----------------------------------------------------------------------ghcCommentText :: GHC.Located GHC.AnnotationComment -> String-ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s))  = s-ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s))  = s-ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s-ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s))    = s-ghcCommentText (GHC.L _ (GHC.AnnDocOptions s))      = s-#if __GLASGOW_HASKELL__ < 801-ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s))   = s-#endif-ghcCommentText (GHC.L _ (GHC.AnnLineComment s))     = s-ghcCommentText (GHC.L _ (GHC.AnnBlockComment s))    = s--tokComment :: GHC.Located GHC.AnnotationComment -> Comment-tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt--mkComment :: String -> GHC.SrcSpan -> Comment-mkComment c ss = Comment c ss Nothing---- | Makes a comment which originates from a specific keyword.-mkKWComment :: GHC.AnnKeywordId -> GHC.SrcSpan -> Comment-mkKWComment kw ss = Comment (keywordToString $ G kw) ss (Just kw)--comment2dp :: (Comment,  DeltaPos) -> (KeywordId, DeltaPos)-comment2dp = first AnnComment--extractComments :: GHC.ApiAnns -> [Comment]-extractComments (_,cm)-  -- cm has type :: Map SrcSpan [Located AnnotationComment]-  = map tokComment . GHC.sortLocated . concat $ Map.elems cm--getAnnotationEP :: (Data a) =>  GHC.Located a  -> Anns -> Maybe Annotation-getAnnotationEP  la as =-  Map.lookup (mkAnnKey la) as---- | The "true entry" is the distance from the last concrete element to the--- start of the current element.-annTrueEntryDelta :: Annotation -> DeltaPos-annTrueEntryDelta Ann{annEntryDelta, annPriorComments} =-  foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )-    `addDP` annEntryDelta---- | Take an annotation and a required "true entry" and calculate an equivalent--- one relative to the last comment in the annPriorComments.-annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos-annCommentEntryDelta Ann{annPriorComments} trueDP = dp-  where-    commentDP =-      foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )-    dp = stepDP commentDP trueDP---- | Return the DP of the first item that generates output, either a comment or the entry DP-annLeadingCommentEntryDelta :: Annotation -> DeltaPos-annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp-  where-    dp = case annPriorComments of-      [] -> annEntryDelta-      ((_,ed):_) -> ed---- | Calculates the distance from the start of a string to the end of--- a string.-dpFromString ::  String -> DeltaPos-dpFromString xs = dpFromString' xs 0 0-  where-    dpFromString' "" line col = DP (line, col)-    dpFromString' ('\n': cs) line _   = dpFromString' cs (line + 1) 0-    dpFromString' (_:cs)     line col = dpFromString' cs line       (col + 1)---- -----------------------------------------------------------------------isSymbolRdrName :: GHC.RdrName -> Bool-isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n--rdrName2String :: GHC.RdrName -> String-rdrName2String r =-  case GHC.isExact_maybe r of-    Just n  -> name2String n-    Nothing ->-      case r of-        GHC.Unqual occ       -> GHC.occNameString occ-        GHC.Qual modname occ -> GHC.moduleNameString modname ++ "."-                                ++ GHC.occNameString occ-        GHC.Orig _ occ       -> GHC.occNameString occ-        GHC.Exact n          -> GHC.getOccString n--name2String :: GHC.Name -> String-name2String = showGhc---- ------------------------------------------------------------------------- | Put the provided context elements into the existing set with fresh level--- counts-setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet-setAcs ctxt acs = setAcsWithLevel ctxt 3 acs---- | Put the provided context elements into the existing set with given level--- counts--- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet--- setAcsWithLevel ctxt level (ACS a) = ACS a'---   where---     upd s (k,v) = Map.insert k v s---     a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level)-setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a-setAcsWithLevel ctxt level (ACS a) = ACS a'-  where-    upd s (k,v) = Map.insert k v s-    a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level)---- ------------------------------------------------------------------------ | Remove the provided context element from the existing set--- unsetAcs :: AstContext -> AstContextSet -> AstContextSet-unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a-unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a---- ------------------------------------------------------------------------- | Are any of the contexts currently active?--- inAcs :: Set.Set AstContext -> AstContextSet -> Bool-inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool-inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a)---- | propagate the ACS down a level, dropping all values which hit zero--- pushAcs :: AstContextSet -> AstContextSet-pushAcs :: ACS' a -> ACS' a-pushAcs (ACS a) = ACS $ Map.mapMaybe f a-  where-    f n-      | n <= 1    = Nothing-      | otherwise = Just (n - 1)---- |Sometimes we have to pass the context down unchanged. Bump each count up by--- one so that it is unchanged after a @pushAcs@ call.--- bumpAcs :: AstContextSet -> AstContextSet-bumpAcs :: ACS' a -> ACS' a-bumpAcs (ACS a) = ACS $ Map.mapMaybe f a-  where-    f n = Just (n + 1)---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ <= 710--  -- to be called in annotationsToCommentsBF by the pretty printer-makeBooleanFormulaAnns :: (GHC.Outputable a)-                       => GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)]-makeBooleanFormulaAnns bf = go 1 bf-  where-    go :: (GHC.Outputable a)-       => Int -> GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)]-    go _ (GHC.Var _) = []-    go l v@(GHC.And [a,b]) =-      go 3 a ++-      go 3 b ++-      (if l > 3 then addParensIfNeeded v else []) ++-      [(GHC.AnnComma, ssAfter (getBoolSrcSpan a))]-    go l v@(GHC.Or  [a,b]) =-      go 2 a ++-      go 2 b ++-      (if l > 2 then addParensIfNeeded v else []) ++-      [(GHC.AnnVbar,  ssAfter (getBoolSrcSpan a) )]-    go _ x = error $ "makeBooleanFormulaAnns: unexpected case:" ++ showGhc x---addParensIfNeeded :: GHC.Outputable a-                  => GHC.BooleanFormula (GHC.Located a)-                  -> [(GHC.AnnKeywordId, GHC.SrcSpan)]-addParensIfNeeded (GHC.Var _) = []-addParensIfNeeded a = [(GHC.AnnOpenP,opp),(GHC.AnnCloseP,cpp)]-  where-    ss = getBoolSrcSpan a-    opp = ssBefore ss-    cpp = ssAfter ss----- ssFor a b = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b)---- | Generate a SrcSpan of single char length before the given one-ssBefore :: GHC.SrcSpan -> GHC.SrcSpan-ssBefore a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e)-  where-    GHC.RealSrcLoc as = GHC.srcSpanStart a-    s = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 2)-    e = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 1)---- | Generate a SrcSpan of single char length after the given one-ssAfter :: GHC.SrcSpan -> GHC.SrcSpan-ssAfter a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e)-  where-    GHC.RealSrcLoc ae = GHC.srcSpanEnd a-    s = ae-    e = GHC.advanceSrcLoc s  ' '---getBoolSrcSpan :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> GHC.SrcSpan-getBoolSrcSpan (GHC.Var (GHC.L ss _)) = ss-getBoolSrcSpan (GHC.And [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b)-getBoolSrcSpan (GHC.Or  [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b)-getBoolSrcSpan x = error $ "getBoolSrcSpan: unexpected case:" ++ showGhc x--#endif---- ------------------------------------------------------------------------- | Show a GHC AST with interleaved Annotation information.-showAnnData :: Data a => Anns -> Int -> a -> String-showAnnData anns n =-  generic -- `ext1Q` located-          `ext1Q` list-          `extQ` string `extQ` fastString `extQ` srcSpan-          `extQ` bytestring-          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon-          -- `extQ` overLit-          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-          `extQ` fixity-          `ext2Q` located-  where generic :: Data a => a -> String-        generic t = indent n ++ "(" ++ showConstr (toConstr t)-                 ++ space (unwords (gmapQ (showAnnData anns (n+1)) t)) ++ ")"-        space "" = ""-        space s  = ' ':s-        indent i = "\n" ++ replicate i ' '-        string     = show :: String -> String-        fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String-        bytestring = show :: B.ByteString -> String-        list l     = indent n ++ "["-                              ++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]"--        name       = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String-        -- occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString-        occName o   = "{OccName: "++ OccName.occNameString o ++ " " ++ occAttributes o ++ "}"-        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String--        -- srcSpan    = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String-        srcSpan :: GHC.SrcSpan -> String-        srcSpan ss = "{ "++ showSDoc_ (GHC.hang (GHC.ppr ss) (n+2)-                                                 -- (GHC.ppr (Map.lookup ss anns)-                                                 (GHC.text "")-                                                 )-                      ++"}"--        var        = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String-        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String--        -- overLit :: GHC.HsOverLit GHC.RdrName -> String-        -- overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr--        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String-        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList-        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String-        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList-        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String-        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList--#if __GLASGOW_HASKELL__ > 800-        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable-#else-        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems-#endif--        fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String--        located :: (Data b,Data loc) => GHC.GenLocated loc b -> String-        -- located la = show (getAnnotationEP la anns)-        located (GHC.L ss a) =-          indent n ++ "("-            ++ case cast ss of-                    Just (s :: GHC.SrcSpan) ->-                      srcSpan s-                      ++ indent (n + 1) ++-                      show (getAnnotationEP (GHC.L s a) anns)-                      -- ++ case showWrappedDeclAnns (GHC.L s a) of-                      --   Nothing -> ""-                      --   Just annStr  -> indent (n + 1) ++ annStr-                    Nothing -> "nnnnnnnn"-                  ++ showAnnData anns (n+1) a-                  ++ ")"---occAttributes :: OccName.OccName -> String-occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"-  where-    ns = (GHC.showSDocUnsafe $ OccName.pprNameSpaceBrief $ GHC.occNameSpace o) ++ ", "-    vo = if GHC.isVarOcc     o then "Var "     else ""-    tv = if GHC.isTvOcc      o then "Tv "      else ""-    tc = if GHC.isTcOcc      o then "Tc "      else ""-    d  = if GHC.isDataOcc    o then "Data "    else ""-    ds = if GHC.isDataSymOcc o then "DataSym " else ""-    s  = if GHC.isSymOcc     o then "Sym "     else ""-    v  = if GHC.isValOcc     o then "Val "     else ""--{--data NameSpace = VarName        -- Variables, including "real" data constructors-               | DataName       -- "Source" data constructors-               | TvName         -- Type variables-               | TcClsName      -- Type constructors and classes; Haskell has them-                                -- in the same name space for now.--}-- -- -----------------------------------------------------------------------showSDoc_ :: GHC.SDoc -> String-showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags--showSDocDebug_ :: GHC.SDoc -> String-#if __GLASGOW_HASKELL__ <= 710-showSDocDebug_ = GHC.showSDoc GHC.unsafeGlobalDynFlags-#else-showSDocDebug_ = GHC.showSDocDebug GHC.unsafeGlobalDynFlags-#endif---- ------------------------------------------------------------------------ Putting these here for the time being, to avoid import loops--ghead :: String -> [a] -> a-ghead  info []    = error $ "ghead "++info++" []"-ghead _info (h:_) = h--glast :: String -> [a] -> a-glast  info []    = error $ "glast " ++ info ++ " []"-glast _info h     = last h--gtail :: String -> [a] -> [a]-gtail  info []   = error $ "gtail " ++ info ++ " []"-gtail _info h    = tail h--gfromJust :: String -> Maybe a -> a-gfromJust _info (Just h) = h-gfromJust  info Nothing = error $ "gfromJust " ++ info ++ " Nothing"+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.GHC.ExactPrint.Utils+    -- (+    --   showAst+    -- , ss2pos, ss2posEnd+    -- , ss2delta, ss2deltaEnd+    -- , ss2range+    -- , rs+    -- , debug, debugM+    -- , adjustDeltaForOffset+    -- , sortEpaComments+    -- , epaCommentsBalanced+    -- , notDocDecl+    -- , notIEDoc+    -- , hsDeclsLocalBinds+    -- , hsDeclsClassDecl+    -- , hsDeclsValBinds+    -- , captureOrderBinds+    -- , wrapSig, wrapDecl+    -- , decl2Sig+    -- , mkLEpaComment+    -- , mkEpaComments+    -- , mkKWComment+    -- , tokComment+    -- , comment2LEpaComment+    -- , commentOrigDelta+    -- , replaceDeclsClassDecl+    -- , decl2Bind+    -- , badRealSrcSpan+    -- , rs2range+    -- , origDelta+    -- , dedentDocChunk+    -- , orderedDecls+    -- , needsWhere+    -- , undelta+    -- , spanLength+    -- , isGoodDelta+    -- , dpFromString+    -- , insertCppComments+    -- )+    where++import Control.Monad (when)+-- import Control.Monad.State.Lazy+import GHC.Utils.Monad.State.Strict+import Data.Data hiding ( Fixity )+import Data.Function+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.List+import qualified Data.Map.Strict as Map++import qualified GHC+import GHC hiding (EpaComment)+import GHC.Base (NonEmpty(..))+import GHC.Data.FastString+import GHC.Driver.Ppr+import GHC.Hs.Dump+import GHC.Parser.Lexer (allocateComments)+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc++import Language.Haskell.GHC.ExactPrint.Types++import Debug.Trace++-- ---------------------------------------------------------------------++-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print+debugEnabledFlag :: Bool+-- debugEnabledFlag = True+debugEnabledFlag = False++-- |Provide a version of trace that comes at the end of the line, so it can+-- easily be commented out when debugging different things.+debug :: c -> String -> c+debug c s = if debugEnabledFlag+              then trace s c+              else c+debugM :: Monad m => String -> m ()+debugM s = when debugEnabledFlag $ traceM s++warn :: c -> String -> c+-- warn = flip trace+warn c _ = c++-- ---------------------------------------------------------------------++captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag+captureOrderBinds ls = AnnSortKey $ map go ls+  where+    go (L _ (ValD _ _))       = BindTag+    go (L _ (SigD _ _))       = SigDTag+    go d      = error $ "captureOrderBinds:" ++ showGhc d++-- ---------------------------------------------------------------------++notDocDecl :: LHsDecl GhcPs -> Bool+notDocDecl (L _ DocD{}) = False+notDocDecl _ = True++notIEDoc :: LIE GhcPs -> Bool+notIEDoc (L _ IEGroup {})    = False+notIEDoc (L _ IEDoc {})      = False+notIEDoc (L _ IEDocNamed {}) = False+notIEDoc _ = True++-- ---------------------------------------------------------------------+-- | A good delta has no negative values.+isGoodDelta :: DeltaPos -> Bool+isGoodDelta (SameLine co) = co >= 0+isGoodDelta (DifferentLine ro _co) = ro > 0+  -- Note: DifferentLine invariant is ro is nonzero and positive+++-- | Create a delta from the current position to the start of the given+-- @RealSrcSpan@.+ss2delta :: Pos -> RealSrcSpan -> DeltaPos+ss2delta ref ss = pos2delta ref (ss2pos ss)++-- | create a delta from the end of a current span.  The +1 is because+-- the stored position ends up one past the span, this is prior to+-- that adjustment+ss2deltaEnd :: RealSrcSpan -> RealSrcSpan -> DeltaPos+ss2deltaEnd rrs ss = ss2delta ref ss+  where+    (r,c) = ss2posEnd rrs+    ref = if r == 0+             then (r,c+1)+             else (r,c)++-- | create a delta from the start of a current span.  The +1 is+-- because the stored position ends up one past the span, this is+-- prior to that adjustment+ss2deltaStart :: RealSrcSpan -> RealSrcSpan -> DeltaPos+ss2deltaStart rrs ss = ss2delta ref ss+  where+    (r,c) = ss2pos rrs+    ref = if r == 0+             then (r,c)+             else (r,c)++-- | Convert the start of the second @Pos@ to be an offset from the+-- first. The assumption is the reference starts before the second @Pos@+pos2delta :: Pos -> Pos -> DeltaPos+pos2delta (refl,refc) (l,c) = deltaPos lo co+  where+    lo = l - refl+    co = if lo == 0 then c - refc+                    else c++-- | Apply the delta to the current position, taking into account the+-- current column offset if advancing to a new line+undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos+undelta (l,c) (SameLine dc)         (LayoutStartCol _co) = (l, c + dc)+undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)+  where+    -- Note: invariant: dl > 0+    fl = l + dl+    fc = co + dc++-- ---------------------------------------------------------------------++adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos+adjustDeltaForOffset _colOffset              dp@(SameLine _) = dp+adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)+  = DifferentLine l (c - colOffset)++-- ---------------------------------------------------------------------++ss2pos :: RealSrcSpan -> Pos+ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)++ss2posEnd :: RealSrcSpan -> Pos+ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndCol ss)++ss2range :: SrcSpan -> (Pos,Pos)+ss2range ss = (ss2pos $ rs ss, ss2posEnd $ rs ss)++rs2range :: RealSrcSpan -> (Pos,Pos)+rs2range ss = (ss2pos ss, ss2posEnd ss)++rs :: SrcSpan -> RealSrcSpan+rs (RealSrcSpan s _) = s+rs _ = badRealSrcSpan++range2rs :: (Pos,Pos) -> RealSrcSpan+range2rs (s,e) = mkRealSrcSpan (mkLoc s) (mkLoc e)+  where+    mkLoc (l,c) = mkRealSrcLoc (fsLit "ghc-exactprint") l c++badRealSrcSpan :: RealSrcSpan+badRealSrcSpan = mkRealSrcSpan bad bad+  where+    bad = mkRealSrcLoc (fsLit "ghc-exactprint-nospan") 0 0++spanLength :: RealSrcSpan -> Int+spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol+++-- | Useful for debug dumps+eloc2str :: EpaLocation -> String+eloc2str (EpaSpan r) = "EpaSpan " ++ show (ss2range r)+eloc2str epaLoc = show epaLoc++-- ---------------------------------------------------------------------+-- | Checks whether a SrcSpan has zero length.+isPointSrcSpan :: RealSrcSpan -> Bool+isPointSrcSpan ss = spanLength ss == 0+                  && srcSpanStartLine ss == srcSpanEndLine ss++-- ---------------------------------------------------------------------++-- | A GHC comment includes the span of the preceding token.  Take an+-- original comment, and convert the 'Anchor to have a have a+-- `MovedAnchor` operation based on the original location, only if it+-- does not already have one.+commentOrigDelta :: LEpaComment -> LEpaComment+commentOrigDelta (L (EpaSpan ss@(RealSrcSpan la _)) (GHC.EpaComment t pp))+  = (L (EpaDelta ss dp' NoComments) (GHC.EpaComment t pp))+                  `debug` ("commentOrigDelta: (la, pp, r,c, dp, dp')=" ++ showAst (la, pp, r,c, dp, dp'))+  where+        (r,c) = ss2posEnd pp++        dp = if r == 0+               then (ss2delta (r,c+1) la)+               else (ss2delta (r,c)   la)+        dp' = case dp of+            SameLine _ -> dp+            DifferentLine l cc -> DifferentLine l (cc - 1)+commentOrigDelta c = c++origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos+origDelta pos pp = ss2delta (ss2posEnd pp) pos++-- ---------------------------------------------------------------------++needsWhere :: DataDefnCons (LConDecl (GhcPass p)) -> Bool+needsWhere (NewTypeCon _) = True+needsWhere (DataTypeCons _ []) = True+needsWhere (DataTypeCons _ ((L _ (ConDeclGADT{})):_)) = True+needsWhere _ = False++-- ---------------------------------------------------------------------++-- | Insert the comments at the appropriate places in the AST+insertCppComments ::  ParsedSource -> [LEpaComment] -> ParsedSource+-- insertCppComments p [] = p+insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining+  where+    (EpAnn anct ant cst) = hsmodAnn $ hsmodExt p+    cs = sortEpaComments $ priorComments cst ++ getFollowingComments cst ++ cs0+    p0 = p { hsmodExt = (hsmodExt p) { hsmodAnn = EpAnn anct ant emptyComments }}+    -- Comments embedded within spans+    -- everywhereM is a bottom-up traversal+    (p1, toplevel) = runState (everywhereM (mkM   addCommentsListItem+                                           `extM` addCommentsGrhs+                                           `extM` addCommentsList) p0) cs+    (p2, remaining) = insertTopLevelCppComments p1 toplevel++    addCommentsListItem :: EpAnn AnnListItem -> State [LEpaComment] (EpAnn AnnListItem)+    addCommentsListItem = addComments++    addCommentsList :: EpAnn (AnnList ()) -> State [LEpaComment] (EpAnn (AnnList ()))+    addCommentsList = addComments++    addCommentsGrhs :: EpAnn GrhsAnn -> State [LEpaComment] (EpAnn GrhsAnn)+    addCommentsGrhs = addComments++    addComments :: forall ann. EpAnn ann -> State [LEpaComment] (EpAnn ann)+    addComments (EpAnn anc an ocs) = do+      case anc of+        EpaSpan (RealSrcSpan s _) -> do+          unAllocated <- get+          let+            (rest, these) = GHC.Parser.Lexer.allocateComments s unAllocated+            cs' = workInComments ocs these+          put rest+          return $ EpAnn anc an cs'++        _ -> return $ EpAnn anc an ocs++workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+workInComments ocs [] = ocs+workInComments ocs new = cs'+  where+    pc = priorComments ocs+    fc = getFollowingComments ocs+    cs' = case fc of+      [] -> EpaComments $ sortEpaComments $ pc ++ fc ++ new+      (L ac _:_) -> epaCommentsBalanced (sortEpaComments $ pc ++ cs_before)+                                        (sortEpaComments $ fc ++ cs_after)+             where+               (cs_before,cs_after)+                   = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )+                           new++insertTopLevelCppComments ::  HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])+insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs+  = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)+    -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))+    -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))+  where+    -- Comments at the top level.+    (an0, cs0) =+      case mmn of+        Nothing -> (an, cs)+        Just _ ->+            -- We have a module name. Capture all comments up to the `where`+            let+              (these, remaining) = splitOnWhere Before (am_where $ anns an) cs+              (EpAnn a anno ocs) = an :: EpAnn AnnsModule+              anm = EpAnn a anno (workInComments ocs these)+            in+              (anm, remaining)+    (an1,cs0a) = case lo of+        EpExplicitBraces (EpTok (EpaSpan (RealSrcSpan s _))) _close ->+            let+                (stay,cs0a') = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ s)) cs0+                cs' = workInComments (comments an0) stay+            in (an0 { comments = cs' }, cs0a')+        _ -> (an0,cs0)+    -- Deal with possible leading semis+    (an2, cs0b) = case am_decls $ anns an1 of+        (AddSemiAnn (EpTok (EpaSpan (RealSrcSpan s _))):_) -> (an1 {comments = cs'}, cs0b')+          where+            (stay,cs0b') = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ s)) cs0a+            cs' = workInComments (comments an1) stay+        _ -> (an1,cs0a)++    (mexports', an3, cs1) =+      case mexports of+        Nothing -> (Nothing, an2, cs0b)+        Just (L l exports) -> (Just (L l exports'), an3', cse)+                         where+                           hc1' = workInComments (comments an2) csh'+                           an3' = an2 { comments = hc1' }+                           (csh', cs0b') = case annListBracketsLocs $ al_brackets $ anns l of+                               (EpaSpan (RealSrcSpan s _),_) ->(h, n)+                                 where+                                   (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )+                                       cs0b++                               _ -> ([], cs0b)+                           (exports', cse) = allocPreceding exports cs0b'+    (imports0, cs2) = allocPreceding imports cs1+    (imports', hc0i) = balanceFirstLocatedAComments imports0++    (decls0, cs3) = allocPreceding decls cs2+    (decls', hc0d) = balanceFirstLocatedAComments decls0++    -- Either hc0i or hc0d should have comments. Combine them+    hc0 = hc0i ++ hc0d++    (hc1,hc_cs) = if NoEpTok == (am_where $ anns an3)+        then (hc0,[])+        else splitOnWhere After (am_where $ anns an3)  hc0+    hc2 = workInComments (comments an3) hc1+    an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }++    allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])+    allocPreceding [] cs' = ([], cs')+    allocPreceding (L (EpAnn anc4 an5 cs4) a:xs) cs' = ((L (EpAnn anc4 an5 cs4') a:xs'), rest')+      where+        (rest, these) =+          case anc4 of+            EpaSpan (RealSrcSpan s _) ->+                allocatePriorComments (ss2pos s) cs'+            _ -> (cs', [])+        cs4' = workInComments cs4 these+        (xs',rest') = allocPreceding xs rest++annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation)+annListBracketsLocs (ListParens o c) = (getEpTokenLoc o,    getEpTokenLoc c)+annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o,    getEpTokenLoc c)+annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o,    getEpTokenLoc c)+annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)+annListBracketsLocs ListNone         = (noAnn,              noAnn)+++data SplitWhere = Before | After++splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])+splitOnWhere w (EpTok (EpaSpan (RealSrcSpan s _))) csIn = (hc, fc)+  where+    splitFunc Before anc_pos c_pos = c_pos < anc_pos+    splitFunc After  anc_pos c_pos = anc_pos < c_pos+    (hc,fc) = break (\(L ll _) ->  splitFunc w (ss2pos $ epaLocationRealSrcSpan ll) (ss2pos s)) csIn+splitOnWhere _ _ csIn = (csIn,[])++balanceFirstLocatedAComments :: [LocatedA a] -> ([LocatedA a], [LEpaComment])+balanceFirstLocatedAComments [] = ([],[])+balanceFirstLocatedAComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd0) a:ds, hc')+  where+    (csd0, hc') = case anc of+        EpaSpan (RealSrcSpan s _) -> (csd', hc)+               `debug` ("balanceFirstLocatedAComments: (csd,csd',attached,header)=" ++ showAst (csd,csd',attached,header))+          where+            (priors, inners) =  break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )+                                       (priorComments csd)+            pcds = priorCommentsDeltas' s priors+            (attached, header) = break (\(d,_c) -> d /= 1) pcds+            csd' = setPriorComments csd (reverse (map snd attached) ++ inners)+            hc = reverse (map snd header)+        _ -> (csd, [])++++priorCommentsDeltas' :: RealSrcSpan -> [LEpaComment]+                    -> [(Int, LEpaComment)]+priorCommentsDeltas' r cs = go r (reverse cs)+  where+    go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]+    go _   [] = []+    go _   (la@(L l@(EpaDelta _ dp _) _):las) = (getDeltaLine dp, la) : go (epaLocationRealSrcSpan l) las+    go rs' (la@(L l _):las) = deltaComment rs' la : go (epaLocationRealSrcSpan l) las++    deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment)+    deltaComment rs' (L loc c) = (abs(ll - al), L loc c)+      where+        (al,_) = ss2pos rs'+        (ll,_) = ss2pos (epaLocationRealSrcSpan loc)++allocatePriorComments+  :: Pos+  -> [LEpaComment]+  -> ([LEpaComment], [LEpaComment])+allocatePriorComments ss_loc comment_q =+  let+    cmp (L l _) = ss2pos (epaLocationRealSrcSpan l) <= ss_loc+    (newAnns,after) = partition cmp comment_q+  in+    (after, newAnns)++insertRemainingCppComments ::  ParsedSource -> [LEpaComment] -> ParsedSource+insertRemainingCppComments (L l p) cs = L l p'+    -- `debug` ("insertRemainingCppComments: (cs,an')=" ++ showAst (cs,an'))+  where+    (EpAnn a an ocs) = GHC.hsmodAnn $ GHC.hsmodExt p+    an' = EpAnn a an (addTrailingComments end_loc ocs cs)+    p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }+    end_loc = case GHC.hsmodLayout $ GHC.hsmodExt p of+        EpExplicitBraces _open close -> case close of+            EpTok (EpaSpan (RealSrcSpan s _)) -> ss2pos s+            _ -> (1,1)+        _ -> (1,1)+    (new_before, new_after) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > end_loc ) cs++    addTrailingComments end_loc' cur new = epaCommentsBalanced pc' fc'+      where+        pc = priorComments cur+        fc = getFollowingComments cur+        (pc', fc') = case reverse pc of+            [] -> (sortEpaComments $ pc ++ new_before, sortEpaComments $ fc ++ new_after)+            (L ac _:_) -> (sortEpaComments $ pc ++ cs_before, sortEpaComments $ fc ++ cs_after)+              where+               (cs_before,cs_after)+                   = if (ss2pos $ epaLocationRealSrcSpan ac) > end_loc'+                       then break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new+                       else (new_before, new_after)++-- ---------------------------------------------------------------------++ghcCommentText :: LEpaComment -> String+ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _))      = exactPrintHsDocString s+ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _))      = s+ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _))     = s+ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _))    = s++tokComment :: LEpaComment -> [Comment]+tokComment t@(L lt c) =+  case c of+    (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc+    _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]++hsDocStringComments :: EpaLocation -> RealSrcSpan -> GHC.HsDocString -> [Comment]+hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =+  let+    decStr = printDecorator dec+    L lx x' = dedentDocChunkBy (3 + length decStr) x+    str = "-- " ++ decStr ++ unpackHDSC x'+    docChunk _ [] = []+    docChunk pt' (L l chunk:cs)+      = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs+  in+    (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))+hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))+  = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ]+hsDocStringComments anc pt (NestedDocString dec (L _ chunk))+  = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ]++hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code++-- At the moment the locations of the 'HsDocStringChunk's are from the start of+-- the string part, leaving aside the "--". So we need to subtract 2 columns from it+dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk+dedentDocChunk chunk = dedentDocChunkBy 2 chunk++dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk+dedentDocChunkBy  dedent (L (RealSrcSpan l mb) c) = L (RealSrcSpan l' mb) c+  where+    f = srcSpanFile l+    sl = srcSpanStartLine l+    sc = srcSpanStartCol l+    el = srcSpanEndLine l+    ec = srcSpanEndCol l+    l' = mkRealSrcSpan (mkRealSrcLoc f sl (sc - dedent))+                       (mkRealSrcLoc f el (ec - dedent))++dedentDocChunkBy _ x = x+++epaCommentsBalanced :: [LEpaComment] -> [LEpaComment] -> EpAnnComments+epaCommentsBalanced priorCs     [] = EpaComments priorCs+epaCommentsBalanced priorCs postCs = EpaCommentsBalanced priorCs postCs++mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments+mkEpaComments priorCs []+  = EpaComments (map comment2LEpaComment priorCs)+mkEpaComments priorCs postCs+  = epaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs)++comment2LEpaComment :: Comment -> LEpaComment+comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r++mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment+mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r))++mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment+mkComment c loc r = Comment c loc r Nothing++-- Windows comments include \r in them from the lexer.+normaliseCommentText :: String -> String+normaliseCommentText [] = []+normaliseCommentText ('\r':xs) = normaliseCommentText xs+normaliseCommentText (x:xs) = x:normaliseCommentText xs++-- |Must compare without span filenames, for CPP injected comments with fake filename+cmpComments :: Comment -> Comment -> Ordering+cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ epaLocationRealSrcSpan l1) (ss2pos $ epaLocationRealSrcSpan l2)++-- |Sort, comparing without span filenames, for CPP injected comments with fake filename+sortComments :: [Comment] -> [Comment]+sortComments cs = sortBy cmpComments cs++-- |Sort, comparing without span filenames, for CPP injected comments with fake filename+sortEpaComments :: [LEpaComment] -> [LEpaComment]+sortEpaComments cs = sortBy cmp cs+  where+    cmp (L l1 _) (L l2 _) = compare (ss2pos $ epaLocationRealSrcSpan l1) (ss2pos $ epaLocationRealSrcSpan l2)++-- | Makes a comment which originates from a specific keyword.+mkKWComment :: String -> NoCommentsLocation -> Comment+mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw)+mkKWComment kw (EpaSpan (UnhelpfulSpan _))   = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw)+mkKWComment kw (EpaDelta ss dp cs)           = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw)++sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a]+sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc))++-- | Calculates the distance from the start of a string to the end of+-- a string.+dpFromString ::  String -> DeltaPos+dpFromString xs = dpFromString' xs 0 0+  where+    dpFromString' "" line col =+      if line == 0+        then SameLine col+        else DifferentLine line col+    dpFromString' ('\n': cs) line _   = dpFromString' cs (line + 1) 0+    dpFromString' (_:cs)     line col = dpFromString' cs line       (col + 1)++-- ---------------------------------------------------------------------++isSymbolRdrName :: RdrName -> Bool+isSymbolRdrName n = isSymOcc $ rdrNameOcc n++rdrName2String :: RdrName -> String+rdrName2String r =+  case isExact_maybe r of+    Just n  -> name2String n+    Nothing ->+      case r of+        Unqual occ       -> occNameString occ+        Qual modname occ -> moduleNameString modname ++ "."+                                ++ occNameString occ+        Orig _ occ       -> occNameString occ+        Exact n          -> getOccString n++name2String :: Name -> String+name2String = showPprUnsafe++-- ---------------------------------------------------------------------++type DeclsByTag a = Map.Map DeclTag [(RealSrcSpan, a)]++orderedDecls+  :: AnnSortKey DeclTag+  -> DeclsByTag a+  -> [(RealSrcSpan, a)]+orderedDecls sortKey declGroup  =+  case sortKey of+    NoAnnSortKey ->+      sortBy (\a b -> compare (fst a) (fst b)) (concat $ Map.elems declGroup)+    AnnSortKey keys ->+      let+        go :: [DeclTag] -> DeclsByTag a -> [(RealSrcSpan, a)]+        go [] _                      = []+        go (tag:ks) dbt = d : go ks dbt'+          where+            dbt' = Map.adjust (\ds -> drop 1 ds) tag dbt+            d = case Map.lookup tag dbt of+              Just (d':_) -> d'+              _           -> error $ "orderedDecls: could not look up "+                                       ++ show tag ++ " in " ++ show (Map.keys dbt)+      in+        go keys declGroup++hsDeclsClassDecl :: TyClDecl GhcPs -> [LHsDecl GhcPs]+hsDeclsClassDecl dec = case dec of+  ClassDecl { tcdCExt = (_an2, _layout, sortKey),+              tcdSigs = sigs,tcdMeths = methods,+              tcdATs = ats, tcdATDefs = at_defs+            } -> map snd decls+    where+      srs :: EpAnn a -> RealSrcSpan+      srs a = realSrcSpan $ locA a+      decls+          = orderedDecls sortKey $ Map.fromList+              [(ClsSigTag,    map (\(L l s) -> (srs l, L l (SigD noExtField s))) sigs),+               (ClsMethodTag, map (\(L l s) -> (srs l, L l (ValD noExtField s))) methods),+               (ClsAtTag,     map (\(L l s) -> (srs l, L l (TyClD noExtField $ FamDecl noExtField s))) ats),+               (ClsAtdTag,    map (\(L l s) -> (srs l, L l (InstD noExtField $ TyFamInstD noExtField s))) at_defs)+              ]+  _ -> error $ "hsDeclsClassDecl:dec=" ++ showAst dec++replaceDeclsClassDecl :: TyClDecl GhcPs -> [LHsDecl GhcPs] -> TyClDecl GhcPs+replaceDeclsClassDecl decl decls = case decl of+  ClassDecl { tcdCExt = (an2, layout, _) } -> decl'+    where+      (tags, methods', sigs', ats', at_defs', _, _docs) = partitionWithSortKey decls+      decl' = decl { tcdCExt = (an2, layout, AnnSortKey tags),+                     tcdSigs = sigs',tcdMeths = methods',+                     tcdATs = ats', tcdATDefs = at_defs'+                   }++  _ -> error $ "replaceDeclsClassDecl:decl=" ++ showAst decl++partitionWithSortKey+  :: [LHsDecl GhcPs]+  -> ([DeclTag], LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],+      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])+partitionWithSortKey = go+  where+    go [] = ([], [], [], [], [], [], [])+    go ((L l decl) : ds) =+      let (tags, bs, ss, ts, tfis, dfis, docs) = go ds in+      case decl of+        ValD _ b+          -> (ClsMethodTag:tags, L l b : bs, ss, ts, tfis, dfis, docs)+        SigD _ s+          -> (ClsSigTag:tags, bs, L l s : ss, ts, tfis, dfis, docs)+        TyClD _ (FamDecl _ t)+          -> (ClsAtTag:tags, bs, ss, L l t : ts, tfis, dfis, docs)+        InstD _ (TyFamInstD { tfid_inst = tfi })+          -> (ClsAtdTag:tags, bs, ss, ts, L l tfi : tfis, dfis, docs)+        InstD _ (DataFamInstD { dfid_inst = dfi })+          -> (tags, bs, ss, ts, tfis, L l dfi : dfis, docs)+        DocD _ d+          -> (tags, bs, ss, ts, tfis, dfis, L l d : docs)+        _ -> error $ "partitionBindsAndSigs" ++ (showAst decl)+++-- ---------------------------------------------------------------------++orderedDeclsBinds+  :: AnnSortKey BindTag+  -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]+  -> [LHsDecl GhcPs]+orderedDeclsBinds sortKey binds sigs =+  case sortKey of+    NoAnnSortKey ->+      sortBy (\a b -> compare (realSrcSpan $ getLocA a)+                              (realSrcSpan $ getLocA b)) (binds ++ sigs)+    AnnSortKey keys ->+      let+        go [] _ _                      = []+        go (BindTag:ks) (b:bs) ss = b : go ks bs ss+        go (SigDTag:ks) bs (s:ss) = s : go ks bs ss+        go (_:ks) bs ss           =     go ks bs ss+      in+        go keys binds sigs++hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs]+hsDeclsLocalBinds lb = case lb of+    HsValBinds _ (ValBinds sortKey bs sigs) ->+      let+        bds = map wrapDecl bs+        sds = map wrapSig sigs+      in+        orderedDeclsBinds sortKey bds sds+    HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"+    HsIPBinds {}       -> []+    EmptyLocalBinds {} -> []++hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs]+hsDeclsValBinds (ValBinds sortKey bs sigs) =+      let+        bds = map wrapDecl bs+        sds = map wrapSig sigs+      in+        orderedDeclsBinds sortKey bds sds+hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds"++-- ---------------------------------------------------------------------++-- |Pure function to convert a 'LHsDecl' to a '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'+decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs]+decl2Bind (L l (ValD _ s)) = [L l s]+decl2Bind _                      = []++-- |Pure function to convert a 'LSig' to a '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 :: LHsDecl GhcPs -> [LSig GhcPs]+decl2Sig (L l (SigD _ s)) = [L l s]+decl2Sig _                = []++-- ---------------------------------------------------------------------++-- |Convert a 'LSig' into a 'LHsDecl'+wrapSig :: LSig GhcPs -> LHsDecl GhcPs+wrapSig (L l s) = L l (SigD NoExtField s)++-- ---------------------------------------------------------------------++-- |Convert a 'LHsBind' into a 'LHsDecl'+wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs+wrapDecl (L l s) = L l (ValD NoExtField s)++-- ---------------------------------------------------------------------++showAst :: (Data a) => a -> String+showAst ast+  = showSDocUnsafe+    $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
− tests/PrepareHackage.hs 
@@ -1,171 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}  ----import Data.Char-import Data.Monoid-import System.Directory-import System.FilePath.Posix-import System.IO-import Test.CommonUtils-import Turtle hiding (FilePath,(<.>))-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.IO as T--import qualified GHC.IO.Handle.Text as GHC--import Test.HUnit--main :: IO ()-main = do-  packages <- allCabalPackages-  -- packages <- allCabalPackagesTest-  myecho (T.pack $ "number of packages:" ++ (show $ length packages))-  packageDirsFull <- drop 2 <$> getDirectoryContents hackageWorkDir-  let cond c = c == '.' || c == '-' || isDigit c-  let packageDirs = map (T.dropWhileEnd cond . T.pack) packageDirsFull-  isBadPackages <- doesFileExist badpackagesFile-  badPackages <- if isBadPackages-                   then T.lines <$> T.readFile badpackagesFile-                   else return []-  let alreadyUnpacked = Set.fromList $ packageDirs ++ badPackages-  _ <- shell ("mkdir -p " <> (T.pack hackageWorkDir)) empty-  mapM_ (preparePackage alreadyUnpacked) packages---- -----------------------------------------------------------------------preparePackage :: Set.Set Text -> Text -> IO ()-preparePackage alreadyUnpacked package = do-  myecho $ "preparePackage:" <> package-  if Set.member package alreadyUnpacked-     then myecho $ "already unpacked:" <> package-     else preparePackage' package--preparePackage' :: Text -> IO ()-preparePackage' package = do-  (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty-  -- myecho (T.pack $ "cabal get:" ++ show dir)-  myecho (T.pack $ show ec)-  when (ec == ExitSuccess) $ do-    let bits = T.splitOn " " (head $ T.lines dir)-    myecho (T.pack $ "cabal get:dir=" ++ show (last bits))-    cleanPackage (last bits)-  return ()---- ------------------------------------------------------------------------- |Clean up whitespace in a package--cleanPackage :: Text -> IO ()-cleanPackage dir = do-  myecho ("cleaning:" <> dir)-  fs <- findSrcFiles (T.unpack dir)-  let-    doOne :: FilePath -> IO ()-    doOne fn = do-      myecho ("doOne:" <> T.pack fn)-      let tmpFn = fn <.> "clean"-      clean <- cleanupWhiteSpace fn-      writeFile tmpFn clean-      removeFile fn-      renameFile tmpFn fn-      return ()-  mapM_ doOne fs-  myecho ("cleaned up:" <> dir)---- ------------------------------------------------------------------------ | The computation 'writeFile' @file str@ function writes the string @str@,--- to the file @file@.-writeFileUtf8 :: FilePath -> String -> IO ()-writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt)---- -----------------------------------------------------------------------allCabalPackagesTest :: IO [Text]-allCabalPackagesTest-  = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"]-  -- = return ["airship"]---allCabalPackages :: IO [Text]-allCabalPackages = do-  -- let cmd = "cabal list --simple-output | awk '{ print $1 }' | uniq"-  let cmd = "cabal list --simple-output | awk '{ print $1 }' | sort | uniq"-  (_ec,r) <- shellStrict cmd empty-  let packages = T.lines r-  myecho (T.pack $ show $ take 5 packages)-  return packages---- ------------------------------------------------------------------------- |strip trailing whitespace, and turn tabs into spaces-cleanupWhiteSpace :: FilePath -> IO String-cleanupWhiteSpace file = do-  contents <- readFileGhc file-  let cleaned = map cleanupOneLine (lines $ contents)-  return (unlines cleaned)--tabWidth :: Int-tabWidth = 8--nonBreakingSpace :: Char-nonBreakingSpace = '\xa0'--cleanupOneLine :: String -> String-cleanupOneLine str = str'-  where-    numSpacesForTab n = tabWidth - (n `mod` tabWidth)-    -- loop over the line, keeping current pos. Where a tab is found, insert-    -- spaces until the next tab stop. Discard any trailing whitespace.-    go col res cur =-      case cur of-        [] -> res-        ('\t':cur') -> go (col + toAdd) ((replicate toAdd ' ') ++ res) cur'-                where-                  toAdd = numSpacesForTab col-        ('\xa0':cur') -> go (col + 1) (' ':res) cur'--        -- convert ISO 8859-16 euro symbol to the UTF8 equivalent-        -- ('\xa4':cur') -> go (col + 1) ('\x20ac':res) cur'-        (c:cur') ->go (col + 1) (c:res) cur'-    str1 = go 0 [] str-    str' = reverse $ dropWhile isSpace str1---- -----------------------------------------------------------------------tt :: IO Counts-tt = runTestTT $ TestList-                  [ testCleanupOneLine-                  , testTabs-                  ]--testCleanupOneLine :: Test-testCleanupOneLine = do-  let-    makeCase n = (show n-                 ,(replicate n ' ') <> "\t|" <> replicate n ' ' <> "\t"-                 ,(replicate 8 ' ' <> "|"))-    mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp)-      where (name,inp,outp) = makeCase n-  testList "cleanupOneLine" $ map mkTest [1..7]--testTabs :: Test-testTabs = TestCase $ assertEqual "testTabs" t2tabsExpected (cleanupOneLine t2tabs)-  where-    t2tabs = "import Data.Foldable\t\t    ( foldMap )"-    t2tabsExpected ="import Data.Foldable                ( foldMap )"--testList :: String -> [Test] -> Test-testList str ts = TestLabel str (TestList ts)---- -----------------------------------------------------------------------myecho :: T.Text -> IO ()-myecho t = mapM_ echo (textToLines t)---- -----------------------------------------------------------------------pwd :: IO FilePath-pwd = getCurrentDirectory--mcd :: FilePath -> IO ()-mcd = setCurrentDirectory
tests/Roundtrip.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import qualified GHC.Paths import Control.Exception import Control.Monad import Data.Time.Clock@@ -13,7 +14,6 @@ import System.Exit import System.FilePath import System.IO--- import System.IO.Temp import Test.Common import Test.CommonUtils import Test.HUnit@@ -74,6 +74,7 @@  main :: IO () main = do+  let libdir = GHC.Paths.libdir   createDirectoryIfMissing True workDir   createDirectoryIfMissing True configDir   createDirectoryIfMissing True failuresDir@@ -81,8 +82,10 @@   case as of     [] -> putStrLn "Must enter directory to process"     ["failures"] -> do+      -- !knownFailures <- readFileIfPresent knownFailuresFile+      -- let done = S.fromList knownFailures       fs <- lines <$> readFile origFailuresFile-      () <$ runTests (TestList (map mkParserTest fs))+      () <$ runTests (TestList (map (mkParserTest libdir) fs))     ["clean"] -> do       putStrLn "Cleaning..."       writeFile processed ""@@ -101,7 +104,7 @@       !cppList       <- lines <$> readFile cppFile       !parseFailList <- lines <$> readFile parseFailFile       let done = S.fromList (processedList ++ cppList ++ blackList ++ knownFailures ++ parseFailList)-      tsts <- TestList <$> mapM (tests done) ds+      tsts <- TestList <$> mapM (tests libdir done) ds       _ <- runTests tsts       return () @@ -112,38 +115,39 @@   putStrLn $ "Verbosity: " ++ show verb   runTestTT t -tests :: S.Set String ->  FilePath -> IO Test-tests done dir = do-  roundTripHackage done dir+tests :: LibDir -> S.Set String ->  FilePath -> IO Test+tests libdir done dir = do+  roundTripHackage libdir done dir  -- Selection:  -- Hackage dir-roundTripHackage :: S.Set String -> FilePath -> IO Test-roundTripHackage done hackageDir = do-  packageDirs <- drop 2 <$> getDirectoryContents hackageDir+roundTripHackage :: LibDir -> S.Set String -> FilePath -> IO Test+roundTripHackage libdir done hackageDir = do+  packageDirs <- listDirectory hackageDir+  dirsOnly <- filterM (doesDirectoryExist . (hackageDir </>)) packageDirs   when (verb <= Debug) (traceShowM hackageDir)-  when (verb <= Debug) (traceShowM packageDirs)-  TestList <$> mapM (roundTripPackage done) (zip [0..] (map (hackageDir </>) packageDirs))+  when (verb <= Debug) (traceShowM dirsOnly)+  TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir </>) dirsOnly))  -roundTripPackage :: S.Set String -> (Int, FilePath) -> IO Test-roundTripPackage done (n, dir) = do+roundTripPackage :: LibDir -> S.Set String -> (Int, FilePath) -> IO Test+roundTripPackage libdir done (n, dir) = do   putStrLn (show n)   when (verb <= Status) (traceM dir)   hsFiles <- filter (flip S.notMember done)  <$> findSrcFiles dir -  return (TestLabel (dropFileName dir) (TestList $ map mkParserTest hsFiles))+  return (TestLabel (dropFileName dir) (TestList $ map (mkParserTest libdir) hsFiles)) -mkParserTest :: FilePath -> Test-mkParserTest fp =+mkParserTest :: LibDir -> FilePath -> Test+mkParserTest libdir fp =     TestLabel fp $     TestCase (do writeLog $ "starting:" ++ fp-                 r1 <- catchAny (roundTripTest fp) $ \e -> do+                 r1 <- catchAny (roundTripTest libdir fp) $ \e -> do                    writeError fp                    throwIO e                  case r1 of-                   Left (ParseFailure _ s) -> do+                   Left (ParseFailure s) -> do                      writeParseFail fp s                      exitFailure                    Right r -> do
tests/Test.hs view
@@ -6,7 +6,7 @@ module Main where  -- import Language.Haskell.GHC.ExactPrint.Utils ( showGhc )-+import qualified GHC.Paths import Control.Monad import System.Directory import System.FilePath@@ -28,36 +28,26 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86+data GHCVersion = GHC912+           | GHC914      deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion-ghcVersion =-#if __GLASGOW_HASKELL__ > 804-  GHC86-#elif __GLASGOW_HASKELL__ > 802-  GHC84-#elif __GLASGOW_HASKELL__ > 800-  GHC82-#elif __GLASGOW_HASKELL__ >= 711-  GHC80+#if MIN_VERSION_ghc(9,14,0)+ghcVersion = GHC914 #else-  GHC710+ghcVersion = GHC912 #endif  -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs =   case ghcVersion of-    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"]+    GHC912 -> ["pre-ghc910", "ghc910", "ghc912"]+    GHC914 -> ["pre-ghc910", "ghc910", "ghc912", "ghc914"]+    -- GHC914  -> ["ghc914"]+    -- GHC914  -> ["ghc914-copied"]+    -- GHC914  -> ["ghc914",  "ghc914-copied"]  -- --------------------------------------------------------------------- @@ -71,47 +61,57 @@      then exitFailure      else return () -- exitSuccess -transform :: IO ()-transform = hSilence [stderr] $ do-  cnts <- fst <$> runTestText (putTextToHandle stdout True) transformTests-  putStrLn $ show cnts-  if errors cnts > 0 || failures cnts > 0-     then exitFailure-     else return () -- exitSuccess+transform :: IO (Counts,Int)+transform = do+  let libdir = GHC.Paths.libdir+  runTestText (putTextToHandle stdout True) (transformTestsTT libdir)  -- --------------------------------------------------------------------- -findTests :: IO Test-findTests = testList "Round-trip tests" <$> mapM (findTestsDir id mkParserTest) testDirs+findTests :: LibDir -> IO Test+findTests libdir+  = testList "Round-trip tests" <$> mapM (findTestsDir id (mkParserTest libdir)) testDirs -findPrettyTests :: IO Test-findPrettyTests =+findTestsBC :: LibDir -> IO Test+findTestsBC libdir+  = testList "Balance comments tests" <$> mapM (findTestsDir filterBC (mkParserTestBC libdir)) testDirs++-- | Filter out tests that are known to fail, for particular compilers+filterBC :: [FilePath] -> [FilePath]+filterBC fps = sort $ Set.toList $ Set.difference (Set.fromList fps) skipped+-- filterBC fps = error $ "filterBC:fps=" ++ show fps+  where+  skipped = Set.fromList+    [+    "Control.hs",+    "Internals.hs",+    "LinePragma.hs",+    "QuasiQuote.hs",+    "RandomPGC.hs",+    "HashTab.hs",+    "LinePragmas.hs",++    -- All related to blending in CPP-as-comments+    "Cpp.hs",+    "Checkpoint.hs",+    "CommentPlacement6.hs"+    ]++findTestsMD :: LibDir -> IO Test+findTestsMD libdir+  = testList "Make Delta tests" <$> mapM (findTestsDir id (mkParserTestMD libdir)) testDirs++findPrettyTests :: LibDir -> IO Test+findPrettyTests libdir =   testList "Default Annotations round-trip tests"-           <$> mapM (findTestsDir filterPrettyRoundTrip mkPrettyRoundtrip) testDirs+           <$> mapM (findTestsDir filterPrettyRoundTrip (mkPrettyRoundtrip libdir)) testDirs  -- | Filter out tests that are known to fail, for particular compilers filterPrettyRoundTrip :: [FilePath] -> [FilePath] filterPrettyRoundTrip fps = sort $ Set.toList $ Set.difference (Set.fromList fps) skipped -- filterPrettyRoundTrip fps = error $ "filterPrettyRoundTrip:fps=" ++ show fps   where-#if __GLASGOW_HASKELL__ > 800-  -- GHC 8.2   skipped = Set.empty-#elif __GLASGOW_HASKELL__ >= 711-  -- GHC 8.0-  skipped = Set.fromList-    [-      -- testPrefix </> "ghc80" </> "MultiQuote.hs"-      "MultiQuote.hs"-    , "TestUtils.hs"-    , "T10689a.hs"-    , "Zwaluw.hs"-    , "determ004.hs"-    ]-#else-  -- GHC 7.10-  skipped = Set.empty-#endif  findTestsDir :: ([FilePath] -> [FilePath]) -> (FilePath -> FilePath -> Test) -> FilePath -> IO Test findTestsDir filterFn mkTestFn dir = do@@ -134,56 +134,51 @@ mkTests :: IO Test mkTests = do   -- listTests-  roundTripTests <- findTests-  prettyRoundTripTests <- findPrettyTests+  let libdir = GHC.Paths.libdir+  roundTripTests <- findTests libdir+  roundTripBalanceCommentsTests <- findTestsBC libdir+  roundTripMakeDeltaTests <- findTestsMD libdir   return $ TestList [                       internalTests,                       roundTripTests-                    ,-                      transformTests-                    , failingTests-                    , noAnnotationTests-                    ,-                      prettyRoundTripTests+                   ,+                     (transformTests libdir)+                   ,+                      (failingTests libdir)+                   ,+                     roundTripBalanceCommentsTests+                   ,+                     roundTripMakeDeltaTests                     ] --- Tests that will fail until https://phabricator.haskell.org/D907 lands in a--- future GHC-failingTests :: Test-failingTests = testList "Failing tests"+failingTests :: LibDir -> Test+failingTests libdir = testList "Failing tests"   [   -- Tests requiring future GHC modifications-    mkTestModBad "InfixOperator.hs" -#if __GLASGOW_HASKELL__ > 802-#elif __GLASGOW_HASKELL__ > 800-  , mkTestModBad "overloadedlabelsrun04.hs"-#elif __GLASGOW_HASKELL__ > 710-  , mkTestModBad "overloadedlabelsrun04.hs"-  , mkTestModBad "TensorTests.hs" -- Should be fixed in GHC 8.2-  , mkTestModBad "List2.hs"       -- Should be fixed in GHC 8.2-#else-  , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4-  , mkTestModBad "UnicodeSyntax.hs"-  , mkTestModBad "UnicodeRules.hs"-  , mkTestModBad "Deprecation.hs"-  , mkTestModBad "MultiLineWarningPragma.hs"-#endif+  -- We do not capture EOF location very well any more+    mkTestModBad libdir "T10970a.hs"+  -- Injecting CPP comments adjacent to existing ones is a problem+  , mkTestModBad libdir "CppComment.hs"+  ]  -  ]+mkParserTest :: LibDir -> FilePath -> FilePath -> Test+mkParserTest libdir dir fp = mkParsingTest (roundTripTest libdir) dir fp +mkParserTestBC :: LibDir -> FilePath -> FilePath -> Test+mkParserTestBC libdir dir fp = mkParsingTest (roundTripTestBC libdir) dir fp -mkParserTest :: FilePath -> FilePath -> Test-mkParserTest dir fp = mkParsingTest roundTripTest dir fp+mkParserTestMD :: LibDir -> FilePath -> FilePath -> Test+mkParserTestMD libdir dir fp = mkParsingTest (roundTripTestMD libdir) dir fp  -- ---------------------------------------------------------------------  formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () formatTT (ts, fs) = do-  when (not . null $ tail ts) (do+  when (not . null $ (drop 1) ts) (do     putStrLn "Pass"-    mapM_ (putStrLn . fst) (tail ts)+    mapM_ (putStrLn . fst) ((drop 1) ts)     )   when (not . null $ fs) (do     putStrLn "Fail"@@ -191,47 +186,58 @@  tr :: IO (Counts,Int) tr = hSilence [stderr] $ do-  prettyRoundTripTests <- findPrettyTests+  let libdir = GHC.Paths.libdir+  prettyRoundTripTests <- findPrettyTests libdir   runTestText (putTextToHandle stdout True) prettyRoundTripTests  tt' :: IO (Counts,Int)-tt' = runTestText (putTextToHandle stdout True) $ TestList [---      -- mkPrettyRoundtrip "ghc82" "TensorTests.hs"+tt' = do+  let libdir = GHC.Paths.libdir+  runTestText (putTextToHandle stdout True) $ TestList [ -      mkParserTest      "ghc710" "GADTContext.hs"+    -- mkParserTest libdir "ghc98" "ModuleComments1.hs"+    -- mkParserTestBC libdir "ghc98" "MonoidsFD1.hs"+    -- mkParserTestMD libdir "ghc98" "ModuleComments1.hs" -      -- mkParserTest      "ghc86" "deriving-via-compile.hs"-    --   mkParserTest "pre-ghc86" "TensorTests.hs"-    -- , mkParserTest "pre-ghc86" "Webhook.hs"-    -- , mkParserTest "ghc710" "RdrNames.hs"+    -- mkParserTest libdir "ghc910" "LinearLet.hs"+    -- mkParserTest libdir "ghc910" "Generic.hs"+    -- mkParserTest libdir "ghc910" "Expression.hs"+    -- mkParserTest libdir "ghc910" "ConstructorArgs.hs"+    -- mkParserTest libdir "ghc910" "CppComment.hs"+    -- mkParserTest libdir "ghc910" "Class.hs"+    -- mkParserTest libdir "ghc910" "Test138.hs"+    -- mkParserTest libdir "vect" "DiophantineVect.hs" -    --   mkPrettyRoundtrip "ghc86" "BinDU.hs"-    -- , mkPrettyRoundtrip "ghc86" "Dial.hs"+    -- mkParserTest libdir "pre-ghc910" "RandomPGC.hs" -      -- mkParserTest      "ghc84" "Types.hs"-    -- , mkPrettyRoundtrip "ghc80" "export-type.hs"+    -- mkParserTest libdir "ghc912" "Module.hs"+    -- mkParserTest libdir "ghc912" "tests.hs"+    -- mkParserTestMD libdir "ghc912" "Fff.hs"+    -- mkParserTestMD libdir "transform" "AddLocalDecl5.hs"+    -- mkParserTestBC libdir "transform" "AddLocalDecl5.hs"+    -- mkParserTestMD libdir "ghc912" "Module.hs"+    -- mkParserTestMD libdir "ghc912" "Operator.hs" +    -- mkParserTest libdir "pre-ghc910" "AnnPackageName.hs"+    mkParserTestMD libdir "pre-ghc910" "AnnPackageName.hs"    -- Needs GHC changes-        -- mkParserTest "failing" "CtorOp.hs"-        -- mkParserTest "failing" "InfixOperator.hs"        ] -testsTT :: Test-testsTT = TestList+testsTT :: LibDir -> Test+testsTT libdir = TestList   [-    mkParserTest "ghc710" "Cpp.hs"-  , mkParserTest "ghc710" "DroppedDoSpace.hs"+    mkParserTest libdir "ghc710" "Cpp.hs"+  , mkParserTest libdir "ghc710" "DroppedDoSpace.hs"   ]  tt :: IO () -- tt = hSilence [stderr] $ do tt = do-  cnts <- fst <$> runTestText (putTextToHandle stdout True) testsTT+  let libdir = GHC.Paths.libdir+  cnts <- fst <$> runTestText (putTextToHandle stdout True) (testsTT libdir)   putStrLn $ show cnts   if errors cnts > 0 || failures cnts > 0      then exitFailure
tests/Test/Common.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}@@ -6,12 +5,15 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Common (                 RoundtripReport (..)               , Report               , ParseFailure(..)               , ReportType(..)               , roundTripTest+              , roundTripTestBC+              , roundTripTestMD               , mkParsingTest               , getModSummaryForFile @@ -20,48 +22,39 @@               , Changer               , genTest               , noChange+              , changeMakeDelta               , mkDebugOutput+              , showErrorMessages+              , LibDir               ) where    import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils-import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCpp)+import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess-import Language.Haskell.GHC.ExactPrint.Types --import qualified ApiAnnotation as GHC-import qualified DynFlags      as GHC--- import qualified FastString    as GHC-import qualified GHC           as GHC hiding (parseModule)--- import qualified Lexer         as GHC-import qualified MonadUtils    as GHC--- import qualified Parser        as GHC--- import qualified SrcLoc        as GHC--- import qualified StringBuffer  as GHC+import qualified Control.Monad.IO.Class as GHC+import GHC hiding (moduleName)+import GHC.Driver.Errors.Types+import qualified GHC.Driver.Session    as GHC+import GHC.Types.Error+import GHC.Utils.Error+import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, vcat) -#if __GLASGOW_HASKELL__ <= 710-#else import qualified GHC.LanguageExtensions as LangExt-#endif --- import qualified Data.Map as Map- import Control.Monad import Data.List hiding (find)  import System.Directory -import Test.Consistency- import Test.HUnit import System.FilePath --- import Debug.Trace testPrefix :: FilePath-testPrefix = "tests" </> "examples"+testPrefix = "." </> "tests" </> "examples"  testList :: String -> [Test] -> Test testList s ts = TestLabel s (TestList ts)@@ -76,117 +69,126 @@    { debugTxt     :: String    , status       :: ReportType    , cppStatus    :: Maybe String -- Result of CPP if invoked-   , inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))]+   -- , inconsistent :: Maybe [(AnnSpan, (GHC.AnnKeywordId, [AnnSpan]))]    } -data ParseFailure = ParseFailure GHC.SrcSpan String+data ParseFailure = ParseFailure String  data ReportType =    Success  | RoundTripFailure deriving (Eq, Show) -{--runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a-runParser parser flags filename str = GHC.unP parser parseState-    where-      location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1-      buffer = GHC.stringToStringBuffer str-      parseState = GHC.mkPState flags buffer location -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs))-parseFile = runParser GHC.parseModule--mkApiAnns :: GHC.PState -> GHC.ApiAnns-mkApiAnns pstate = (Map.fromListWith (++) . GHC.annotations $ pstate-                   , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate)))--removeSpaces :: String -> String-removeSpaces = map (\case {'\160' -> ' '; s -> s})--}+roundTripTest :: LibDir -> FilePath -> IO Report+roundTripTest libdir f = genTest libdir noChange f f -roundTripTest :: FilePath -> IO Report-roundTripTest f = genTest noChange f f+roundTripTestBC :: LibDir -> FilePath -> IO Report+roundTripTestBC libdir f = genTest libdir changeBalanceComments f f +roundTripTestMD :: LibDir -> FilePath -> IO Report+roundTripTestMD libdir f = genTest libdir changeMakeDelta f f  mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test mkParsingTest tester dir fp =   let basename       = testPrefix </> dir </> fp       writeFailure   = writeFile (basename <.> "out")       writeHsPP      = writeFile (basename <.> "hspp")-      writeIncons s  = writeFile (basename <.> "incons") (showGhc s)+      -- writeIncons s  = writeFile (basename <.> "incons") (showGhc s)   in-    TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id+    TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id                         <$> tester basename                  writeFailure (debugTxt r)-                 forM_ (inconsistent r) writeIncons+                 -- forM_ (inconsistent r) writeIncons                  forM_ (cppStatus r) writeHsPP                  assertBool fp (status r == Success)) --type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource))+type Changer = LibDir -> (GHC.ParsedSource -> IO GHC.ParsedSource)  noChange :: Changer-noChange ans parsed = return (ans,parsed)+noChange _libdir parsed = return parsed -genTest :: Changer -> FilePath -> FilePath -> IO Report-genTest f origFile expectedFile  = do-      res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile+changeBalanceComments :: Changer+changeBalanceComments _libdir top = do+  let (GHC.L l p) = top+  let decls0 = GHC.hsmodDecls p+      decls = balanceCommentsList decls0+  let p2 = p { GHC.hsmodDecls = decls}+  return (GHC.L l p2)++changeMakeDelta :: Changer+changeMakeDelta _libdir m = do+  return (makeDeltaAst m)++genTest :: LibDir -> Changer -> FilePath -> FilePath -> IO Report+genTest libdir f origFile expectedFile  = do+      res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile       expected <- GHC.liftIO $ readFileGhc expectedFile       orig <- GHC.liftIO $ readFileGhc origFile       -- let pristine = removeSpaces expected       let pristine = expected        case res of-        Left (ss, m) -> return . Left $ ParseFailure ss m-        Right (apianns, injectedComments, dflags, pmod)  -> do-          (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments)-#if __GLASGOW_HASKELL__ <= 710-          let useCpp = GHC.xopt GHC.Opt_Cpp dflags-#else+        Left m -> return . Left $ ParseFailure (showErrorMessages m)+        Right (!injectedComments, !dflags, !pmod)  -> do+          (printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments)           let useCpp = GHC.xopt LangExt.Cpp dflags-#endif               printed = trimPrinted printed'-          -- let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments               -- Clang cpp adds an extra newline character               -- Do not remove this line!               trimPrinted p = if useCpp                                 then unlines $ take (length (lines pristine)) (lines p)                                 else p-              debugTxt = mkDebugOutput origFile printed pristine apianns anns pmod'-              consistency = checkConsistency apianns pmod-              inconsistent = if null consistency then Nothing else Just consistency+              debugTxt = mkDebugOutput origFile printed pristine pmod'+              -- consistency = checkConsistency apianns pmod+              -- inconsistent = if null consistency then Nothing else Just consistency               status = if printed == pristine then Success else RoundTripFailure               cppStatus = if useCpp then Just orig else Nothing           return $ Right Report {..} +showErrorMessages :: Messages GhcMessage -> String+showErrorMessages msgs =+  renderWithContext defaultSDocContext+    $ vcat+    $ pprMsgEnvelopeBagWithLocDefault+    $ getMessages+    $ msgs +-- showErrorMessages :: Messages GhcMessage -> String+-- showErrorMessages msgs =+--   renderWithContext defaultSDocContext+--     $ vcat+--     $ pprMsgEnvelopeBagWithLocDefault+--     $ getMessages+--     $ msgs++ mkDebugOutput :: FilePath -> String -> String-              -> GHC.ApiAnns-              -> Anns               -> GHC.ParsedSource -> String-mkDebugOutput filename printed original apianns anns parsed =+mkDebugOutput filename printed original parsed =   intercalate sep [ printed                  , filename                  , "lengths:" ++ show (length printed,length original) ++ "\n"-                 , showAnnData anns 0 parsed-                 , showGhc anns-                 , showGhc apianns+                 -- , showAnnData anns 0 parsed+                 , showAst parsed+                 -- , showGhc anns                 ]   where     sep = "\n==============\n"   -runRoundTrip :: Changer-             -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GhcPs)-             -> [Comment]-             -> IO (String, Anns, GHC.ParsedSource)-runRoundTrip f !anns !parsedOrig cs = do-  let !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns-  (annsMod, pmod) <- f relAnns parsedOrig-  let !printed = exactPrint pmod annsMod-  -- return (printed,  relAnns, pmod)-  return (printed,  annsMod, pmod)+runRoundTrip :: LibDir+             -> Changer+             -> GHC.Located (GHC.HsModule GHC.GhcPs)+             -> [GHC.LEpaComment]+             -> IO (String, GHC.ParsedSource)+runRoundTrip libdir f !parsedOrig cs = do+  -- putStrLn $ "comments:" ++ showAst cs+  let !parsedOrigWithComments = insertCppComments parsedOrig cs+  -- putStrLn $ "parsedOrigWithComments:" ++ showAst parsedOrigWithComments+  !pmod <- f libdir parsedOrigWithComments+  let !printed = exactPrint pmod+  return (printed, pmod)  -- ---------------------------------------------------------------------` @@ -210,14 +212,11 @@   cfileName <- GHC.liftIO $ canonicalizePath fileName    graph <- GHC.getModuleGraph-#if __GLASGOW_HASKELL__ >= 804   cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph)-#else-  cgraph <- GHC.liftIO $ canonicalizeGraph graph-#endif    let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph   case mm of-   [] -> return Nothing-   fs -> return (Just (snd $ head fs))+   (f:_) -> return (Just (snd f))+   _ -> return Nothing +-- ---------------------------------------------------------------------
tests/Test/CommonUtils.hs view
@@ -21,10 +21,12 @@   , failuresHtmlFile   ) where +import Control.Monad+import GHC.Utils.Monad import Data.List hiding (find)+import qualified GHC.Data.StringBuffer as GHC+import System.Directory import System.FilePath-import System.FilePath.Find-import qualified StringBuffer as GHC  -- --------------------------------------------------------------------- @@ -100,30 +102,38 @@  -- Given base directory finds all haskell source files findSrcFiles :: FilePath -> IO [FilePath]-findSrcFiles = find filterDirectory filterFilename--filterDirectory :: FindClause Bool-filterDirectory =-  p <$> fileName+findSrcFiles = traverseDir okDirectory accFile []   where-    p x-      | "." `isPrefixOf` x = False+    okDirectory :: FilePath -> Bool+    okDirectory path+      | "." `isPrefixOf` takeBaseName path = False       | otherwise = True -filterFilename :: FindClause Bool-filterFilename = do-  ext <- extension-  fname <- fileName-  return (ext == ".hs" && p fname)-  where-    p x-      | "refactored" `isInfixOf` x = False-      | "Setup.hs" `isInfixOf` x = False-      | "HLint.hs" `isInfixOf` x = False -- HLint config files-      | otherwise                 = True+    accFile :: [FilePath] -> FilePath -> IO [FilePath]+    accFile acc fileName = do+      return (if (takeExtension fileName == ".hs" && p fileName)+                then fileName:acc+                else acc)+      where+        p x+          | "refactored" `isInfixOf` x = False+          | "Setup.hs" `isInfixOf` x = False+          | "HLint.hs" `isInfixOf` x = False -- HLint config files+          | otherwise                 = True  -- ---------------------------------------------------------------------+-- Based on https://stackoverflow.com/questions/51712083/recursively-search-directories-for-all-files-matching-name-criteria-in-haskell+traverseDir :: (FilePath -> Bool) -> (b -> FilePath -> IO b) -> b -> FilePath -> IO b+traverseDir validDir transition =+    let go state dirPath =+            do names <- listDirectory dirPath+               let paths = map (dirPath </>) names+               (dirPaths, filePaths) <- partitionM doesDirectoryExist paths+               state' <- foldM transition state filePaths -- process current dir+               foldM go state' (filter validDir dirPaths) -- process subdirs+     in go +-- --------------------------------------------------------------------- readFileGhc :: FilePath -> IO String readFileGhc file = do   buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file
− tests/Test/Consistency.hs 
@@ -1,27 +0,0 @@-module Test.Consistency where--import Data.Data-import GHC-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Generics (everything, mkQ)--import Language.Haskell.GHC.ExactPrint.Utils (isPointSrcSpan)---- import Debug.Trace--checkConsistency :: Data a => GHC.ApiAnns -> a -> [(SrcSpan, (AnnKeywordId, [SrcSpan]))]-checkConsistency anns ast =-  let srcspans = Set.fromList $ getAllSrcSpans ast-      cons (s, (_, vs)) = Set.member s srcspans || (all (isPointSrcSpan) vs)-  in filter (\s -> not (cons s)) (getAnnSrcSpans anns)--getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(AnnKeywordId,[SrcSpan]))]-getAnnSrcSpans (anns,_) = map (\((ss,k),v) -> (ss,(k,v))) $ Map.toList anns--getAllSrcSpans :: (Data t) => t -> [SrcSpan]-getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast-  where-    getSrcSpan :: SrcSpan -> [SrcSpan]-    getSrcSpan ss = [ss]-
tests/Test/NoAnnotations.hs view
@@ -1,57 +1,26 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Test.NoAnnotations where --- import Control.Monad.State import Data.Algorithm.Diff import Data.Algorithm.DiffOutput-import Data.Data (Data, toConstr, showConstr, cast)-import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List--- import Data.Ord (comparing)-import qualified Data.ByteString as B  import Language.Haskell.GHC.ExactPrint--- import Language.Haskell.GHC.ExactPrint.Annotate import Language.Haskell.GHC.ExactPrint.Parsers--- import Language.Haskell.GHC.ExactPrint.Pretty import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils -import qualified ApiAnnotation as GHC-import qualified Bag           as GHC--- import qualified DynFlags      as GHC-import qualified FastString    as GHC-import qualified GHC           as GHC hiding (parseModule)--- import qualified Lexer         as GHC-import qualified MonadUtils    as GHC--- import qualified Name          as GHC-import qualified NameSet       as GHC--- import qualified OccName       as GHC-import qualified Outputable    as GHC--- import qualified Parser        as GHC--- import qualified RdrName       as GHC-import qualified SrcLoc        as GHC--- import qualified StringBuffer  as GHC-import qualified Var           as GHC--import qualified OccName(occNameString)---- import qualified Data.Generics as SYB--- import qualified GHC.SYB.Utils as SYB-+import qualified Control.Monad.IO.Class as GHC+import qualified GHC                    as GHC hiding (parseModule)+import qualified GHC.Hs.Dump            as GHC+import qualified GHC.Utils.Outputable   as GHC  import System.Directory import System.FilePath--- import System.FilePath.Posix--- import System.IO-import qualified Data.Map as Map--- import Data.List--- import Data.Maybe  import Test.Common @@ -75,68 +44,65 @@  -- --------------------------------------------------------------------- -mkPrettyRoundtrip :: FilePath -> FilePath -> Test-mkPrettyRoundtrip dir fp = mkParsingTest prettyRoundtripTest dir fp+mkPrettyRoundtrip :: LibDir -> FilePath -> FilePath -> Test+mkPrettyRoundtrip libdir dir fp = mkParsingTest (prettyRoundtripTest libdir) dir fp -prettyRoundtripTest :: FilePath -> IO Report-prettyRoundtripTest origFile = do-      res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile+prettyRoundtripTest :: LibDir -> FilePath -> IO Report+prettyRoundtripTest libdir origFile = do+      -- res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile+      res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile       case res of-        Left (ss, m) -> return . Left $ ParseFailure ss m-        Right (apianns, injectedComments, _dflags, parsed)  -> do-          res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments)+        Left m -> return . Left $ ParseFailure (showErrorMessages m)+        Right (injectedComments, _dflags, parsed)  -> do+          res2 <- GHC.liftIO (runPrettyRoundTrip libdir origFile parsed injectedComments)           case res2 of-            Left (ss, m) -> return . Left $ ParseFailure ss m-            Right (_anns', parsed') -> do+            Left m -> return . Left $ ParseFailure (showErrorMessages m)+            Right parsed' -> do               let-                originalStructure  = astStructure parsed []-                roundtripStructure = astStructure parsed' []+                originalStructure  = astStructure parsed+                roundtripStructure = astStructure parsed'                 (status,debugTxt') = if roundtripStructure == originalStructure                   then (Success, "ok")                   else (RoundTripFailure,diffText originalStructure roundtripStructure                          ++ sep ++ originalStructure ++ sep ++ roundtripStructure)                 cppStatus = Nothing-                inconsistent = Nothing-                !annsOrig = relativiseApiAnnsWithComments injectedComments parsed apianns                 debugTxt = intercalate sep [ debugTxt'                                            , originalStructure                                            , roundtripStructure-                                           , showAnnData annsOrig 0 parsed+                                           , showAst parsed                                            ]                 sep = "\n=====================================\n"-              return $ Right Report {debugTxt,status,cppStatus,inconsistent}+              return $ Right Report {debugTxt,status,cppStatus}  -- --------------------------------------------------------------------- -runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource-                   -> [Comment]-                   -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))-runPrettyRoundTrip origFile !anns !parsedOrig _cs = do-  let !newAnns = addAnnotationsForPretty [] parsedOrig mempty-  let comments = case Map.lookup GHC.noSrcSpan (snd anns) of-        Nothing -> []-        Just cl -> map tokComment $ GHC.sortLocated cl-  let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments+runPrettyRoundTrip :: LibDir -> FilePath -> GHC.ParsedSource+                   -> [GHC.LEpaComment]+                   -> IO (ParseResult GHC.ParsedSource)+runPrettyRoundTrip libdir origFile !parsedOrig _cs = do+  let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn+        $ GHC.hsmodExt $ GHC.unLoc parsedOrig+  let comments = concatMap tokComment priorComments+  let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments   let pragmaStr = intercalate "\n" $ map commentContents pragmas -  let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig newAnns-  -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig)+  let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig -  parseString origFile printed newAnns parsedOrig+  parseString libdir origFile printed parsedOrig  -parseString :: FilePath -> String -> Anns -> GHC.ParsedSource-            -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource))-parseString origFile src newAnns origParsed = do+parseString :: LibDir -> FilePath -> String -> GHC.ParsedSource+            -> IO (ParseResult GHC.ParsedSource)+parseString libdir origFile src origParsed = do   tmpDir <- getTemporaryDirectory   let workDir = tmpDir </> "ghc-exactprint" </> "noannotations"   -- putStrLn $ "workDir=" ++ workDir   createDirectoryIfMissing True workDir   let fileName = workDir </> takeFileName origFile   writeFile (workDir </> takeFileName origFile <.> ".anns")-      (showAnnData  newAnns 0 origParsed)+      (showAst  origParsed)   writeFile fileName src-  parseModule fileName+  parseModule libdir fileName  -- --------------------------------------------------------------------- @@ -151,74 +117,8 @@ -- |Convert an AST with comments into a string representing the structure only -- (i.e. ignoring locations), to be used for comparisons between the original -- AST and the one after pretty-print roundtripping.--- Based on @showAnnData@-astStructure :: GHC.ParsedSource -> [Comment] -> String-astStructure parsed _cs = r+astStructure :: GHC.ParsedSource -> String+astStructure parsed = r   where-    r = showAstData 0 parsed------ | Show a GHC AST with interleaved Annotation information.-showAstData :: Data a => Int -> a -> String-showAstData n =-  generic -- `ext1Q` located-          `ext1Q` list-          `extQ` string `extQ` fastString `extQ` srcSpan-          `extQ` bytestring-          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon-          `extQ` overLit-          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-          `extQ` fixity-          `ext2Q` located-  where generic :: Data a => a -> String-        generic t = indent n ++ "(" ++ showConstr (toConstr t)-                 ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")"-        space "" = ""-        space s  = ' ':s-        indent i = "\n" ++ replicate i ' '-        string     = show :: String -> String-        fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String-        bytestring = show :: B.ByteString -> String-        list l     = indent n ++ "["-                              ++ intercalate "," (map (showAstData (n+1)) l) ++ "]"--        name       = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String-        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString-        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String--        srcSpan :: GHC.SrcSpan -> String-        srcSpan _ss = "{ "++ "ss" ++"}"--        var        = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String-        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String--        overLit :: GHC.HsOverLit GhcPs -> String-        overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr--        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String-        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList-        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String-        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList-        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String-        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList--#if __GLASGOW_HASKELL__ > 800-        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable-#else-        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems-#endif--        fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String--        located :: (Data b,Data loc) => GHC.GenLocated loc b -> String-        located (GHC.L ss a) =-          indent n ++ "("-            ++ case cast ss of-                    Just (s :: GHC.SrcSpan) ->-                      srcSpan s-                    Nothing -> "nnnnnnnn"-                  ++ showAstData (n+1) a-                  ++ ")"---- ---------------------------------------------------------------------+    r = GHC.showSDocUnsafe+        $ GHC.showAstData GHC.BlankSrcSpanFile GHC.NoBlankEpAnnotations parsed
tests/Test/Transform.hs view
@@ -1,834 +1,652 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-module Test.Transform where--import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Parsers--import qualified Bag            as GHC-import qualified GHC            as GHC-import qualified OccName        as GHC-import qualified RdrName        as GHC-import qualified SrcLoc         as GHC-import qualified FastString     as GHC--import qualified Data.Generics as SYB--- import qualified GHC.SYB.Utils as SYB--import System.FilePath-import qualified Data.Map as Map--- import Data.List-import Data.Maybe--import Test.Common--import Test.HUnit--transformTests :: Test-transformTests = TestLabel "transformation tests" $ TestList-  [-    TestLabel "Low level transformations"-       (TestList transformLowLevelTests)-  , TestLabel "High level transformations"-       (TestList transformHighLevelTests)-  ]--transformLowLevelTests :: [Test]-transformLowLevelTests = [-    mkTestModChange changeRenameCase1 "RenameCase1.hs"-  , mkTestModChange changeLayoutLet2  "LayoutLet2.hs"-  , mkTestModChange changeLayoutLet3  "LayoutLet3.hs"-  , mkTestModChange changeLayoutLet3  "LayoutLet4.hs"-  , mkTestModChange changeRename1     "Rename1.hs"-  , mkTestModChange changeRename2     "Rename2.hs"-  , mkTestModChange changeLayoutIn1   "LayoutIn1.hs"-  , mkTestModChange changeLayoutIn3   "LayoutIn3.hs"-  , mkTestModChange changeLayoutIn3   "LayoutIn3a.hs"-  , mkTestModChange changeLayoutIn3   "LayoutIn3b.hs"-  , mkTestModChange changeLayoutIn4   "LayoutIn4.hs"-  , mkTestModChange changeLocToName   "LocToName.hs"-  , mkTestModChange changeLetIn1      "LetIn1.hs"-  , mkTestModChange changeWhereIn4    "WhereIn4.hs"-  , mkTestModChange changeAddDecl     "AddDecl.hs"-  , mkTestModChange changeLocalDecls  "LocalDecls.hs"-  , mkTestModChange changeLocalDecls2 "LocalDecls2.hs"-  , mkTestModChange changeWhereIn3a   "WhereIn3a.hs"---  , mkTestModChange changeCifToCase  "C.hs"          "C"-  ]--mkTestModChange :: Changer -> FilePath -> Test-mkTestModChange = mkTestMod "expected" "transform"--mkTestModBad :: FilePath -> Test-mkTestModBad = mkTestMod "bad" "failing" noChange---mkTestMod :: String -> FilePath -> Changer -> FilePath ->  Test-mkTestMod suffix dir f fp =-  let basename       = testPrefix </> dir </> fp-      expected       = basename <.> suffix-      writeFailure   = writeFile (basename <.> "out")-  in-    TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id-                        <$> genTest f basename expected-                 writeFailure (debugTxt r)-                 assertBool fp (status r == Success))----- -----------------------------------------------------------------------changeWhereIn3a :: Changer-changeWhereIn3a ans (GHC.L l p) = do-  let decls = GHC.hsmodDecls p-         -- (GHC.L _ (GHC.SigD sig))    = head $ drop 1 decls-      d1 = head $ drop 2 decls-      d2 = head $ drop 3 decls-  let (_p1,(ans',_),_w) = runTransform ans (balanceComments d1 d2)-  let p2 = p { GHC.hsmodDecls = d2:d1:decls}-  return (ans',GHC.L l p2)---- ------------------------------------------------------------------------- | Add a local declaration with signature to LocalDecl, where there was no--- 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-  -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns-  -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'-  let (p',(ans',_),_w) = runTransform ans doAddLocal-      doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p-      replaceLocalBinds :: GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)-                        -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs))-#if __GLASGOW_HASKELL__ <= 710-      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-#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-          newAnnKey = AnnKey newSpan (CN "HsValBinds")-          addWhere mkds =-            case Map.lookup (mkAnnKey m) mkds of-              Nothing -> error "wtf"-              Just ann -> Map.insert newAnnKey ann2 mkds2-                where-                  ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]-                             , annCapturedSpan = Just newAnnKey-                             , annSortKey = Just [ls, ld]-                             }-                  mkds2 = Map.insert (mkAnnKey m) ann1 mkds-                  ann2 = annNone-                             { annEntryDelta     = DP (1,0) }-        modifyAnnsT addWhere-        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))))-#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-  return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')---- ------------------------------------------------------------------------- | 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-  -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns-  -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'-  let (p',(ans',_),_w) = runTransform ans doAddLocal-      doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p-      replaceLocalBinds :: GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)-                        -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs))-#if __GLASGOW_HASKELL__ <= 710-      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-#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-              []    -> return a1-              (s1:_) -> do-                let a2 = setPrecedingLines s1 2 0 a1-                return a2-        putAnnsT a'-        let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs-        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'))))-#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-  return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')---- ------------------------------------------------------------------------- | Add a declaration to AddDecl-changeAddDecl :: Changer-changeAddDecl ans top = do-  Right (declAnns, decl) <- withDynFlags (\df -> parseDecl df "<interactive>" "nn = n2")-  -- putStrLn $ "changeDecl:(declAnns,decl)=" ++ showGhc (declAnns,decl)-  let declAnns' = setPrecedingLines decl 2 0 declAnns-  -- putStrLn $ "changeDecl:(declAnns',decl)=" ++ showGhc (declAnns',decl)--  let (p',(ans',_),_) = runTransform ans doAddDecl-      doAddDecl = SYB.everywhereM (SYB.mkM replaceTopLevelDecls) top-      replaceTopLevelDecls :: GHC.ParsedSource -> Transform (GHC.ParsedSource)-      replaceTopLevelDecls m = insertAtStart m decl-  return (mergeAnns declAnns' ans',p')---- ------------------------------------------------------------------------- |Remove a decl with a trailing comment, and remove the trailing comment too-changeWhereIn3 :: Int -> Changer-changeWhereIn3 declIndex ans p = return (ans',p')-  where-    (p',(ans',_),_) = runTransform ans doTransform-    doTransform = doRmDecl p--    doRmDecl (GHC.L l (GHC.HsModule mmn mexp imps decls mdepr haddock)) = do-      let-        -- declIndex = 2 -- zero based-        decls1 = take declIndex decls-        decls2 = drop (declIndex + 1) decls-        decls' = decls1 ++ decls2-      return (GHC.L l (GHC.HsModule mmn mexp imps decls' mdepr haddock))-      -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2)---- -----------------------------------------------------------------------changeRenameCase1 :: Changer-changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed)--changeRenameCase2 :: Changer-changeRenameCase2 ans parsed = return (ans,rename "fooLonger" [((3,1),(3,4))] parsed)--changeLayoutLet2 :: Changer-changeLayoutLet2 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed)--changeLocToName :: Changer-changeLocToName ans parsed = return (ans,rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed)--changeLayoutIn3 :: Changer-changeLayoutIn3 ans parsed = return (ans,rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed)--- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed--changeLayoutIn4 :: Changer-changeLayoutIn4 ans parsed = return (ans,rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed)--changeLayoutIn1 :: Changer-changeLayoutIn1 ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed)--changeRename1 :: Changer-changeRename1 ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed)--changeRename2 :: Changer-changeRename2 ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed)--changeLayoutLet3 :: Changer-changeLayoutLet3 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed)--changeLayoutLet5 :: Changer-changeLayoutLet5 ans parsed = return (ans,rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed)---- AZ:TODO: the GHC 8 version only needs to consider Located RdrName-rename :: (SYB.Data a) => String -> [(Pos, Pos)] -> a -> a-rename newNameStr spans a-  = SYB.everywhere ( SYB.mkT   replaceRdr-                    `SYB.extT` replaceHsVar-                    `SYB.extT` replacePat-                   ) a-  where-    newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr)--    cond :: GHC.SrcSpan -> Bool-    cond ln = ln `elem` srcSpans-      where-        srcSpans  = map (\(start, end) -> GHC.mkSrcSpan (f start) (f end)) spans-        fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln)-        f = uncurry (GHC.mkSrcLoc fname)---    replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName-    replaceRdr (GHC.L ln _)-        | cond ln = GHC.L ln newName-    replaceRdr x = x--    replaceHsVar :: GHC.LHsExpr GhcPs -> GHC.LHsExpr GhcPs-    replaceHsVar (GHC.L ln (GHC.HsVar{}))-#if __GLASGOW_HASKELL__ <= 710-        | cond ln = GHC.L ln (GHC.HsVar newName)-#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 {}))-#if __GLASGOW_HASKELL__ <= 710-        | cond ln = GHC.L ln (GHC.VarPat newName)-#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------ -----------------------------------------------------------------------changeWhereIn4 :: Changer-changeWhereIn4 ans parsed-  = return (ans,SYB.everywhere (SYB.mkT replace) parsed)-  where-    replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName-    replace (GHC.L ln _n)-      | ln == (g (12,16) (12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2"))-      where-        g start end = GHC.mkSrcSpan (f start) (f end)-        fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln)-        f = uncurry (GHC.mkSrcLoc fname)-    replace x = x---- -----------------------------------------------------------------------changeLetIn1 :: Changer-changeLetIn1 ans parsed-  = return (ans,SYB.everywhere (SYB.mkT replace) parsed)-  where-    replace :: GHC.HsExpr GhcPs -> GHC.HsExpr GhcPs-#if __GLASGOW_HASKELL__ <= 710-    replace (GHC.HsLet localDecls expr@(GHC.L _ _))-#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)-#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---- -----------------------------------------------------------------------transformHighLevelTests :: [Test]-transformHighLevelTests =-  [-    mkTestModChange addLocaLDecl1  "AddLocalDecl1.hs"-  , mkTestModChange addLocaLDecl2  "AddLocalDecl2.hs"-  , mkTestModChange addLocaLDecl3  "AddLocalDecl3.hs"-  , mkTestModChange addLocaLDecl4  "AddLocalDecl4.hs"-  , mkTestModChange addLocaLDecl5  "AddLocalDecl5.hs"-  , mkTestModChange addLocaLDecl6  "AddLocalDecl6.hs"--  , mkTestModChange rmDecl1 "RmDecl1.hs"-  , mkTestModChange rmDecl2 "RmDecl2.hs"-  , mkTestModChange rmDecl3 "RmDecl3.hs"-  , mkTestModChange rmDecl4 "RmDecl4.hs"-  , mkTestModChange rmDecl5 "RmDecl5.hs"-  , mkTestModChange rmDecl6 "RmDecl6.hs"-  , mkTestModChange rmDecl7 "RmDecl7.hs"--  , mkTestModChange rmTypeSig1 "RmTypeSig1.hs"-  , mkTestModChange rmTypeSig2 "RmTypeSig2.hs"--  , mkTestModChange addHiding1 "AddHiding1.hs"-  , mkTestModChange addHiding2 "AddHiding2.hs"--  , mkTestModChange cloneDecl1 "CloneDecl1.hs"-  ]---- -----------------------------------------------------------------------addLocaLDecl1 :: Changer-addLocaLDecl1 ans lp = do-  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  let declAnns' = setPrecedingLines newDecl 1 4 declAnns-      doAddLocal = do-        (d1:d2:_) <- hsDecls lp-        balanceComments d1 d2-        (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do-          return ((newDecl : d),Nothing)-        replaceDecls lp [d1', d2]--  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns') doAddLocal-  -- putStrLn $ "log:\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------addLocaLDecl2 :: Changer-addLocaLDecl2 ans lp = do-  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  let-      doAddLocal = do-         tlDecs <- hsDecls lp-         let parent = head tlDecs-         balanceComments parent (head $ tail tlDecs)--         (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do-           transferEntryDPT (head decls) newDecl-           setEntryDPT (head decls) (DP (1, 0))-           return ((newDecl:decls),Nothing)--         replaceDecls lp (parent':tail tlDecs)--  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal-  -- putStrLn $ "log:\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------addLocaLDecl3 :: Changer-addLocaLDecl3 ans lp = do-  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  let-      doAddLocal = do-         -- logDataWithAnnsTr "parsed:" lp-         logDataWithAnnsTr "newDecl:" newDecl-         tlDecs <- hsDecls lp-         let parent = head tlDecs-         balanceComments parent (head $ tail tlDecs)--         (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do-           setPrecedingLinesT newDecl 1 0-           moveTrailingComments m (last decls)-           return ((decls++[newDecl]),Nothing)--         replaceDecls lp (parent':tail tlDecs)--  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal-  -- putStrLn $ "log\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------addLocaLDecl4 :: Changer-addLocaLDecl4 ans lp = do-  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  Right (sigAnns, newSig)   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")-  -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp-  let-      doAddLocal = do-         tlDecs <- hsDecls lp-         let parent = head tlDecs--         setPrecedingLinesT newSig  1 0-         setPrecedingLinesT newDecl 1 0--         (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do-           return ((decls++[newSig,newDecl]),Nothing)--         replaceDecls lp (parent':tail tlDecs)--  let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal-  -- putStrLn $ "log\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------addLocaLDecl5 :: Changer-addLocaLDecl5 ans lp = do-  let-      doAddLocal = do-         [s1,d1,d2,d3] <- hsDecls lp--         transferEntryDPT d2 d3--         (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do-           return ([d2],Nothing)-         replaceDecls lp [s1,d1',d3]--  let (lp',(ans',_),_w) = runTransform ans doAddLocal-  -- putStrLn $ "log\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------addLocaLDecl6 :: Changer-addLocaLDecl6 ans lp = do-  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3")-  let declAnns' = setPrecedingLines newDecl 1 4 declAnns-      doAddLocal = do-        [d1,d2] <- hsDecls lp-        balanceComments d1 d2--#if __GLASGOW_HASKELL__ <= 710-        let GHC.L _ (GHC.ValD (GHC.FunBind  _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1-#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--        (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do-           return ((newDecl : decls),Nothing)-        replaceDecls lp [d1', d2]--  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns') doAddLocal-  -- putStrLn $ "log:\n" ++ intercalate "\n" _w-  return (ans',lp')--- -----------------------------------------------------------------------rmDecl1 :: Changer-rmDecl1 ans lp = do-  let doRmDecl = do-         tlDecs <- hsDecls lp-         let (d1:s1:d2:ds) = tlDecs--         -- First delete the decl (d2) only-         balanceComments s1 d2 -- ++AZ++-         balanceComments d2 (head ds)-         lp1 <- replaceDecls lp (d1:s1:ds)-         -- return lp1--         -- Then delete the sig separately-         tlDecs1 <- hsDecls lp1-         let (d1':s1':ds') = tlDecs1-         -- transferEntryDPT s1' (head ds')  -- required in HaRe.-         balanceComments d1' s1'-         balanceComments s1' (head ds')-         transferEntryDPT s1' (head ds')  -- required in HaRe.-         replaceDecls lp (d1':ds')--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  return (ans',lp')---- -----------------------------------------------------------------------rmDecl2 :: Changer-rmDecl2 ans lp = do-  let-      doRmDecl = do-        let-          go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs)-          go e@(GHC.L _ (GHC.HsLet{})) = do-            decs <- hsDecls e-            e' <- replaceDecls e (init decs)-            return e'-          go x = return x--        SYB.everywhereM (SYB.mkM go) lp--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  -- putStrLn $ "log:\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------rmDecl3 :: Changer-rmDecl3 ans lp = do-  let-      doRmDecl = do-         [d1,d2] <- hsDecls lp--         (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do-           setPrecedingLinesDeclT sd1 2 0-           return ([],Just sd1)--         replaceDecls lp [d1',sd1,d2]--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  -- putStrLn $ "log:\n" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------rmDecl4 :: Changer-rmDecl4 ans lp = do-  let-      doRmDecl = do-         [d1] <- hsDecls lp--         (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do-           -- [sd1,sd2] <- hsDecls d1-           transferEntryDPT sd1 sd2--           setPrecedingLinesDeclT sd1 2 0-           -- d1' <- replaceDecls d1 [sd2]-           return ([sd2],Just sd1)--         replaceDecls lp [d1',sd1]--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  return (ans',lp')---- -----------------------------------------------------------------------rmDecl5 :: Changer-rmDecl5 ans lp = do-  let-      doRmDecl = do-        let-          go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs)-#if __GLASGOW_HASKELL__ <= 710-          go (GHC.HsLet lb expr) = do-#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-            transferEntryDPT (head decs) dec-            lb' <- replaceDeclsValbinds lb [dec]-#if __GLASGOW_HASKELL__ <= 710-            return (GHC.HsLet lb' expr)-#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--        SYB.everywhereM (SYB.mkM go) lp--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  -- putStrLn $ "log:" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------rmDecl6 :: Changer-rmDecl6 ans lp = do-  let-      doRmDecl = do-         [d1] <- hsDecls lp--         (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do-           let (ss1:_sd1:sd2:sds) = subDecs-           transferEntryDPT ss1 sd2--           return (sd2:sds,Nothing)--         replaceDecls lp [d1']--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  -- putStrLn $ "log:" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------rmDecl7 :: Changer-rmDecl7 ans lp = do-  let-      doRmDecl = do-         tlDecs <- hsDecls lp-         let [s1,d1,d2,d3] = tlDecs--         balanceComments d1 d2-         balanceComments d2 d3--         transferEntryDPT d2 d3--         replaceDecls lp [s1,d1,d3]--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  -- putStrLn $ "log:" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------rmTypeSig1 :: Changer-rmTypeSig1 ans lp = do-  let doRmDecl = do-         tlDecs <- hsDecls lp-         let (s1:d1:d2) = tlDecs-#if __GLASGOW_HASKELL__ <= 710-             (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1-             s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p)))-#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)--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  return (ans',lp')---- -----------------------------------------------------------------------rmTypeSig2 :: Changer-rmTypeSig2 ans lp = do-  let doRmDecl = do-         tlDecs <- hsDecls lp-         let [d1] = tlDecs--         (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do-           transferEntryDPT s d-           return ([d],Nothing)-         replaceDecls lp [d1']--  let (lp',(ans',_),_w) = runTransform ans doRmDecl-  -- putStrLn $ "log:" ++ intercalate "\n" _w-  return (ans',lp')---- -----------------------------------------------------------------------addHiding1 :: Changer-addHiding1 ans (GHC.L l p) = do-  let doTransform = do-        l0 <- uniqueSrcSpanT-        l1 <- uniqueSrcSpanT-        l2 <- uniqueSrcSpanT-        let-          [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__ > 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-          v1 = GHC.L l1 (GHC.IEVar n1)-          v2 = GHC.L l2 (GHC.IEVar n2)-#endif-          impHiding = GHC.L l0 [v1,v2]-          imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)}-          p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]}-        addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]-        addSimpleAnnT n1        (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]-        addSimpleAnnT v1        (DP (0,0)) [((G GHC.AnnComma),DP (0,0))]-        addSimpleAnnT n2        (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]-        return (GHC.L l p')--  let (lp',(ans',_),_w) = runTransform ans doTransform-  return (ans',lp')---- -----------------------------------------------------------------------addHiding2 :: Changer-addHiding2 ans (GHC.L l p) = do-  let doTransform = do-        l1 <- uniqueSrcSpanT-        l2 <- uniqueSrcSpanT-        let-          [GHC.L li imp1] = GHC.hsmodImports p-          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__ > 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-          v1 = GHC.L l1 (GHC.IEVar n1)-          v2 = GHC.L l2 (GHC.IEVar n2)-#endif-          imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))}-          p' = p { GHC.hsmodImports = [GHC.L li imp1']}-        addSimpleAnnT n1        (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]-        addSimpleAnnT v1        (DP (0,0)) [((G GHC.AnnComma),DP (0,0))]-        addSimpleAnnT n2        (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]-        addTrailingCommaT (last ns)-        return (GHC.L l p')--  let (lp',(ans',_),_w) = runTransform ans doTransform-  return (ans',lp')---- -----------------------------------------------------------------------cloneDecl1 :: Changer-cloneDecl1 ans lp = do-  let doChange = do-         tlDecs <- hsDecls lp-         let (d1:d2:ds) = tlDecs-         d2' <- fst <$> cloneT d2-         replaceDecls lp (d1:d2:d2':ds)--  let (lp',(ans',_),_w) = runTransform ans doChange-  return (ans',lp')+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++ -- Many of the tests match on a specific expected value,the other patterns should trigger a fail+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module Test.Transform where++import Language.Haskell.GHC.ExactPrint+-- import Language.Haskell.GHC.ExactPrint.ExactPrint+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Parsers+import Language.Haskell.GHC.ExactPrint.Utils++import GHC                       as GHC+import GHC.Data.FastString       as GHC+import GHC.Types.Name.Occurrence as GHC+import GHC.Types.Name.Reader     as GHC++import Data.Generics as SYB++import System.FilePath+import Data.List++import Test.Common++import Test.HUnit++transformTestsTT :: LibDir -> Test+transformTestsTT libdir = TestLabel "transformTestsTT" $ TestList+  [+    mkTestModChange libdir addLocaLDecl5  "AddLocalDecl5.hs"+  ]++transformTests :: LibDir -> Test+transformTests libdir = TestLabel "transformation tests" $ TestList+  [+    TestLabel "Low level transformations"+       (TestList (transformLowLevelTests libdir))+  , TestLabel "High level transformations"+       (TestList (transformHighLevelTests libdir))+  ]++transformLowLevelTests :: LibDir -> [Test]+transformLowLevelTests libdir = [+    mkTestModChange libdir changeRenameCase1 "RenameCase1.hs"+  , mkTestModChange libdir changeLayoutLet2  "LayoutLet2.hs"+  , mkTestModChange libdir changeLayoutLet3  "LayoutLet3.hs"+  , mkTestModChange libdir changeLayoutLet3  "LayoutLet4.hs"+  , mkTestModChange libdir changeRename1     "Rename1.hs"+  , mkTestModChange libdir changeRename2     "Rename2.hs"+  , mkTestModChange libdir changeLayoutIn1   "LayoutIn1.hs"+  , mkTestModChange libdir changeLayoutIn3   "LayoutIn3.hs"+  , mkTestModChange libdir changeLayoutIn3   "LayoutIn3a.hs"+  , mkTestModChange libdir changeLayoutIn3   "LayoutIn3b.hs"+  , mkTestModChange libdir changeLayoutIn4   "LayoutIn4.hs"+  , mkTestModChange libdir changeLocToName   "LocToName.hs"+  , mkTestModChange libdir changeLetIn1      "LetIn1.hs"+  , mkTestModChange libdir changeWhereIn4    "WhereIn4.hs"+  , mkTestModChange libdir changeAddDecl     "AddDecl.hs"+  , mkTestModChange libdir changeLocalDecls  "LocalDecls.hs"+  , mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs"+  , mkTestModChange libdir changeWhereIn3a   "WhereIn3a.hs"+  , mkTestModChange libdir changeWhereIn3b   "WhereIn3b.hs"+--  , mkTestModChange changeCifToCase  "C.hs"          "C"+  ]++mkTestModChange :: LibDir -> Changer -> FilePath -> Test+mkTestModChange libdir f file = mkTestMod libdir "expected" "transform" f file++mkTestModBad :: LibDir -> FilePath -> Test+mkTestModBad libdir file+  = mkTestMod libdir "bad" "failing" noChange file++mkTestModBadMD :: LibDir -> FilePath -> Test+mkTestModBadMD libdir file+  = mkTestMod libdir "bad" "failing" changeMakeDelta file++mkTestMod :: LibDir -> String -> FilePath -> Changer -> FilePath ->  Test+mkTestMod libdir suffix dir f fp =+  let basename       = testPrefix </> dir </> fp+      expected       = basename <.> suffix+      writeFailure   = writeFile (basename <.> "out")+  in+    TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id+                        <$> genTest libdir f basename expected+                 writeFailure (debugTxt r)+                 assertBool fp (status r == Success))+++-- ---------------------------------------------------------------------++-- | Check that balanceCommentsList is idempotent+changeWhereIn3a :: Changer+changeWhereIn3a _libdir (L l p) = do+  let decls0 = hsmodDecls p+      decls = balanceCommentsList decls0+      (_de0:_:de1:_d2:_) = decls+  debugM $ "changeWhereIn3a:de1:" ++ showAst de1+  let p2 = p { hsmodDecls = decls}+  return (L l p2)++-- ---------------------------------------------------------------------++changeWhereIn3b :: Changer+changeWhereIn3b _libdir (L l p) = do+  let decls0 = hsmodDecls p+      decls = balanceCommentsList decls0+      (de0:tdecls@(_:de1:d2:_)) = decls+      de0' = setEntryDP de0 (DifferentLine 2 0)+      de1' = setEntryDP de1 (DifferentLine 2 0)+      d2' = setEntryDP d2 (DifferentLine 2 0)+      decls' = d2':de1':de0':tdecls+  debugM $ "changeWhereIn3b:de1':" ++ showAst de1'+  let p2 = p { hsmodDecls = decls'}+  return (L l p2)++-- ---------------------------------------------------------------------++-- | Add a local declaration with signature to LocalDecl, where there was no+-- prior local decl. So it adds a "where" annotation.+changeLocalDecls2 :: Changer+changeLocalDecls2 libdir (L l p) = do+  Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")+  Right s@(L ls (SigD _ sig))  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")+  let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)+  let  sig' = setEntryDP (L ls  sig) (SameLine 2)+  let (p',_,_w) = runTransform doAddLocal+      doAddLocal = everywhereM (mkM replaceLocalBinds) p+      replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)+                        -> Transform (LMatch GhcPs (LHsExpr GhcPs))+      replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do+        let anc = (EpaDelta noSrcSpan (DifferentLine 1 2) [])+        let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) [])+        let an = EpAnn anc+                        (AnnList (Just anc2) ListNone+                                 []+                                 (EpTok (EpaDelta noSrcSpan (SameLine 0) []))+                                 [])+                        emptyComments+        let decls = [s,d]+        let sortKey = captureOrderBinds decls+        let binds = (HsValBinds an (ValBinds sortKey [decl']+                                    [sig']))+        return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds)))+      replaceLocalBinds x = return x+  return (L l p')++-- ---------------------------------------------------------------------++-- | Add a local declaration with signature to LocalDecl+changeLocalDecls :: Changer+changeLocalDecls libdir (L l p) = do+  Right s@(L ls (SigD _ sig))  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")+  Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")+  let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)+  let  sig' = setEntryDP (L ls sig)  (SameLine 0)+  let (p',_,_w) = runTransform doAddLocal+      doAddLocal = everywhereM (mkM replaceLocalBinds) p+      replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)+                        -> Transform (LMatch GhcPs (LHsExpr GhcPs))+      replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do+        let oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs+        let decls = s:d:oldDecls+        let oldDecls' = captureLineSpacing oldDecls+        let oldBinds     = concatMap decl2Bind oldDecls'+            (os:oldSigs) = concatMap decl2Sig  oldDecls'+            os' = setEntryDP os (DifferentLine 2 0)+        let sortKey = captureOrderBinds decls+        let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van+        let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs)+        let binds' = (HsValBinds van'+                          (ValBinds sortKey (decl':oldBinds)+                                          (sig':os':oldSigs)))+        return (L lm (Match an mln pats (GRHSs emptyComments rhs binds')))+                   `debug` ("oldDecls=" ++ showAst oldDecls)+      replaceLocalBinds x = return x+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+  return (L l p')++-- ---------------------------------------------------------------------++-- | Add a declaration to AddDecl+changeAddDecl :: Changer+changeAddDecl libdir top = do+  Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")+  let decl' = setEntryDP decl (DifferentLine 2 0)++  let (p',_,_w) = runTransform doAddDecl+      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top+      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource+      replaceTopLevelDecls m = return $ insertAtStart m decl'+  return p'++-- ---------------------------------------------------------------------++changeRenameCase1 :: Changer+changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed)++changeRenameCase2 :: Changer+changeRenameCase2 _libdir parsed = return (rename "fooLonger" [((3,1),(3,4))] parsed)++changeLayoutLet2 :: Changer+changeLayoutLet2 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed)++changeLocToName :: Changer+changeLocToName _libdir parsed = return (rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed)++changeLayoutIn3 :: Changer+changeLayoutIn3 _libdir parsed = return (rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed)++changeLayoutIn4 :: Changer+changeLayoutIn4 _libdir parsed = return (rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed)++changeLayoutIn1 :: Changer+changeLayoutIn1 _libdir parsed = return (rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed)++changeRename1 :: Changer+changeRename1 _libdir parsed = return (rename "bar2" [((3,1),(3,4))] parsed)++changeRename2 :: Changer+changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed)++changeLayoutLet3 :: Changer+changeLayoutLet3 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed)++changeLayoutLet5 :: Changer+changeLayoutLet5 _libdir parsed = return (rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed)+++rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a+rename newNameStr spans' a+  = everywhere (mkT replaceRdr) a+  where+    newName = mkRdrUnqual (mkVarOcc newNameStr)++    cond :: SrcSpan -> Bool+    cond ln = ss2range ln `elem` spans'++    replaceRdr :: LocatedN RdrName -> LocatedN RdrName+    replaceRdr (L ln _)+        | cond (locA ln) = L ln newName+    replaceRdr x = x++-- ---------------------------------------------------------------------++changeWhereIn4 :: Changer+changeWhereIn4 _libdir parsed+  = return (everywhere (mkT replace) parsed)+  where+    replace :: LocatedN RdrName -> LocatedN RdrName+    replace (L ln _n)+      | ss2range (locA ln) == ((12,16),(12,17)) = L ln (mkRdrUnqual (mkVarOcc "p_2"))+    replace x = x++-- ---------------------------------------------------------------------++changeLetIn1 :: Changer+changeLetIn1 _libdir parsed+  = return (everywhere (mkT replace) parsed)+  where+    replace :: HsExpr GhcPs -> HsExpr GhcPs+    replace (HsLet (tkLet, _) localDecls expr)+      =+         let (HsValBinds x (ValBinds xv decls sigs)) = localDecls+             [l2,_l1] = map wrapDecl decls+             bagDecls' = concatMap decl2Bind [l2]+             (L _ e) = expr+             a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments+             expr' = L a e+             tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) [])+         in (HsLet (tkLet, tkIn')+                (HsValBinds x (ValBinds xv bagDecls' sigs)) expr')++    replace x = x++-- ---------------------------------------------------------------------++transformHighLevelTests :: LibDir -> [Test]+transformHighLevelTests libdir =+  [+    mkTestModChange libdir addLocaLDecl1  "AddLocalDecl1.hs"+  , mkTestModChange libdir addLocaLDecl2  "AddLocalDecl2.hs"+  , mkTestModChange libdir addLocaLDecl3  "AddLocalDecl3.hs"+  , mkTestModChange libdir addLocaLDecl4  "AddLocalDecl4.hs"+  , mkTestModChange libdir addLocaLDecl5  "AddLocalDecl5.hs"+  , mkTestModChange libdir addLocaLDecl6  "AddLocalDecl6.hs"++  , mkTestModChange libdir rmDecl1 "RmDecl1.hs"+  , mkTestModChange libdir rmDecl2 "RmDecl2.hs"+  , mkTestModChange libdir rmDecl3 "RmDecl3.hs"+  , mkTestModChange libdir rmDecl4 "RmDecl4.hs"+  , mkTestModChange libdir rmDecl5 "RmDecl5.hs"+  , mkTestModChange libdir rmDecl6 "RmDecl6.hs"++  -- Currently failing, arguable output+  -- , mkTestModChange libdir rmDecl7 "RmDecl7.hs"++  , mkTestModChange libdir rmTypeSig1 "RmTypeSig1.hs"+  , mkTestModChange libdir rmTypeSig2 "RmTypeSig2.hs"++  , mkTestModChange libdir addHiding1 "AddHiding1.hs"+  , mkTestModChange libdir addHiding2 "AddHiding2.hs"++  , mkTestModChange libdir cloneDecl1 "CloneDecl1.hs"+  ]++-- ---------------------------------------------------------------------++addLocaLDecl1 :: Changer+addLocaLDecl1 libdir top = do+  Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")+  let decl' = setEntryDP (L ld decl) (DifferentLine 1 5)+      doAddLocal :: ParsedSource+      doAddLocal = replaceDecls lp [de1', d2', d3]+        where+          lp = top+          (de1:d2:d3:_) = hsDecls lp+          (de1'',d2') = balanceComments de1 d2+          (de1',_) = modifyValD (getLocA de1'') de1'' $ \_m d -> ((wrapDecl decl' : d),Nothing)++  let lp' = doAddLocal+  return lp'++-- ---------------------------------------------------------------------++addLocaLDecl2 :: Changer+addLocaLDecl2 libdir lp = do+  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")+  let+      doAddLocal = replaceDecls lp [parent',d2']+        where+         (de1:d2:_) = hsDecls lp+         (de1'',d2') = balanceComments de1 d2++         (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) ->+             let+               newDecl' = transferEntryDP' d (makeDeltaAst newDecl)+               d' = setEntryDP d (DifferentLine 1 0)+             in ((newDecl':d':ds),Nothing)+++      lp' = doAddLocal+  return lp'++-- ---------------------------------------------------------------------++addLocaLDecl3 :: Changer+addLocaLDecl3 libdir top = do+  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")+  let+      doAddLocal = replaceDecls (anchorEof lp) [parent',d2']+        where+         lp = top+         (de1:d2:_) = hsDecls lp+         (de1'',d2') = balanceComments de1 d2++         (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) ->+           let+             newDecl' = setEntryDP newDecl (DifferentLine 1 0)+           in (((d:ds) ++ [newDecl']),Nothing)++      lp' = doAddLocal+  return lp'++-- ---------------------------------------------------------------------++addLocaLDecl4 :: Changer+addLocaLDecl4 libdir lp = do+  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")+  Right newSig  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")+  let+      doAddLocal = replaceDecls (anchorEof lp) (parent':ds)+        where+          (parent:ds) = hsDecls (makeDeltaAst lp)++          newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0)+          newSig'  = setEntryDP (makeDeltaAst newSig)  (DifferentLine 1 5)++          (parent',_) = modifyValD (getLocA parent) parent $ \_m decls ->+                         ((decls++[newSig',newDecl']),Nothing)+++      lp' = doAddLocal+  return lp'++-- ---------------------------------------------------------------------++addLocaLDecl5 :: Changer+addLocaLDecl5 _libdir lp = do+  let+      doAddLocal = replaceDecls lp (s1:de1':d3':ds)+        where+          decls = hsDecls lp+          (s1:de1:d2:d3:ds) = balanceCommentsList decls++          d3' = setEntryDP d3 (DifferentLine 2 0)++          (de1',_) = modifyValD (getLocA de1) de1 $ \_m _decls ->+                       let+                         d2' = setEntryDP d2 (DifferentLine 1 0)+                       in ([d2'],Nothing)++      lp' = doAddLocal+  return lp'++-- ---------------------------------------------------------------------++addLocaLDecl6 :: Changer+addLocaLDecl6 libdir lp = do+  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3")+  let+      newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 5)+      doAddLocal = replaceDecls lp [de1', d2]+        where+          decls0 = hsDecls lp+          [de1'',d2] = balanceCommentsList decls0++          de1 = captureMatchLineSpacing de1''+          L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1+          [ma1,_ma2] = ms++          (de1',_) = modifyValD (getLocA ma1) de1 $ \_m decls ->+                       ((newDecl' : decls),Nothing)++      lp' = doAddLocal+  return lp'++-- ---------------------------------------------------------------------++rmDecl1 :: Changer+rmDecl1 _libdir lp = do+  let+      doRmDecl = replaceDecls lp (de1:d3':ds)+        where+          tlDecs0 = hsDecls lp+          tlDecs = balanceCommentsList tlDecs0+          (de1:_s1:_d2:d3:ds) = tlDecs+          d3' = setEntryDP d3 (DifferentLine 2 0)+++      lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++rmDecl2 :: Changer+rmDecl2 _libdir lp = do+  let+      doRmDecl = do+        let+          go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs)+          go e@(GHC.L _ (GHC.HsLet{})) = do+            let decs0 = hsDecls e+            let decs = balanceCommentsList $ captureLineSpacing decs0+            let e' = replaceDecls e (init decs)+            return e'+          go x = return x++        everywhereM (mkM go) (makeDeltaAst lp)++  let (lp',_,_w) = runTransform doRmDecl+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+  return lp'++-- ---------------------------------------------------------------------++rmDecl3 :: Changer+rmDecl3 _libdir lp = do+  let+      doRmDecl = replaceDecls lp [de1',sd1,d2]+        where+          [de1,d2] = hsDecls lp+          (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a] ->+                       let+                           sd1' = setEntryDP sd1a (DifferentLine 2 0)+                       in ([],Just sd1')++      lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++rmDecl4 :: Changer+rmDecl4 _libdir lp = do+  let+      doRmDecl = replaceDecls (anchorEof lp) [de1',sd1]+        where+         [de1] = hsDecls lp+         (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] ->+           let+             sd2' = transferEntryDP' sd1a sd2+             sd1' = setEntryDP sd1a (DifferentLine 2 0)+           in ([sd2'],Just sd1')+      lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++rmDecl5 :: Changer+rmDecl5 _libdir lp = do+  let+      doRmDecl = do+        let+          go :: HsExpr GhcPs -> Transform (HsExpr GhcPs)+          go (HsLet (tkLet, tkIn) lb expr) = do+            let decs = hsDeclsLocalBinds lb+            let dec = last decs+            let lb' = replaceDeclsValbinds WithoutWhere lb [dec]+            return (HsLet (tkLet, tkIn) lb' expr)+          go x = return x++        everywhereM (mkM go) lp++  let (lp',_,_w) = runTransform doRmDecl+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+  return lp'++-- ---------------------------------------------------------------------++rmDecl6 :: Changer+rmDecl6 _libdir lp = do+  let+      doRmDecl = replaceDecls lp [de1']+        where+          [de1] = hsDecls lp++          (de1',_) = modifyValD (getLocA de1) de1 $ \_m subDecs ->+            let+              subDecs' = captureLineSpacing subDecs+              (ss1:_sd1:sd2:sds) = subDecs'+              sd2' = transferEntryDP' ss1 sd2+            in (sd2':sds,Nothing)++      lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++rmDecl7 :: Changer+rmDecl7 _libdir lp = do+  let+      doRmDecl = replaceDecls lp [s1,de1,d3']+        where+          tlDecs = hsDecls lp+          [s1,de1,d2,d3] = balanceCommentsList tlDecs+          d3' = transferEntryDP' d2 d3++      lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++rmTypeSig1 :: Changer+rmTypeSig1 _libdir lp = do+  let doRmDecl = replaceDecls lp (s1':de1:d2)+        where+          tlDecs = hsDecls lp+          (s0:de1:d2) = tlDecs+          s1 = captureTypeSigSpacing s0+          (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1+          L ln n2' = transferEntryDP n1 n2+          s1' = (L l (SigD x1 (TypeSig x2 [L (noTrailingN ln) n2'] typ)))++      lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++rmTypeSig2 :: Changer+rmTypeSig2 _libdir lp = do+  let doRmDecl = replaceDecls lp [de1']+        where+          tlDecs = hsDecls lp+          [de1] = tlDecs+          (de1',_) = modifyValD (getLocA de1) de1 $ \_m [_s,d] -> ([d],Nothing)++  let lp' = doRmDecl+  return lp'++-- ---------------------------------------------------------------------++addHiding1 :: Changer+addHiding1 _libdir (L l p) = do+  let doTransform = do+        let+          [L li imp1,imp2] = hsmodImports p+          n1 = L noAnnSrcSpanDP0 (mkVarUnqual (mkFastString "n1"))+          n2 = L noAnnSrcSpanDP0 (mkVarUnqual (mkFastString "n2"))+          v1 = L (addComma $ noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n1)) Nothing)+          v2 = L (           noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n2)) Nothing)+          impHiding = L (EpAnn d0+                               (AnnList Nothing+                                        (ListParens  (EpTok  d1) (EpTok d0))+                                        []+                                        (EpTok d1, [])+                                        [])+                                 emptyComments) [v1,v2]+          imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)}+          imp2' = setEntryDP imp2 (DifferentLine 2 0)+          p' = p { hsmodImports = [L li imp1',imp2']}+        return (L l p')++  let (lp',_,_w) = runTransform doTransform+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+  return lp'++-- ---------------------------------------------------------------------++addHiding2 :: Changer+addHiding2 _libdir top = do+  let doTransform = do+        let (L l p) = top+        let+          [L li imp1] = hsmodImports p+          Just (_,L _lh ns) = ideclImportList imp1+          lh' = (EpAnn d0+                       (AnnList Nothing+                                (ListParens (EpTok d1) (EpTok d0))+                                []+                                (EpTok d1, [])+                                [])+                         emptyComments)+          n1 = L (noAnnSrcSpanDP0) (mkVarUnqual (mkFastString "n1"))+          n2 = L (noAnnSrcSpanDP0) (mkVarUnqual (mkFastString "n2"))+          v1 = L (addComma $ noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n1)) Nothing)+          v2 = L (           noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n2)) Nothing)+          L ln n = last ns+          n' = L (addComma ln) n+          imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))}+          p' = p { hsmodImports = [L li imp1']}+        return (L l p')++  let (lp',_,_w) = runTransform doTransform+  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+  return lp'++-- ---------------------------------------------------------------------++cloneDecl1 :: Changer+cloneDecl1 _libdir lp = do+  let doChange = replaceDecls lp (d1':d2:d2'':ds)+        where+          tlDecs = hsDecls (makeDeltaAst lp)+          (d1':d2:ds) = tlDecs+          d2' = d2+          d2'' = setEntryDP d2' (DifferentLine 2 0)++  let lp' = doChange+  return lp'  -- ---------------------------------------------------------------------
+ tests/examples/failing/CppComment.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}+module CppComment where++trace_options =+-- c1+#if 0+    x+#endif+    y
+ tests/examples/failing/CppComment.hs.bad view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}+module CppComment where++trace_options =++#if 0+    x+#endif+    y
− tests/examples/failing/InfixOperator.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}--#define BACKSLASH 92-#define CLOSE_CURLY 125-#define CLOSE_SQUARE 93-#define COMMA 44-#define DOUBLE_QUOTE 34-#define OPEN_CURLY 123-#define OPEN_SQUARE 91-#define C_0 48-#define C_9 57-#define C_A 65-#define C_F 70-#define C_a 97-#define C_f 102-#define C_n 110-#define C_t 116--json_ :: Parser Value -> Parser Value -> Parser Value-json_ obj ary = do-  w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)-  if w == OPEN_CURLY-    then obj-    else ary-{-# INLINE json_ #-}-
− tests/examples/failing/InfixOperator.hs.bad 
@@ -1,25 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}--#define BACKSLASH 92-#define CLOSE_CURLY 125-#define CLOSE_SQUARE 93-#define COMMA 44-#define DOUBLE_QUOTE 34-#define OPEN_CURLY 123-#define OPEN_SQUARE 91-#define C_0 48-#define C_9 57-#define C_A 65-#define C_F 70-#define C_a 97-#define C_f 102-#define C_n 110-#define C_t 116--json_ :: Parser Value -> Parser Value -> Parser Value-json_ obj ary = do-  w <- skipSpace *> A.satisfy (\w -> w == 123OPEN_CURLY w ==||) == OPEN_SQUARE)-  if w == 123OPEN_CURLY-    then obj-    else ary-{-# INLINE json_ #-}
− tests/examples/failing/List2.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE GADTs #-}--------------------------------------------------------------------------------- |--- Module      :  Type.Family.List--- Copyright   :  Copyright (C) 2015 Kyle Carter--- License     :  BSD3------ Maintainer  :  Kyle Carter <kylcarte@indiana.edu>--- Stability   :  experimental--- Portability :  RankNTypes------ Convenient aliases and type families for working with--- type-level lists.-------------------------------------------------------------------------------module Type.Family.List where--import Type.Family.Constraint-import Type.Family.Monoid-import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>))-import Type.Class.Witness--type Ø    = '[]-type (:<) = '(:)-infixr 5 :<-
− tests/examples/failing/List2.hs.bad 
@@ -1,40 +0,0 @@-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE GADTs #-}--------------------------------------------------------------------------------- |--- Module      :  Type.Family.List--- Copyright   :  Copyright (C) 2015 Kyle Carter--- License     :  BSD3------ Maintainer  :  Kyle Carter <kylcarte@indiana.edu>--- Stability   :  experimental--- Portability :  RankNTypes------ Convenient aliases and type families for working with--- type-level lists.-------------------------------------------------------------------------------module Type.Family.List where--import Type.Family.Constraint-import Type.Family.Monoid-import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>))-import Type.Class.Witness--type Ø    = '[]-type (:<) =  (:)-infixr 5 :<-
− tests/examples/failing/MultiLineWarningPragma.hs 
@@ -1,18 +0,0 @@--{-# WARNING Logic-          , mkSolver-          , mkSimpleSolver-          , mkSolverForLogic-          , solverSetParams-          , solverPush-          , solverPop-          , solverReset-          , solverGetNumScopes-          , solverAssertCnstr-          , solverAssertAndTrack-          , solverCheck-          , solverCheckAndGetModel-          , solverGetReasonUnknown-          "New Z3 API support is still incomplete and fragile: \-          \you may experience segmentation faults!"-  #-}
− tests/examples/failing/MultiLineWarningPragma.hs.bad 
@@ -1,17 +0,0 @@--{-# WARNING Logic-          , mkSolver-          , mkSimpleSolver-          , mkSolverForLogic-          , solverSetParams-          , solverPush-          , solverPop-          , solverReset-          , solverGetNumScopes-          , solverAssertCnstr-          , solverAssertAndTrack-          , solverCheck-          , solverCheckAndGetModel-          , solverGetReasonUnknown-          "New Z3 API support is still incomplete and fragile: you may experience segmentation faults!"-  #-}
− tests/examples/failing/OverloadedLabelsRun04_A.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}-module OverloadedLabelsRun04_A where--import GHC.OverloadedLabels-import Language.Haskell.TH--instance IsLabel x (Q [Dec]) where-  fromLabel _ = [d| main = putStrLn "Ok" |]
+ tests/examples/failing/T10970a.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}+main = do+#ifndef VERSION_containers+    putStrLn "OK"+#endif+#ifndef MIN_VERSION_base+    putStrLn "OK"+#endif
+ tests/examples/failing/T10970a.hs.bad view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+main = do+#ifndef VERSION_containers+    putStrLn "OK"+#endif+#ifndef MIN_VERSION_base+    putStrLn "OK"
− tests/examples/failing/TensorTests.hs 
@@ -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)-
− tests/examples/failing/TensorTests.hs.bad 
@@ -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)-
− tests/examples/failing/UnicodeRules.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE-    BangPatterns-  , FlexibleContexts-  , FlexibleInstances-  , ScopedTypeVariables-  , UnboxedTuples-  , UndecidableInstances-  , UnicodeSyntax-  #-}--strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool-{-# RULES "head → strictHead" [1]-    ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).-    head v = strictHead v #-}-{-# INLINE strictHead #-}-strictHead (Bitstream _ v) = head (SV.head v)
− tests/examples/failing/UnicodeRules.hs.bad 
@@ -1,16 +0,0 @@-{-# LANGUAGE-    BangPatterns-  , FlexibleContexts-  , FlexibleInstances-  , ScopedTypeVariables-  , UnboxedTuples-  , UndecidableInstances-  , UnicodeSyntax-  #-}--strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool-{-# RULES "head \8594 strictHead" [1]-    ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).-    head v = strictHead v #-}-{-# INLINE strictHead #-}-strictHead (Bitstream _ v) = head (SV.head v)
− tests/examples/failing/UnicodeSyntax.hs 
@@ -1,236 +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)-      }-
− tests/examples/failing/UnicodeSyntax.hs.bad 
@@ -1,236 +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)-      }-
− tests/examples/failing/overloadedlabelsrun04.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}--import OverloadedLabelsRun04_A---- Who knew that there were so many ways that a line could start with--- a # sign in Haskell? None of these are overloaded labels:-#line 7 "overloadedlabelsrun04.hs"-# 8 "overloadedlabelsrun04.hs"-#!notashellscript-#pragma foo---- But this one is:-#foo
− tests/examples/failing/overloadedlabelsrun04.hs.bad 
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}--import OverloadedLabelsRun04_A------#!notashellscript---- But this one is:--- a # sign in Haskell? None of these are overloaded labels:------#foo
+ tests/examples/failing/record-dot-operator-parens.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE RebindableSyntax #-}++data Foo = Foo {bar :: Foo}++operatorUpdate f = f{(+) = 1}
+ tests/examples/failing/record-dot-operator-parens.hs.bad view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE RebindableSyntax #-}++data Foo = Foo {bar :: Foo}++operatorUpdate f = f{+ = 1}
− tests/examples/ghc710-only/DataDecl.hs 
@@ -1,34 +0,0 @@-{-# Language DatatypeContexts #-}-{-# Language ExistentialQuantification #-}-{-# LAnguage GADTs #-}-{-# LAnguage KindSignatures #-}--data Foo = A-         | B-         | C----         | data_or_newtype capi_ctype tycl_hdr constrs deriving-data {-# Ctype "Foo" "bar" #-} F1 = F1-data {-# Ctype       "baz" #-} Eq a =>  F2 a = F2 a--data (Eq a,Ord a) => F3 a = F3 Int a--data F4 a = forall x y. (Eq x,Eq y) => F4 a x y-          | forall x y. (Eq x,Eq y) => F4b a x y---data G1 a :: * where-  G1A,  G1B :: Int -> G1 a-  G1C :: Double -> G1 a--data G2 a :: * where-  G2A { g2a :: a, g2b :: Int } :: G2 a-  G2C :: Double -> G2 a----data (Eq a,Ord a) => G3 a = G3-  { g3A :: Int-  , g3B :: Bool-  , g3a :: a-  } deriving (Eq,Ord)
− tests/examples/ghc710-only/HashQQ.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}--module Web.Maid.ApacheMimeTypes where---import qualified Data.Text as T-import Air.TH----apache_mime_types :: T.Text-apache_mime_types = [here|--# This file maps Internet media types to unique file extension(s).-# Although created for httpd, this file is used by many software systems-# and has been placed in the public domain for unlimited redisribution.-#-# The table below contains both registered and (common) unregistered types.-# A type that has no unique extension can be ignored -- they are listed-# here to guide configurations toward known types and to make it easier to-# identify "new" types.  File extensions are also commonly used to indicate-# content languages and encodings, so choose them carefully.-#-# Internet media types should be registered as described in RFC 4288.-# The registry is at .-#-# MIME type (lowercased)      Extensions-# ============================================  ==========-# application/1d-interleaved-parityfec-# application/3gpp-ims+xml-# application/activemessage-application/andrew-inset      ez |]---testComplex    = assertBool "" ([$istr|-        ok-#{Foo 4 "Great!" : [Foo 3 "Scott!"]}-        then-|] == ("\n" ++-    "        ok\n" ++-    "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++-    "        then\n"))-
− tests/examples/ghc710-only/QuasiQuote.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module QuasiQuote where--import T7918A--ex1 = [qq|e1|]-ex2 = [qq|e2|]-ex3 = [qq|e3|]-ex4 = [qq|e4|]--tx1 = undefined :: [qq|t1|]-tx2 = undefined :: [qq|t2|]-tx3 = undefined :: [qq|t3|]-tx4 = undefined :: [qq|t4|]--px1 [qq|p1|] = undefined-px2 [qq|p2|] = undefined-px3 [qq|p3|] = undefined-px4 [qq|p4|] = undefined--{-# LANGUAGE QuasiQuotes #-}--testComplex    = assertBool "" ([$istr|-        ok-#{Foo 4 "Great!" : [Foo 3 "Scott!"]}-        then-|] == ("\n" ++-    "        ok\n" ++-    "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++-    "        then\n"))-
− tests/examples/ghc710-only/TypeFamilies.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}---- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html--import Control.Concurrent.STM-import Control.Concurrent.MVar-import Data.Foldable (forM_)-import Data.IORef--class IOStore store where-  newIO :: a -> IO (store a)-  getIO :: store a -> IO a-  putIO :: store a -> a -> IO ()--instance IOStore MVar where-  newIO = newMVar-  getIO = readMVar-  putIO mvar a = modifyMVar_ mvar (return . const a)--instance IOStore IORef where-  newIO = newIORef-  getIO = readIORef-  putIO ioref a = modifyIORef ioref (const a)--type Present = String-storePresentsIO :: IOStore store => [Present] -> IO (store [Present])-storePresentsIO xs = do-  store <- newIO []-  forM_ xs $ \x -> do-    old <- getIO store-    putIO store (x : old)-  return store---- Type family version--class Store store where-  type StoreMonad store :: * -> *-  new :: a -> (StoreMonad store) (store a)-  get :: store a -> (StoreMonad store) a-  put :: store a -> a -> (StoreMonad store) ()--instance Store IORef where-  type StoreMonad IORef = IO-  new = newIORef-  get = readIORef-  put ioref a = modifyIORef ioref (const a)--instance Store TVar where-  type StoreMonad TVar = STM-  new = newTVar-  get = readTVar-  put ioref a = modifyTVar ioref (const a)--storePresents :: (Store store, Monad (StoreMonad store))-              => [Present] -> (StoreMonad store) (store [Present])-storePresents xs = do-  store <- new []-  forM_ xs $ \x -> do-    old <- get store-    put store (x : old)-  return store--type family (++) (a :: [k]) (b :: [k]) :: [k] where-    '[]       ++ b = b-    (a ': as) ++ b = a ': (as ++ b)--type family (f :: * -> *) |> (s :: * -> *) :: * -> *--type instance f |> Union s = Union (f :> s)--type family Compare (a :: k) (b :: k') :: Ordering where-  Compare '() '() = EQ--type family (r1 :++: r2); infixr 5 :++:-type instance r :++: Nil = r-type instance r1 :++: r2 :> a = (r1 :++: r2) :> a
− tests/examples/ghc710/AddAndOr3.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-module AddAndOr3 where--addAndOr3 :: _ -> _ -> _-addAndOr3 (a, b) (c, d) = (a `plus` d, b || c)-  where plus :: Int -> Int -> Int-        x `plus` y = x + y
− tests/examples/ghc710/AltsSemis.hs 
@@ -1,11 +0,0 @@---foo x =-  case x of-   { ;;; -- leading-     0 -> 'a';  -- case 0-     1 -> 'b'   -- case 1-   ; 2 -> 'c' ; -- case 2-   ; 3 -> 'd'   -- case 3-          ;;;   -- case 4-   }
− tests/examples/ghc710/Ann01.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Ann01 where--{-# ANN module (1 :: Int) #-}-{-# ANN module (1 :: Integer) #-}-{-# ANN module (1 :: Double) #-}-{-# ANN module $([| 1 :: Int |]) #-}-{-# ANN module "Hello" #-}-{-# ANN module (Just (1 :: Int)) #-}-{-# ANN module [1 :: Int, 2, 3] #-}-{-# ANN module ([1..10] :: [Integer]) #-}-{-# ANN module ''Foo #-}-{-# ANN module (-1 :: Int) #-}--{-# ANN type Foo (1 :: Int) #-}-{-# ANN type Foo (1 :: Integer) #-}-{-# ANN type Foo (1 :: Double) #-}-{-# ANN type Foo $([| 1 :: Int |]) #-}-{-# ANN type Foo "Hello" #-}-{-# ANN type Foo (Just (1 :: Int)) #-}-{-# ANN type Foo [1 :: Int, 2, 3] #-}-{-# ANN type Foo ([1..10] :: [Integer]) #-}-{-# ANN type Foo ''Foo #-}-{-# ANN type Foo (-1 :: Int) #-}-data Foo = Bar Int--{-# ANN f (1 :: Int) #-}-{-# ANN f (1 :: Integer) #-}-{-# ANN f (1 :: Double) #-}-{-# ANN f $([| 1 :: Int |]) #-}-{-# ANN f "Hello" #-}-{-# ANN f (Just (1 :: Int)) #-}-{-# ANN f [1 :: Int, 2, 3] #-}-{-# ANN f ([1..10] :: [Integer]) #-}-{-# ANN f 'f #-}-{-# ANN f (-1 :: Int) #-}-f x = x
− tests/examples/ghc710/AnnPackageName.hs 
@@ -1,4 +0,0 @@---import "base" Prelude-import "base" Data.Data
− tests/examples/ghc710/Annotations.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Annotations where--{-# ANN module (1 :: Int) #-}-{-# ANN module (1 :: Integer) #-}-{-# ANN module (1 :: Double) #-}-{-# ANN module $([| 1 :: Int |]) #-}-{-# ANN module "Hello" #-}-{-# ANN module (Just (1 :: Int)) #-}-{-# ANN module [1 :: Int, 2, 3] #-}-{-# ANN module ([1..10] :: [Integer]) #-}-{-# ANN module ''Foo #-}-{-# ANN module (-1 :: Int) #-}--{-# ANN type Foo (1 :: Int) #-}-{-# ANN type Foo (1 :: Integer) #-}-{-# ANN type Foo (1 :: Double) #-}-{-# ANN type Foo $([| 1 :: Int |]) #-}-{-# ANN type Foo "Hello" #-}-{-# ANN type Foo (Just (1 :: Int)) #-}-{-# ANN type Foo [1 :: Int, 2, 3] #-}-{-# ANN type Foo ([1..10] :: [Integer]) #-}-{-# ANN type Foo ''Foo #-}-{-# ANN type Foo (-1 :: Int) #-}-data Foo = Bar Int--{-# ANN f (1 :: Int) #-}-{-# ANN f (1 :: Integer) #-}-{-# ANN f (1 :: Double) #-}-{-# ANN f $([| 1 :: Int |]) #-}-{-# ANN f "Hello" #-}-{-# ANN f (Just (1 :: Int)) #-}-{-# ANN f [1 :: Int, 2, 3] #-}-{-# ANN f ([1..10] :: [Integer]) #-}-{-# ANN f 'f #-}-{-# ANN f (-1 :: Int) #-}-f x = x--{-# ANN foo "HLint: ignore" #-};foo = map f (map g x)
− tests/examples/ghc710/Arrow.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE Arrows #-}-module Arrow where--import Control.Arrow-import qualified Control.Category as Cat--addA :: Arrow a => a b Int -> a b Int -> a b Int-addA f g = proc x -> do-                y <- f -< x-                z <- g -< x-                returnA -< y + z--newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) }--instance Cat.Category Circuit where-    id = Circuit $ \a -> (Cat.id, a)-    (.) = dot-      where-        (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a ->-            let (cir1', b) = cir1 a-                (cir2', c) = cir2 b-            in  (cir2' `dot` cir1', c)--instance Arrow Circuit where-    arr f = Circuit $ \a -> (arr f, f a)-    first (Circuit cir) = Circuit $ \(b, d) ->-        let (cir', c) = cir b-        in  (first cir', (c, d))---- | Accumulator that outputs a value determined by the supplied function.-accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b-accum acc f = Circuit $ \input ->-    let (output, acc') = input `f` acc-    in  (accum acc' f, output)---- | Accumulator that outputs the accumulator value.-accum' :: b -> (a -> b -> b) -> Circuit a b-accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b'))--total :: Num a => Circuit a a-total = accum' 0 (+)--mean3 :: Fractional a => Circuit a a-mean3 = proc value -> do-    (t, n) <- (| (&&&) (total -< value) (total -< 1) |)-    returnA -< t / n
− tests/examples/ghc710/Arrows.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE Arrows #-}--- from https://ocharles.org.uk/blog/guest-posts/2014-12-21-arrows.html--import Control.Monad (guard)-import Control.Monad.Identity (Identity, runIdentity)-import Control.Arrow (returnA, Kleisli(Kleisli), runKleisli)--f :: Int -> (Int, Int)-f = \x ->-  let y  = 2 * x-      z1 = y + 3-      z2 = y - 5-  in (z1, z2)---- ghci> f 10--- (23, 15)--fM :: Int -> Identity (Int, Int)-fM = \x -> do-  y  <- return (2 * x)-  z1 <- return (y + 3)-  z2 <- return (y - 5)-  return (z1, z2)---- ghci> runIdentity (fM 10)--- (23,15)---fA :: Int -> (Int, Int)-fA = proc x -> do-  y  <- (2 *) -< x-  z1 <- (+ 3) -< y-  z2 <- (subtract 5) -< y-  returnA -< (z1, z2)---- ghci> fA 10--- (23,15)--range :: Int -> [Int]-range r = [-r..r]--cM :: Int -> [(Int, Int)]-cM = \r -> do-  x <- range 5-  y <- range 5-  guard (x*x + y*y <= r*r)-  return (x, y)---- ghci> take 10 (cM 5)--- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)]---type K = Kleisli--k :: (a -> m b) -> Kleisli m a b-k = Kleisli--runK :: Kleisli m a b -> (a -> m b)-runK = runKleisli--cA :: Kleisli [] Int (Int, Int)-cA = proc r -> do-  x <- k range -< 5-  y <- k range -< 5-  k guard -< (x*x + y*y <= r*r)-  returnA -< (x, y)---- ghci> take 10 (runK cA 5)--- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)]--getLineM :: String -> IO String-getLineM prompt = do-  print prompt-  getLine--printM :: String -> IO ()-printM = print--writeFileM :: (FilePath, String) -> IO ()-writeFileM  (filePath, string) = writeFile filePath string--procedureM :: String -> IO ()-procedureM = \prompt -> do-  input <- getLineM prompt-  if input == "Hello"-    then printM "You said 'Hello'"-    else writeFileM ("/tmp/output", "The user said '" ++ input ++ "'")
− tests/examples/ghc710/Associated.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}---- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example--import qualified Data.IntMap-import Prelude hiding (lookup)-import Data.Char (ord)--class GMapKey k where-  data GMap k :: * -> *-  empty       :: GMap k v-  lookup      :: k -> GMap k v -> Maybe v-  insert      :: k -> v -> GMap k v -> GMap k v---- An Int instance-instance GMapKey Int where-  data GMap Int v        = GMapInt (Data.IntMap.IntMap v)-  empty                  = GMapInt Data.IntMap.empty-  lookup k   (GMapInt m) = Data.IntMap.lookup k m-  insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m)---- A Char instance-instance GMapKey Char where-  data GMap Char v        = GMapChar (GMap Int v)-  empty                   = GMapChar empty-  lookup k (GMapChar m)   = lookup (ord k) m-  insert k v (GMapChar m) = GMapChar (insert (ord k) v m)---- A Unit instance-instance GMapKey () where-  data GMap () v           = GMapUnit (Maybe v)-  empty                    = GMapUnit Nothing-  lookup () (GMapUnit v)   = v-  insert () v (GMapUnit _) = GMapUnit $ Just v---- Product and sum instances-instance (GMapKey a, GMapKey b) => GMapKey (a, b) where-  data GMap (a, b) v            = GMapPair (GMap a (GMap b v))-  empty                         = GMapPair empty-  lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b-  insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of-                                    Nothing  -> insert a (insert b v empty) gm-                                    Just gm2 -> insert a (insert b v gm2  ) gm--instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where-  data GMap (Either a b) v                = GMapEither (GMap a v) (GMap b v)-  empty                                   = GMapEither empty empty-  lookup (Left  a) (GMapEither gm1  _gm2) = lookup a gm1-  lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2-  insert (Left  a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2-  insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2)--myGMap :: GMap (Int, Either Char ()) String-myGMap = insert (5, Left 'c') "(5, Left 'c')"    $-         insert (4, Right ()) "(4, Right ())"    $-         insert (5, Right ()) "This is the one!" $-         insert (5, Right ()) "This is the two!" $-         insert (6, Right ()) "(6, Right ())"    $-         insert (5, Left 'a') "(5, Left 'a')"    $-         empty--main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap---- (Type) Synonym Family--type family Elem c--type instance Elem [e] = e---- type instance Elem BitSet = Char---data family T a-data    instance T Int  = T1 Int | T2 Bool-newtype instance T Char = TC Bool--data family G a b-data instance G [a] b where-   G1 :: c -> G [Int] b-   G2 :: G [a] Bool
− tests/examples/ghc710/AssociatedType.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-class Foldable t where-  type FoldableConstraint t x :: *-  type FoldableConstraint t x = ()-
− tests/examples/ghc710/B.hs 
@@ -1,4 +0,0 @@--foo x = case (odd x) of-            True  -> "Odd"-            False -> "Even"
− tests/examples/ghc710/BCase.hs 
@@ -1,8 +0,0 @@---main =- case 1 > 10 of-   True  -> do putStrLn "hello"-               putStrLn "there"-   False -> do putStrLn "blah"-               putStrLn "blah"
− tests/examples/ghc710/BIf.hs 
@@ -1,8 +0,0 @@---main =- if 1 > 10-   then do putStrLn "hello"-           putStrLn "there"-   else do putStrLn "blah"-           putStrLn "blah"
− tests/examples/ghc710/Backquote.hs 
@@ -1,11 +0,0 @@-import Data.List--foo = do-  let genOut (f,st) = putStrLn (f ++ "\t"++go [e`div`4,e`div`2,3*e`div`4] (scanl1 (+) $ sort st))-  Just 5--f = undefined-go = undefined-e = undefined--
− tests/examples/ghc710/BangPatterns.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- From https://ocharles.org.uk/blog/posts/2014-12-05-bang-patterns.html--import Data.Function (fix)-import Data.List (foldl')--hello3 :: Bool -> String-hello3 !loud = "Hello."--mean :: [Double] -> Double-mean xs = s / fromIntegral l-  where-    (s, l) = foldl' step (0, 0) xs-    step (!s, !l) a = (s + a, l + 1)-
− tests/examples/ghc710/BootImport.hs 
@@ -1,3 +0,0 @@-module BootImport where--data Foo = Foo Int
− tests/examples/ghc710/BootImport.hs-boot 
@@ -1,3 +0,0 @@-module BootImport where--data Foo
− tests/examples/ghc710/BracesSemiDataDecl.hs 
@@ -1,7 +0,0 @@---data Nat (t :: NatKind) where-{-    ZeroNat :: Nat Zero;-    SuccNat :: Nat t -> Nat (Succ t);-};
− tests/examples/ghc710/CExpected.hs 
@@ -1,12 +0,0 @@-module CExpected where--- Test for refactor of if to case--- The comments on the then and else legs should be preserved--foo x = case (odd x) of-          True  -> -- This is an odd result-            bob x 1-          False -> -- This is an even result-            bob x 2--bob x y = x + y-
− tests/examples/ghc710/Case.hs 
@@ -1,5 +0,0 @@--foo x = case x of-          True -> "a"-          False -> "b"-
− tests/examples/ghc710/Cg008.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE MagicHash, BangPatterns #-}-{-# OPTIONS_GHC -O0 #-}---- Variant of cgrun066; compilation as a module is different.--module Cg008 (hashStr) where--import Foreign.C-import Data.Word-import Foreign.Ptr-import GHC.Exts--import Control.Exception--hashStr  :: Ptr Word8 -> Int -> Int-hashStr (Ptr a#) (I# len#) = loop 0# 0#-   where-    loop h n | isTrue# (n GHC.Exts.==# len#) = I# h-             | otherwise  = loop h2 (n GHC.Exts.+# 1#)-          where !c = ord# (indexCharOffAddr# a# n)-                !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091#
− tests/examples/ghc710/Commands.hs 
@@ -1,257 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--commands :: [Command]-commands = [-    command "help" "display a list of all commands, and their current keybindings" $ do-      macroGuesses <- Macro.guessCommands commandNames <$> getMacros-      addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose--  , command "log" "show the error log" $ do-      messages <- gets logMessages-      let widget = ListWidget.moveLast (ListWidget.new $ reverse messages)-      addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose--  , command "map" "display a list of all commands that are currently bound to keys" $ do-      showMappings--  , command "map" "display the command that is currently bound to the key {name}" $ do-      showMapping--  , command "map" [help|-        Bind the command {expansion} to the key {name}.  The same command may-        be bound to different keys.-        |] $ do-      addMapping--  , command "unmap" "remove the binding currently bound to the key {name}" $ do-      \(MacroName m) -> removeMacro m--  , command "mapclear" "" $ do-      clearMacros--  , command "exit" "exit vimus" $ do-      eval "quit"--  , command "quit" "exit vimus" $ do-      liftIO exitSuccess :: Vimus ()--  , command "close" "close the current window (not all windows can be closed)" $ do-      void closeTab--  , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do-      \(Path p) -> liftIO (expandHome p) >>= either printError source_--  , command "runtime" "" $-      \(Path p) -> liftIO (getDataFileName p) >>= source_--  , command "color" "define the fore- and background color for a thing on the screen." $ do-      \color fg bg -> liftIO (defineColor color fg bg) :: Vimus ()--  , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do-      MPD.repeat  True :: Vimus ()--  , command "norepeat" "Unset the playlist option *repeat*." $ do-      MPD.repeat  False :: Vimus ()--  , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do-      MPD.consume True :: Vimus ()--  , command "noconsume" "Unset the playlist option *consume*." $ do-      MPD.consume False :: Vimus ()--  , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do-      MPD.random  True :: Vimus ()--  , command "norandom" "Unset the playlist option *random*." $ do-      MPD.random  False :: Vimus ()--  , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do-      MPD.single  True :: Vimus ()--  , command "nosingle" "Unset the playlist option *single*." $ do-      MPD.single  False :: Vimus ()--  , command "autotitle" "Set the *autotitle* option.  When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do-      setAutoTitle True--  , command "noautotitle" "Unset the *autotitle* option." $ do-      setAutoTitle False--  , command "volume" "[+-] set volume to  or adjust by [+-] num" $ do-      volume :: Volume -> Vimus ()-- , command "toggle-repeat" "Toggle the *repeat* option." $ do-      MPD.status >>= MPD.repeat  . not . MPD.stRepeat :: Vimus ()--  , command "toggle-consume" "Toggle the *consume* option." $ do-      MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus ()--  , command "toggle-random" "Toggle the *random* option." $ do-      MPD.status >>= MPD.random  . not . MPD.stRandom :: Vimus ()--  , command "toggle-single" "Toggle the *single* option." $ do-      MPD.status >>= MPD.single  . not . MPD.stSingle :: Vimus ()--  , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do-      \(Path p) -> setLibraryPath p--  , command "next" "stop playing the current song, and starts the next one" $ do-      MPD.next :: Vimus ()--  , command "previous" "stop playing the current song, and starts the previous one" $ do-      MPD.previous :: Vimus ()--  , command "toggle" "toggle between play and pause" $ do-      MPDE.toggle :: Vimus ()--  , command "stop" "stop playback" $ do-      MPD.stop :: Vimus ()--  , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song.  MPD will only rescan a file already in the database if its modification time has changed." $ do-      void (MPD.update Nothing) :: Vimus ()--  , command "rescan" "" $ do-      void (MPD.rescan Nothing) :: Vimus ()--  , command "clear" "delete all songs from the playlist" $ do-      MPD.clear :: Vimus ()--  , command "search-next" "jump to the next occurrence of the search string in the current window"-      searchNext--  , command "search-prev" "jump to the previous occurrence of the search string in the current window"-      searchPrev---  , command "window-library" "open the *Library* window" $-      selectTab Library--  , command "window-playlist" "open the *Playlist* window" $-      selectTab Playlist--  , command "window-search" "open the *SearchResult* window" $-      selectTab SearchResult--  , command "window-browser" "open the *Browser* window" $-      selectTab Browser--  , command "window-next" "open the window to the right of the current one"-      nextTab--  , command "window-prev" "open the window to the left of the current one"-      previousTab--  , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example."-      runShellCommand--  , command "seek" "jump to the given position in the current song"-      seek--  , command "visual" "start visual selection" $-      sendEventCurrent EvVisual--  , command "novisual" "cancel visual selection" $-      sendEventCurrent EvNoVisual--  -- Remove current song from playlist-  , command "remove" "remove the song under the cursor from the playlist" $-      sendEventCurrent EvRemove--  , command "paste" "add the last deleted song after the selected song in the playlist" $-      sendEventCurrent EvPaste--  , command "paste-prev" "" $-      sendEventCurrent EvPastePrevious--  , command "copy" "" $-      sendEventCurrent EvCopy--  , command "shuffle" "shuffle the current playlist" $ do-      MPD.shuffle Nothing :: Vimus ()--  , command "add" "append selected songs to the end of the playlist" $ do-      sendEventCurrent EvAdd--  -- insert a song right after the current song-  , command "insert" [help|-      inserts a song to the playlist. The song is inserted after the currently-      playing song.-      |] $ do-      st <- MPD.status-      case MPD.stSongPos st of-        Just n -> do-          -- there is a current song, insert after-          sendEventCurrent (EvInsert (n + 1))-        _ -> do-          -- there is no current song, just add-          sendEventCurrent EvAdd--  -- Playlist: play selected song-  -- Library:  add song to playlist and play it-  -- Browse:   either add song to playlist and play it, or :move-in-  , command "default-action" [help|-      depending on the item under the cursor, somthing different happens:--      - *Playlist* start playing the song under the cursor--      - *Library* append the song under the cursor to the playlist and start playing it--      - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory.-      |] $ do-      sendEventCurrent EvDefaultAction--  , command "add-album" "add all songs of the album of the selected song to the playlist" $ do-      songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track]-      maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs--  , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do-      songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track]-      maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs--  -- movement-  , command "move-up" "move the cursor one line up" $-      sendEventCurrent EvMoveUp--  , command "move-down" "move the cursor one line down" $-      sendEventCurrent EvMoveDown--  , command "move-album-prev" "move the cursor up to the first song of an album" $-      sendEventCurrent EvMoveAlbumPrev--  , command "move-album-next" "move the cursor down to the first song of an album" $-      sendEventCurrent EvMoveAlbumNext--  , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $-      sendEventCurrent EvMoveIn--  , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $-      sendEventCurrent EvMoveOut--  , command "move-first" "go to the first line in the current window" $-      sendEventCurrent EvMoveFirst--  , command "move-last" "go to the last line in the current window" $-      sendEventCurrent EvMoveLast--  , command "scroll-up" "scroll the contents of the current window up one line" $-      sendEventCurrent (EvScroll (-1))--  , command "scroll-down" "scroll the contents of the current window down one line" $-      sendEventCurrent (EvScroll 1)--  , command "scroll-page-up" "scroll the contents of the current window up one page" $-      pageScroll >>= sendEventCurrent . EvScroll . negate--  , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $-      pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2)--  , command "scroll-page-down" "scroll the contents of the current window down one page" $-      pageScroll >>= sendEventCurrent . EvScroll--  , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $-      pageScroll >>= sendEventCurrent . EvScroll . (`div` 2)--  , command "song-format" "set song rendering format" $-      sendEvent . EvChangeSongFormat-  ]-
− tests/examples/ghc710/Control.hs 
@@ -1,210 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , ScopedTypeVariables-           , BangPatterns-  #-}--module GHC.Event.Control-    (-    -- * Managing the IO manager-      Signal-    , ControlMessage(..)-    , Control-    , newControl-    , closeControl-    -- ** Control message reception-    , readControlMessage-    -- *** File descriptors-    , controlReadFd-    , controlWriteFd-    , wakeupReadFd-    -- ** Control message sending-    , sendWakeup-    , sendDie-    -- * Utilities-    , setNonBlockingFD-    ) where--#include "EventConfig.h"--import Foreign.ForeignPtr (ForeignPtr)-import GHC.Base-import GHC.Conc.Signal (Signal)-import GHC.Real (fromIntegral)-import GHC.Show (Show)-import GHC.Word (Word8)-import Foreign.C.Error (throwErrnoIfMinus1_)-import Foreign.C.Types (CInt(..), CSize(..))-import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)-import Foreign.Marshal (alloca, allocaBytes)-import Foreign.Marshal.Array (allocaArray)-import Foreign.Ptr (castPtr)-import Foreign.Storable (peek, peekElemOff, poke)-import System.Posix.Internals (c_close, c_pipe, c_read, c_write,-                               setCloseOnExec, setNonBlockingFD)-import System.Posix.Types (Fd)--#if defined(HAVE_EVENTFD)-import Foreign.C.Error (throwErrnoIfMinus1)-import Foreign.C.Types (CULLong(..))-#else-import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)-#endif--data ControlMessage = CMsgWakeup-                    | CMsgDie-                    | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)-                                 {-# UNPACK #-} !Signal-    deriving (Eq, Show)---- | The structure used to tell the IO manager thread what to do.-data Control = W {-      controlReadFd  :: {-# UNPACK #-} !Fd-    , controlWriteFd :: {-# UNPACK #-} !Fd-#if defined(HAVE_EVENTFD)-    , controlEventFd :: {-# UNPACK #-} !Fd-#else-    , wakeupReadFd   :: {-# UNPACK #-} !Fd-    , wakeupWriteFd  :: {-# UNPACK #-} !Fd-#endif-    , didRegisterWakeupFd :: !Bool-    } deriving (Show)--#if defined(HAVE_EVENTFD)-wakeupReadFd :: Control -> Fd-wakeupReadFd = controlEventFd-{-# INLINE wakeupReadFd #-}-#endif---- | Create the structure (usually a pipe) used for waking up the IO--- manager thread from another thread.-newControl :: Bool -> IO Control-newControl shouldRegister = allocaArray 2 $ \fds -> do-  let createPipe = do-        throwErrnoIfMinus1_ "pipe" $ c_pipe fds-        rd <- peekElemOff fds 0-        wr <- peekElemOff fds 1-        -- The write end must be non-blocking, since we may need to-        -- poke the event manager from a signal handler.-        setNonBlockingFD wr True-        setCloseOnExec rd-        setCloseOnExec wr-        return (rd, wr)-  (ctrl_rd, ctrl_wr) <- createPipe-#if defined(HAVE_EVENTFD)-  ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0-  setNonBlockingFD ev True-  setCloseOnExec ev-  when shouldRegister $ c_setIOManagerWakeupFd ev-#else-  (wake_rd, wake_wr) <- createPipe-  when shouldRegister $ c_setIOManagerWakeupFd wake_wr-#endif-  return W { controlReadFd  = fromIntegral ctrl_rd-           , controlWriteFd = fromIntegral ctrl_wr-#if defined(HAVE_EVENTFD)-           , controlEventFd = fromIntegral ev-#else-           , wakeupReadFd   = fromIntegral wake_rd-           , wakeupWriteFd  = fromIntegral wake_wr-#endif-           , didRegisterWakeupFd = shouldRegister-           }---- | Close the control structure used by the IO manager thread.--- N.B. If this Control is the Control whose wakeup file was registered with--- the RTS, then *BEFORE* the wakeup file is closed, we must call--- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup--- file after it has been closed.-closeControl :: Control -> IO ()-closeControl w = do-  _ <- c_close . fromIntegral . controlReadFd $ w-  _ <- c_close . fromIntegral . controlWriteFd $ w-  when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)-#if defined(HAVE_EVENTFD)-  _ <- c_close . fromIntegral . controlEventFd $ w-#else-  _ <- c_close . fromIntegral . wakeupReadFd $ w-  _ <- c_close . fromIntegral . wakeupWriteFd $ w-#endif-  return ()--io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8-io_MANAGER_WAKEUP = 0xff-io_MANAGER_DIE    = 0xfe--foreign import ccall "__hscore_sizeof_siginfo_t"-    sizeof_siginfo_t :: CSize--readControlMessage :: Control -> Fd -> IO ControlMessage-readControlMessage ctrl fd-    | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do-                    throwErrnoIfMinus1_ "readWakeupMessage" $-                      c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)-                    return CMsgWakeup-    | otherwise =-        alloca $ \p -> do-            throwErrnoIfMinus1_ "readControlMessage" $-                c_read (fromIntegral fd) p 1-            s <- peek p-            case s of-                -- Wakeup messages shouldn't be sent on the control-                -- file descriptor but we handle them anyway.-                _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup-                _ | s == io_MANAGER_DIE    -> return CMsgDie-                _ -> do  -- Signal-                    fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)-                    withForeignPtr fp $ \p_siginfo -> do-                        r <- c_read (fromIntegral fd) (castPtr p_siginfo)-                             sizeof_siginfo_t-                        when (r /= fromIntegral sizeof_siginfo_t) $-                            error "failed to read siginfo_t"-                        let !s' = fromIntegral s-                        return $ CMsgSignal fp s'--  where wakeupBufferSize =-#if defined(HAVE_EVENTFD)-            8-#else-            4096-#endif--sendWakeup :: Control -> IO ()-#if defined(HAVE_EVENTFD)-sendWakeup c =-  throwErrnoIfMinus1_ "sendWakeup" $-  c_eventfd_write (fromIntegral (controlEventFd c)) 1-#else-sendWakeup c = do-  n <- sendMessage (wakeupWriteFd c) CMsgWakeup-  case n of-    _ | n /= -1   -> return ()-      | otherwise -> do-                   errno <- getErrno-                   when (errno /= eAGAIN && errno /= eWOULDBLOCK) $-                     throwErrno "sendWakeup"-#endif--sendDie :: Control -> IO ()-sendDie c = throwErrnoIfMinus1_ "sendDie" $-            sendMessage (controlWriteFd c) CMsgDie--sendMessage :: Fd -> ControlMessage -> IO Int-sendMessage fd msg = alloca $ \p -> do-  case msg of-    CMsgWakeup        -> poke p io_MANAGER_WAKEUP-    CMsgDie           -> poke p io_MANAGER_DIE-    CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"-  fromIntegral `fmap` c_write (fromIntegral fd) p 1--#if defined(HAVE_EVENTFD)-foreign import ccall unsafe "sys/eventfd.h eventfd"-   c_eventfd :: CInt -> CInt -> IO CInt--foreign import ccall unsafe "sys/eventfd.h eventfd_write"-   c_eventfd_write :: CInt -> CULLong -> IO CInt-#endif--foreign import ccall unsafe "setIOManagerWakeupFd"-   c_setIOManagerWakeupFd :: CInt -> IO ()
− tests/examples/ghc710/CoreIr.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Llvm.Data.CoreIr-       ( module Llvm.Data.CoreIr-       , module Llvm.Data.Shared-       , module Llvm.Data.IrType-       , module Data.Word-       , Label-       ) where-import Llvm.Data.Shared-import Llvm.Data.IrType-import Compiler.Hoopl (Label)-import Data.Int-import Data.Word (Word8, Word16, Word32, Word64)-import Data.DoubleWord--data Conversion s v where {-  AddrSpaceCast :: T (Type s P) v -> Type s P -> Conversion s v;-  } deriving (Eq, Ord, Show)-
− tests/examples/ghc710/CorePragma.hs 
@@ -1,6 +0,0 @@-{-# INLINE strictStream #-}-strictStream (Bitstream l v)-    = {-# CORE "Strict Bitstream stream" #-}-      S.concatMap stream (GV.stream v)-      `S.sized`-      Exact l
− tests/examples/ghc710/Cpp.hs 
@@ -1,17 +0,0 @@-{-# Language CPP #-}--#if __GLASGOW_HASKELL__ > 704-foo :: Int-#else-foo :: Integer-#endif-foo = 3--bar :: (-#if __GLASGOW_HASKELL__ > 704-    Int)-#else-    Integer)-#endif-bar = 4-
− tests/examples/ghc710/DataDecl.hs 
@@ -1,34 +0,0 @@-{-# Language DatatypeContexts #-}-{-# Language ExistentialQuantification #-}-{-# LAnguage GADTs #-}-{-# LAnguage KindSignatures #-}--data Foo = A-         | B-         | C----         | data_or_newtype capi_ctype tycl_hdr constrs deriving-data {-# Ctype "Foo" "bar" #-} F1 = F1-data {-# Ctype       "baz" #-} Eq a =>  F2 a = F2 a--data (Eq a,Ord a) => F3 a = F3 Int a--data F4 a = forall x y. (Eq x,Eq y) => F4 a x y-          | forall x y. (Eq x,Eq y) => F4b a x y---data G1 a :: * where-  G1A,  G1B :: Int -> G1 a-  G1C :: Double -> G1 a--data G2 a :: * where-  G2A :: { g2a :: a, g2b :: Int } -> G2 a-  G2C :: Double -> G2 a----data (Eq a,Ord a) => G3 a = G3-  { g3A :: Int-  , g3B :: Bool-  , g3a :: a-  } deriving (Eq,Ord)
− tests/examples/ghc710/DataFamilies.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- Based on https://www.haskell.org/haskellwiki/GHC/Type_families#Detailed_definition_of_data_families--module DataFamilies-  (-    GMap-  , GMapKey(type GMapK)-  ) where---- Type 1, Top level--data family GMap k :: * -> *--data family Array e--data family ArrayK :: * -> *----- Type 2, associated types--class GMapKey k where-  data GMapK k :: * -> *--class C a b c where { data T1 c a :: * }  -- OK--- class C a b c where { data T a a :: * }  -- Bad: repeated variable--- class D a where { data T a x :: * }      -- Bad: x is not a class variable-class D a where { data T2 a :: * -> * }   -- OK---- Instances--data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)--data family T3 a-data instance T3 Int  = A-data instance T3 Char = B-nonsense :: T3 a -> Int--- nonsense A = 1             -- WRONG: These two equations together...--- nonsense B = 2             -- ...will produce a type error.-nonsense = undefined---instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where-  data GMapK (Either a b) v = GMapEitherK (GMap a v) (GMap b v)---- data GMap () v = GMapUnit (Maybe v)---               deriving Show--
− tests/examples/ghc710/Dead1.hs 
@@ -1,42 +0,0 @@-{-# OPTIONS  -O -ddump-stranal #-}--module Dead1(foo) where--foo :: Int -> Int-foo n = baz (n+1) (bar1 n)--{-# NOINLINE bar1 #-}-bar1 n = 1 + bar n--bar :: Int -> Int-{-# NOINLINE bar #-}-{-# RULES-"bar/foo" forall n. bar (foo n) = n-   #-}-bar n = n-1--baz :: Int -> Int -> Int-{-# INLINE [0] baz #-}-baz m n = m---{- Ronam writes (Feb08)--    Note that bar becomes dead as soon as baz gets inlined. But strangely,-    the simplifier only deletes it after full laziness and CSE. That is, it-    is not deleted in the phase in which baz gets inlined. In fact, it is-    still there after w/w and the subsequent simplifier run. It gets deleted-    immediately if I comment out the rule.--    I stumbled over this when I removed one simplifier run after SpecConstr-    (at the moment, it runs twice at the end but I don't think that should-    be necessary). With this change, the original version of a specialised-    loop (the one with the rules) is not longer deleted even if it isn't-    used any more. I'll reenable the second simplifier run for now but-    should this really be necessary?--No, it should not be necessary.  A refactoring in OccurAnal makes-this work right. Look at the simplifier output just before strictness-analysis; there should be a binding for 'foo', but for nothing else.---}
− tests/examples/ghc710/Default.hs 
@@ -1,8 +0,0 @@-default (Integer, Double) -- "default default"--mag :: Float -> Float -> Float-mag x y = sqrt( x^2 + y^2 )--main = do--print $ mag 1 1
− tests/examples/ghc710/DefaultTypeInstance.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TypeFamilies #-}---class Foldable t where-  type FoldableConstraint t x :: Constraint-  type FoldableConstraint t x = ()
− tests/examples/ghc710/Deriving.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}--import Data.Data--data Foo = FooA | FooB--deriving instance Show Foo--deriving instance {-# Overlappable #-} Eq Foo-deriving instance {-# Overlapping  #-} Ord Foo-deriving instance {-# Overlaps     #-} Typeable Foo-deriving instance {-# Incoherent   #-} Data Foo-
− tests/examples/ghc710/DerivingOC.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- from https://ocharles.org.uk/blog/guest-posts/2014-12-15-deriving.html--import Data.Data-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.State--data MiniIoF a = Terminate-               | PrintLine String a-               | ReadLine (String -> a)-               deriving (Functor)----- data List a = Nil | Cons a (List a)---               deriving (Eq, Show, Functor, Foldable, Traversable)----data List a = Nil | Cons a (List a)-              deriving ( Eq, Show-                       , Functor, Foldable, Traversable-                       , Typeable, Data)--data Config = C String String-data AppState = S Int Bool--newtype App a = App { unApp :: ReaderT Config (StateT AppState IO) a }-                deriving (Monad, MonadReader Config,-                          MonadState AppState, MonadIO,-                          Applicative,Functor)
− tests/examples/ghc710/DoParens.hs 
@@ -1,4 +0,0 @@--foo = do-  (-) <- Just 5-  return ()
− tests/examples/ghc710/DoPatBind.hs 
@@ -1,4 +0,0 @@-module Main where--bar = do-  foo :: String <- baz
− tests/examples/ghc710/DocDecls.hs 
@@ -1,7 +0,0 @@-module DocDecls where---- | A document before-data Foo = A Int | B Char-         deriving (Show)--
− tests/examples/ghc710/DoubleForall.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---extremumNewton :: (Eq a, Fractional a) =>-                  (forall tag. forall tag1.-                          Tower tag1 (Tower tag a)-                              -> Tower tag1 (Tower tag a))-                      -> a -> [a]-extremumNewton f x0 = zeroNewton (diffUU f) x0
− tests/examples/ghc710/DroppedComma.hs 
@@ -1,5 +0,0 @@---foo =-  let (xs, ys) = ([1,2..3], [4,5..6]) in-  bar
− tests/examples/ghc710/DroppedDoSpace.hs 
@@ -1,26 +0,0 @@-import FooBarBaz -- non-existent import, check that we can still parse--save :: C -> IO ()-save state = saveFileDialog "Save file " (maybe Nothing (Just . (++) "*.") (filesuffix state)) $-             do \fileName ->-                    case onSaveCB state of-                      Nothing ->-                          return ()-                      Just callback ->-                          do-                            c <- callback-                            case c of-                              Nothing ->-                                   return ()-                              Just c' ->-                                  let realfn = maybe-                                                fileName-                                                (extendFileName fileName)-                                                (filesuffix state)-                                  in do-                                    L.writeFile realfn c'-                                    postGUIAsync $ labelSetText (View.statusL $ gui state) $ realfn ++ " Saved."-    where-      extendFileName fileName suffix = if isSuffixOf suffix fileName-                                         then fileName-                                         else fileName ++ "." ++ suffix
− tests/examples/ghc710/DroppedDoSpace2.hs 
@@ -1,6 +0,0 @@---save state = do \fileName ->-                  4--
− tests/examples/ghc710/EmptyMostly.hs 
@@ -1,13 +0,0 @@-module EmptyMostly where-   { ;;;-     ;;x=let{;;;;;y=2;;z=3;;;;}in y;-   -- ;;;;-    class Foo a where {;;;;;;-  (--<>--) :: a -> a -> Int  ;-  infixl 5 --<>-- ;-  (--<>--) _ _ = 2 ; -- empty decl at the end.-};--- ;;;;;;;;;;;;--- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;}--- ;;-   }
− tests/examples/ghc710/EmptyMostly2.hs 
@@ -1,8 +0,0 @@-module EmptyMostly2 where-   {-;;;;;;;;;;;;-;-class Baz a where {;;;;;;;;;- ; baz :: a -> Int;;;-}-   }
− tests/examples/ghc710/EmptyMostlyInst.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module EmptyMostlyInst where-   {-;;;;;;;;;;;;-;-instance Eq (Int,Integer) where {;;;;;;;;;-;;;;;;; a == b = False;;;;;;;;;;;-}-   }
− tests/examples/ghc710/EmptyMostlyNoSemis.hs 
@@ -1,8 +0,0 @@-module EmptyMostlyNoSemis where--x=let{y=2}in y-class Foo a where {-  (--<>--) :: a -> a -> Int;-  infixl 5 --<>--;-  (--<>--) _ _ = 2 ; -- empty decl at the end.- }
− tests/examples/ghc710/Existential.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}---- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html--data HashMap k v = HM  -- ... -- actual implementation--class Hashable v where-  h :: v -> Int--data HashMapM hm = HashMapM-  { empty  :: forall k v . hm k v-  , lookup :: Hashable k => k -> hm k v -> Maybe v-  , insert :: Hashable k => k -> v -> hm k v -> hm k v-  , union  :: Hashable k => hm k v -> hm k v -> hm k v-  }---data HashMapE = forall hm . HashMapE (HashMapM hm)---- public-mkHashMapE :: Int -> HashMapE-mkHashMapE = HashMapE . mkHashMapM---- private-mkHashMapM :: Int -> HashMapM HashMap-mkHashMapM salt = HashMapM { {- implementation -} }--instance Hashable String where--type Name = String-data Gift = G String--giraffe :: Gift-giraffe = G "giraffe"--addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift-addGift mod gifts =-  let-    HashMapM{..} = mod-  in-    insert "Ollie" giraffe gifts---- ---------------------------------santa'sSecretSalt = undefined-sendGiftToOllie = undefined-traverse_ = undefined--sendGifts =-  case mkHashMapE santa'sSecretSalt of-    HashMapE (mod@HashMapM{..}) ->-      let-        gifts = addGift mod empty-      in-        traverse_ sendGiftToOllie $ lookup "Ollie" gifts
− tests/examples/ghc710/ExplicitNamespaces.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}--module CLaSH.Prelude.BitIndex where--import GHC.TypeLits                   (KnownNat, type (+), type (-))
− tests/examples/ghc710/Expr.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Expr where--import Data.Generics-import Language.Haskell.TH as TH-import Language.Haskell.TH.Quote---- import Text.ParserCombinators.Parsec--- import Text.ParserCombinators.Parsec.Char--data Expr  =  IntExpr Integer-           |  AntiIntExpr String-           |  BinopExpr BinOp Expr Expr-           |  AntiExpr String-    deriving(Typeable, Data,Show)--data BinOp  =  AddOp-            |  SubOp-            |  MulOp-            |  DivOp-    deriving(Typeable, Data,Show)--eval :: Expr -> Integer-eval (IntExpr n)        = n-eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)-  where-    opToFun AddOp = (+)-    opToFun SubOp = (-)-    opToFun MulOp = (*)-    opToFun DivOp = (div)--small   = lower <|> char '_'-large   = upper-idchar  = small <|> large <|> digit <|> char '\''--lexeme p    = do{ x <- p; spaces; return x  }-symbol name = lexeme (string name)-parens p    = undefined -- between (symbol "(") (symbol ")") p--_expr :: CharParser st Expr-_expr   = term   `chainl1` mulop--term :: CharParser st Expr-term    = factor `chainl1` addop--factor :: CharParser st Expr-factor  = parens _expr <|> integer <|> anti--mulop   =  undefined-{--           do{ symbol "*"; return $ BinopExpr MulOp }-        <|> do{ symbol "/"; return $ BinopExpr DivOp }--}-addop   = undefined-{--  do{ symbol "+"; return $ BinopExpr AddOp }-        <|> do{ symbol "-"; return $ BinopExpr SubOp }--}--integer :: CharParser st Expr-integer  = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) }--anti   = undefined-{--  lexeme $-         do  symbol "$"-             c <- small-             cs <- many idchar-             return $ AntiIntExpr (c : cs)--}--parseExpr :: Monad m => TH.Loc -> String -> m Expr-parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s =-    case runParser p () "" s of-      Left err  -> fail $ "baz"-      Right e   -> return e-  where-    p = do  pos <- getPosition-            setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file-            spaces-            e <- _expr-            eof-            return e--expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat }--parseExprExp :: String -> Q Exp-parseExprExp s =  do  loc <- location-                      expr <- parseExpr loc s-                      dataToExpQ (const Nothing `extQ` antiExprExp) expr--antiExprExp :: Expr -> Maybe (Q Exp)-antiExprExp  (AntiIntExpr v)  = Just $ appE  (conE (mkName "IntExpr"))-                                                (varE (mkName v))-antiExprExp  (AntiExpr v)     = Just $ varE  (mkName v)-antiExprExp  _                = Nothing--parseExprPat :: String -> Q Pat-parseExprPat s =  do  loc <- location-                      expr <- parseExpr loc s-                      dataToPatQ (const Nothing `extQ` antiExprPat) expr--antiExprPat :: Expr -> Maybe (Q Pat)-antiExprPat  (AntiIntExpr v)  = Just $ conP  (mkName "IntExpr")-                                                [varP (mkName v)]-antiExprPat  (AntiExpr v)     = Just $ varP  (mkName v)-antiExprPat  _                = Nothing---- keep parser happy-runParser = undefined-getPosition = undefined-setPosition = undefined-setSourceName = undefined-setSourceLine = undefined-setSourceColumn = undefined-spaces = undefined-eof = undefined-many = undefined-digit = undefined-many1 = undefined-data CharParser a b = F a b-(<|>) = undefined-chainl1 = undefined-string = undefined-char = undefined-lower = undefined-upper = undefined-between = undefined-instance Monad (CharParser a) where-instance Applicative (CharParser a) where-instance Functor (CharParser a) where-
− tests/examples/ghc710/ExprPragmas.hs 
@@ -1,7 +0,0 @@-module ExprPragmas where--a = {-# SCC "name"   #-}  0x5--b = {-# SCC foo   #-} 006--c = {-# GENERATED "foobar" 1 : 2  -  3 :   4 #-} 0.00
− tests/examples/ghc710/ExtraConstraints1.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-module ExtraConstraints1 where--arbitCs1 :: _ => a -> String-arbitCs1 x = show (succ x) ++ show (x == x)--arbitCs2 :: (Show a, _) => a -> String-arbitCs2 x = arbitCs1 x--arbitCs3 :: (Show a, Enum a, _) => a -> String-arbitCs3 x = arbitCs1 x--arbitCs4 :: (Eq a, _) => a -> String-arbitCs4 x = arbitCs1 x--arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String-arbitCs5 x = arbitCs1 x
− tests/examples/ghc710/Field1.hs 
@@ -1,10 +0,0 @@-module Field1 where----Rename field name 'pointx' to 'pointx1'--data Point = Pt {pointx, pointy :: Float} deriving Show--absPoint :: Point -> Float-absPoint p = sqrt (pointx p * pointx p +-                  pointy p * pointy p)-
− tests/examples/ghc710/FooExpected.hs 
@@ -1,8 +0,0 @@---main =- case 1 > 10 of-   True  -> do putStrLn "hello"-               putStrLn "there"-   False -> do putStrLn "blah"-               putStrLn "blah"
− tests/examples/ghc710/ForAll.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module ForAll where--import Data.Data--foo ::  (forall a. Data a => a -> a) -> forall a. Data a => a -> a-foo a = a
− tests/examples/ghc710/ForeignDecl.hs 
@@ -1,107 +0,0 @@-{-# LANGUAGE MagicHash, UnliftedFFITypes #-}-{-# LANGUAGE ForeignFunctionInterface #-}---- Based on ghc/testsuite/tests/ffi/should_compile contents-module ForeignDecl where--import Foreign-import GHC.Exts-import Data.Int-import Data.Word---- simple functions--foreign import ccall unsafe "a" a :: IO Int--foreign import ccall unsafe "b" b :: Int -> IO Int--foreign import ccall unsafe "c"-  c :: Int -> Char -> Float -> Double -> IO Float---- simple monadic code--d =     a               >>= \ x ->-        b x             >>= \ y ->-        c y 'f' 1.0 2.0---- We can't import the same function using both stdcall and ccall--- calling conventions in the same file when compiling via C (this is a--- restriction in the C backend caused by the need to emit a prototype--- for stdcall functions).-foreign import stdcall        "p" m_stdcall :: StablePtr a -> IO (StablePtr b)-foreign import ccall   unsafe "q" m_ccall   :: ByteArray# -> IO Int---- We can't redefine the calling conventions of certain functions (those from--- math.h).-foreign import stdcall "my_sin" my_sin :: Double -> IO Double-foreign import stdcall "my_cos" my_cos :: Double -> IO Double--foreign import stdcall "m1" m8  :: IO Int8-foreign import stdcall "m2" m16 :: IO Int16-foreign import stdcall "m3" m32 :: IO Int32-foreign import stdcall "m4" m64 :: IO Int64--foreign import stdcall "dynamic" d8  :: FunPtr (IO Int8) -> IO Int8-foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16-foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32-foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64--foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ();--foreign import ccall unsafe "kitchen"-   sink :: Ptr a-        -> ByteArray#-        -> MutableByteArray# RealWorld-        -> Int-        -> Int8-        -> Int16-        -> Int32-        -> Int64-        -> Word8-        -> Word16-        -> Word32-        -> Word64-        -> Float-        -> Double-        -> IO ()---type Sink2 b = Ptr b-            -> ByteArray#-            -> MutableByteArray# RealWorld-            -> Int-            -> Int8-            -> Int16-            -> Int32-            -> Word8-            -> Word16-            -> Word32-            -> Float-            -> Double-            -> IO ()--foreign import ccall unsafe "dynamic"-  sink2 :: Ptr (Sink2 b) -> Sink2 b---- exports-foreign export ccall "plusInt" (+) :: Int -> Int -> Int--listToJSArray :: ToJSRef a => [a] -> IO (JSArray a)-listToJSArray = toJSArray deconstr-        where deconstr (x : xs) = Just (x, xs)-              deconstr [] = Nothing--foreign import javascript unsafe "$r = new Float32Array($1);"-        float32Array :: JSArray Float -> IO Float32Array--foreign import javascript unsafe "$r = new Int32Array($1);"-        int32Array :: JSArray Int32 -> IO Int32Array--foreign import javascript unsafe "$r = new Uint16Array($1);"-        uint16Array :: JSArray Word16 -> IO Uint16Array--foreign import javascript unsafe "$r = new Uint8Array($1);"-        uint8Array :: JSArray Word8 -> IO Uint8Array--foreign import javascript unsafe "$r = $1.getContext(\"webgl\");"-        getCtx :: JSRef a -> IO Ctx
− tests/examples/ghc710/FromUtils.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--import Data.Data----- -----------------------------------------------------------------------instance AnnotateP RdrName where-  annotateP l n = do-    case rdrName2String n of-      "[]" -> do-        addDeltaAnnotation AnnOpenS -- '['-        addDeltaAnnotation AnnCloseS -- ']'---- -----------------------------------------------------------------------class (Typeable ast) => AnnotateP ast where-  annotateP :: SrcSpan -> ast -> IO ()---type SrcSpan = Int-rdrName2String = undefined-type RdrName = String--data A = AnnOpenS | AnnCloseS--addDeltaAnnotation = undefined
− tests/examples/ghc710/FunDeps.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE FunctionalDependencies #-}---- FunDeps example-class Foo a b c | a b -> c where-  bar :: a -> b -> c-
− tests/examples/ghc710/FunctionalDeps.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}---- from https://ocharles.org.uk/blog/posts/2014-12-14-functional-dependencies.html--import Data.Foldable (forM_)-import Data.IORef--class Store store m | store -> m where- new :: a -> m (store a)- get :: store a -> m a- put :: store a -> a -> m ()--instance Store IORef IO where-  new = newIORef-  get = readIORef-  put ioref a = modifyIORef ioref (const a)-
− tests/examples/ghc710/GADTRecords.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE GADTs #-}-module GADTRecords (H1(..)) where---- | h1-data H1 a b where-  C1 :: H1 a b-  C2 :: Ord a => [a] -> H1 a a-  C3 :: { field :: Int -- ^ hello docs-        } -> H1 Int Int-  C4 :: { field2 :: a -- ^ hello2 docs-        } -> H1 Int a--  FwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f-                                            , analysisMeet :: f -> f -> f-                                            , analysisTransfer :: f -> Instruction -> m f-                                            , analysisFwdEdgeTransfer :: Maybe (f -> Instruction -> m [(BasicBlock, f)])-                                            } -> DataflowAnalysis m f--data GADT :: * -> * where-      Ctor :: { gadtField :: A } -> GADT A
− tests/examples/ghc710/GADTRecords2.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE GADTs #-}-module GADTRecords2 (H1(..)) where---- | h1-data H1 a b where-  C3 :: (Num a) => { field :: a -- ^ hello docs-                   } -> H1 Int Int
− tests/examples/ghc710/GHCOrig.hs 
@@ -1,211 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  GHC.Tuple--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/ghc-prim/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (GHC extensions)------ The tuple data types-----------------------------------------------------------------------------------module GHC.Tuple where---default () -- Double and Integer aren't available yet---- | The unit datatype @()@ has one non-undefined member, the nullary--- constructor @()@.-data () = ()--data (,) a b = (,) a b-data (,,) a b c = (,,) a b c-data (,,,) a b c d = (,,,) a b c d-data (,,,,) a b c d e = (,,,,) a b c d e-data (,,,,,) a b c d e f = (,,,,,) a b c d e f-data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g-data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h-data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i-data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j-data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k-data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l-data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m-data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n-data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o-data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p-data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q- = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q-data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r- = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r-data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s- = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s-data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t- = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t-data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u- = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u-data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v- = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v-data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w- = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w-data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x- = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x-data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y- = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y-data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z- = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z-data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__--{- Manuel says: Including one more declaration gives a segmentation fault.-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___  u___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___  u___ v___- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___--}
− tests/examples/ghc710/GenericDeriving.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}-import GHC.Generics---- from https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html--data Valid e a = Error e | OK a-  deriving (Generic)--toEither :: Valid e a -> Either e a-toEither (Error e) = Left e-toEither (OK a) = Right a--fromEither :: Either e a -> Valid e a-fromEither (Left e) = Error e-fromEither (Right a) = OK a---- -----------------------------------------------------------------------class GetError rep e | rep -> e where-  getError' :: rep a -> Maybe e--instance GetError f e => GetError (M1 i c f) e where-  getError' (M1 m1) = getError' m1--instance GetError l e => GetError (l :+: r) e where-  getError' (L1 l) = getError' l-  getError' (R1 _) = Nothing--instance GetError (K1 i e) e where-  getError' (K1 e) = Just e--getError :: (Generic (errorLike e a), GetError (Rep (errorLike e a)) e) => errorLike e a -> Maybe e-getError = getError' . from-
− tests/examples/ghc710/Guards.hs 
@@ -1,6 +0,0 @@---f x | x > 0, x /= 10 = 1 / x-    | x == 0 = undefined-  where-    y = 4
− tests/examples/ghc710/Hang.hs 
@@ -1,1 +0,0 @@-(~>) = forall
− tests/examples/ghc710/HangingRecord.hs 
@@ -1,5 +0,0 @@--data Foo = Foo-  { r1 :: Int-  , r2 :: Int-  }
− tests/examples/ghc710/HashQQ.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}--module Web.Maid.ApacheMimeTypes where---import qualified Data.Text as T-import Air.TH----apache_mime_types :: T.Text-apache_mime_types = [here|--# This file maps Internet media types to unique file extension(s).-# Although created for httpd, this file is used by many software systems-# and has been placed in the public domain for unlimited redisribution.-#-# The table below contains both registered and (common) unregistered types.-# A type that has no unique extension can be ignored -- they are listed-# here to guide configurations toward known types and to make it easier to-# identify "new" types.  File extensions are also commonly used to indicate-# content languages and encodings, so choose them carefully.-#-# Internet media types should be registered as described in RFC 4288.-# The registry is at .-#-# MIME type (lowercased)      Extensions-# ============================================  ==========-# application/1d-interleaved-parityfec-# application/3gpp-ims+xml-# application/activemessage-application/andrew-inset      ez |]---testComplex    = assertBool "" ([istr|-        ok-#{Foo 4 "Great!" : [Foo 3 "Scott!"]}-        then-|] == ("\n" ++-    "        ok\n" ++-    "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++-    "        then\n"))-
− tests/examples/ghc710/HsDo.hs 
@@ -1,22 +0,0 @@-module HsDo where--import qualified Data.Map as Map--moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)-  where-    numbered_summaries = zip summaries [1..]--    node_map :: NodeMap SummaryNode-    node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)-                            | node@(s, _, _) <- nodes ]---graphFromEdgedVertices = undefined-nodes = undefined-lookup_node = undefined-type NodeMap a = Map.Map (Int,Int) (Int,Int,Int)-data SummaryNode = SummaryNode-moduleName = undefined-ms_mod = undefined-ms_hsc_src = undefined-
− tests/examples/ghc710/IfThenElse1.hs 
@@ -1,7 +0,0 @@--- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai-main = do-  cs <- if True-  then getLine-  else return "computer input"-  putStrLn cs-
− tests/examples/ghc710/IfThenElse2.hs 
@@ -1,5 +0,0 @@--- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai-main = if True-then print 12-else print 42-
− tests/examples/ghc710/IfThenElse3.hs 
@@ -1,6 +0,0 @@--- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai-main = do-  print 3-  if True then do-    print 5-    else print 7
− tests/examples/ghc710/ImplicitParams.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE ImplicitParams #-}---- From https://ocharles.org.uk/blog/posts/2014-12-11-implicit-params.html--import Data.Char---type LogFunction = String -> IO ()--type Present = String--queueNewChristmasPresents :: LogFunction -> [Present] -> IO ()-queueNewChristmasPresents logMessage presents = do-  mapM (logMessage . ("Queueing present for delivery: " ++)) presents-  return ()--queueNewChristmasPresents2 :: (?logMessage :: LogFunction) => [Present] -> IO ()-queueNewChristmasPresents2 presents = do-  mapM (?logMessage . ("Queueing present for delivery: " ++)) presents-  return ()---ex1 :: IO ()-ex1 =-  let ?logMessage = \t -> putStrLn ("[XMAS LOG]: " ++ t)-  in queueNewChristmasPresents2 ["Cuddly Lambda", "Gamma Christmas Pudding"]---ex2 :: IO ()-ex2 = do-  -- Specifies its own logger-  ex1--  -- We can locally define a new logging function-  let ?logMessage = \t -> putStrLn (zipWith (\i c -> if even i-                                                     then c-                                                     else toUpper c)-                                           [0..]-                                           t)-  queueNewChristmasPresents2 ["Category Theory Books"]-
− tests/examples/ghc710/ImplicitSemi.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE ImplicitParams #-}--explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b-explicit x ab be = x where ?above = ab; ?below = be
− tests/examples/ghc710/ImplicitTypeSyn.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnicodeSyntax #-}--type MPI = ?mpi_secret :: MPISecret
− tests/examples/ghc710/Imports.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ExplicitNamespaces #-}-module Imports( f, type (+), pattern Single ) where--import GHC.TypeLits--pattern Single x = [x]--f = undefined
− tests/examples/ghc710/ImportsSemi.hs 
@@ -1,6 +0,0 @@-module ImportsSemi where-{-; ; ; ; ; ;-import Data.List-;;;-}
− tests/examples/ghc710/IndentedDo.hs 
@@ -1,12 +0,0 @@----foo =-  parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do-      \res -> case res of-        Right ([ PPM { ppmHeader = h1 }-               , PPM { ppmHeader = h2 }], rest) -> do h1 `shouldBe` PPMHeader P6 220 92-                                                      h2 `shouldBe` PPMHeader P6 220 92-                                                      rest `shouldBe` Nothing-        Right r                                    -> assertFailure $ "parsed unexpected: " ++ show r-        Left e                                     -> assertFailure $ "did not parse: " ++ e
− tests/examples/ghc710/Infix.hs 
@@ -1,8 +0,0 @@--infix  3 &&&--(&&&) :: (Eq a) => [a] -> [a] -> [a]-(&&& ) [] [] =  []-xs  &&&   [] =  xs-(  &&&) [] ys =  ys-
− tests/examples/ghc710/InfixPatternSynonyms.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}---- | The pattern synonym equivalent of 'destIff'.-pattern l :<=> r <- Comb (Comb (Const "=" (TyBool :-> TyBool :-> TyBool)) l) r---- | Destructor for boolean conjunctions.-destConj :: HOLTerm -> Maybe (HOLTerm, HOLTerm)-destConj = destBinary "/\\"---- | The pattern synonym equivalent of 'destConj'.-pattern l :/\ r <- Binary "/\\" l r---- | Destructor for boolean implications.-destImp :: HOLTerm -> Maybe (HOLTerm, HOLTerm)-destImp = destBinary "==>"---- | The pattern synonym equivalent of 'destImp'.-pattern l :==> r <- Binary "==>" l r
− tests/examples/ghc710/InlineSemi.hs 
@@ -1,1 +0,0 @@-{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a         ; (|.) a i   = peekElemOff a i
− tests/examples/ghc710/Internals.hs 
@@ -1,427 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,-             CPP #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-#endif--{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Array.IO.Internal--- Copyright   :  (c) The University of Glasgow 2001-2012--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Array.Base)------ Mutable boxed and unboxed arrays in the IO monad.-----------------------------------------------------------------------------------module Data.Array.IO.Internals (-    IOArray(..),         -- instance of: Eq, Typeable-    IOUArray(..),        -- instance of: Eq, Typeable-    castIOUArray,        -- :: IOUArray ix a -> IO (IOUArray ix b)-    unsafeThawIOUArray,-  ) where--import Data.Int-import Data.Word-import Data.Typeable--import Control.Monad.ST         ( RealWorld, stToIO )-import Foreign.Ptr              ( Ptr, FunPtr )-import Foreign.StablePtr        ( StablePtr )--#if __GLASGOW_HASKELL__ < 711-import Data.Ix-#endif-import Data.Array.Base--import GHC.IOArray (IOArray(..))---------------------------------------------------------------------------------- Flat unboxed mutable arrays (IO monad)---- | Mutable, unboxed, strict arrays in the 'IO' monad.  The type--- arguments are as follows:------  * @i@: the index type of the array (should be an instance of 'Ix')------  * @e@: the element type of the array.  Only certain element types---    are supported: see "Data.Array.MArray" for a list of instances.----newtype IOUArray i e = IOUArray (STUArray RealWorld i e)-                       deriving Typeable-#if __GLASGOW_HASKELL__ >= 708--- Both parameters have class-based invariants. See also #9220.-type role IOUArray nominal nominal-#endif--instance Eq (IOUArray i e) where-    IOUArray s1 == IOUArray s2  =  s1 == s2--instance MArray IOUArray Bool IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Char IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Int IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Word IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray (Ptr a) IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray (FunPtr a) IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Float IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Double IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray (StablePtr a) IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Int8 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Int16 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Int32 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Int64 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Word8 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Word16 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Word32 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)--instance MArray IOUArray Word64 IO where-    {-# INLINE getBounds #-}-    getBounds (IOUArray arr) = stToIO $ getBounds arr-    {-# INLINE getNumElements #-}-    getNumElements (IOUArray arr) = stToIO $ getNumElements arr-    {-# INLINE newArray #-}-    newArray lu initialValue = stToIO $ do-        marr <- newArray lu initialValue; return (IOUArray marr)-    {-# INLINE unsafeNewArray_ #-}-    unsafeNewArray_ lu = stToIO $ do-        marr <- unsafeNewArray_ lu; return (IOUArray marr)-    {-# INLINE newArray_ #-}-    newArray_ = unsafeNewArray_-    {-# INLINE unsafeRead #-}-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)-    {-# INLINE unsafeWrite #-}-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)---- | Casts an 'IOUArray' with one element type into one with a--- different element type.  All the elements of the resulting array--- are undefined (unless you know what you\'re doing...).-castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)-castIOUArray (IOUArray marr) = stToIO $ do-    marr' <- castSTUArray marr-    return (IOUArray marr')--{-# INLINE unsafeThawIOUArray #-}-#if __GLASGOW_HASKELL__ >= 711-unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e)-#else-unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)-#endif-unsafeThawIOUArray arr = stToIO $ do-    marr <- unsafeThawSTUArray arr-    return (IOUArray marr)--{-# RULES-"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray-    #-}--#if __GLASGOW_HASKELL__ >= 711-thawIOUArray :: UArray ix e -> IO (IOUArray ix e)-#else-thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)-#endif-thawIOUArray arr = stToIO $ do-    marr <- thawSTUArray arr-    return (IOUArray marr)--{-# RULES-"thaw/IOUArray" thaw = thawIOUArray-    #-}--{-# INLINE unsafeFreezeIOUArray #-}-#if __GLASGOW_HASKELL__ >= 711-unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e)-#else-unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)-#endif-unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)--{-# RULES-"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray-    #-}--#if __GLASGOW_HASKELL__ >= 711-freezeIOUArray :: IOUArray ix e -> IO (UArray ix e)-#else-freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)-#endif-freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)--{-# RULES-"freeze/IOUArray" freeze = freezeIOUArray-    #-}
− tests/examples/ghc710/Jon.hs 
@@ -1,4 +0,0 @@-{- ___ -}import Data.Char;main=putStr$do{c<-"/1 AA A A;9+ )11929 )1191A 2C9A ";e-{-  |  -}    .(`divMod`8).(+(-32)).ord$c};e(0,0)="\n";e(m,n)=m?"  "++n?"_/"-{-  |  -}n?x=do{[1..n];x}                                    --- obfuscated-{-\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -}
− tests/examples/ghc710/LambdaCase.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE LambdaCase #-}--foo = f >>= \case-        Just h -> loadTestDB (h ++ "/.testdb")-        Nothing -> fmap S.Right initTestDB--{-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -}-isAlarmSetSTM :: AlarmClock -> STM Bool-isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting-  >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True }
− tests/examples/ghc710/LayoutLet.hs 
@@ -1,7 +0,0 @@--foo x =-  let-    a = 1-    b = 2-  in x + a + b-
− tests/examples/ghc710/LayoutWhere.hs 
@@ -1,6 +0,0 @@--foo x = r-  where-    a = 3-    b = 4-    r = a + a + b
− tests/examples/ghc710/LetExpr.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# Language DeriveFoldable #-}-{-# LANGUAGE Safe #-}-{-# options_ghc -w #-}---- | A simple let expression, to ensure the layout is detected--- With some haddock in the top-{- And a normal-   multiline comment too -}-  module {- brah -}  LetExpr        ( foo -- foo does ..-                                    , bar -- bar does ..-                                    , Baz () -- baz does ..-                                 , Ba   ( ..),Ca(Cc,Cd)   ,-                                     bbb ,  aaa-                                  , module  Data.List-                                    , pattern  Bar-                                    )-    where--import Data.List--- A comment in the middle-import {-# SOURCE #-} BootImport ( Foo(..) )-import {-# SoURCE  #-} safe   qualified  BootImport   as    BI-import qualified Data.Map as {- blah -}  Foo.Map--import Control.Monad  (   )-import Data.Word (Word8)-import Data.Tree hiding  (  drawTree   )--import qualified Data.Maybe as M hiding    ( maybe  , isJust  )----- comment-foo = let x = 1-          y = 2-      in x + y--bar = 3-bbb x- | x == 1 = ()- | otherwise = ()---aaa [ ] _   = 0-aaa x  _unk = 1--aba () = 0--x `ccc` 1 = x + 1-x `ccc` y = x + y--x !@# y = x + y--data Baz = Baz1 | Baz2--data Ba = Ba | Bb--data Ca = Cc | Cd--pattern Foo a <- RealFoo a-pattern Bar a <- RealBar a--data Thing = RealFoo Thing | RealBar Int
− tests/examples/ghc710/LetExpr2.hs 
@@ -1,4 +0,0 @@-l z =-  let-    ll = 34-  in ll + z
− tests/examples/ghc710/LetExprSemi.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# Language DeriveFoldable #-}-{-# LANGUAGE Safe #-}-{-# options_ghc -w #-}---- | A simple let expression, to ensure the layout is detected--- With some haddock in the top-{- And a normal-   multiline comment too -}-  module {- brah -}  LetExprSemi    ( foo -- foo does ..-                                    , bar -- bar does ..-                                    , Baz () -- baz does ..-                                 , Ba   ( ..),Ca(Cc,Cd)   ,-                                     bbb ,  aaa-                                  , module  Data.List-                                    , pattern  Bar-                                    )-    where-{-import Data.List--- A comment in the middle-; import {-# SOURCE #-} BootImport ( Foo(..) ) ;-import {-# SOURCE  #-} safe   qualified  BootImport   as    BI-;;; import qualified Data.Map as {- blah -}  Foo.Map;--import Control.Monad  (   )  ;-import Data.Word (Word8);-import Data.Tree hiding  (  drawTree   ) ;--  ; import qualified Data.Maybe as M hiding    ( maybe  , isJust  )-;---- comment-foo = let x = 1-          y = 2-      in x + y-;-bar = 3;-bbb x- | x == 1 = ()- | otherwise = ()--;-aaa [] _    = 0;-aaa x  _unk = 1-;-x `ccc` 1 = x + 1;-x `ccc` y = x + y-;-x !@# y = x + y-;-data Baz = Baz1 | Baz2-;-data Ba = Ba | Bb-;-data Ca = Cc | Cd-;-pattern Foo a <- RealFoo a ;-pattern Bar a <- RealBar a-;-data Thing = RealFoo Thing | RealBar Int-}--
− tests/examples/ghc710/LetStmt.hs 
@@ -1,9 +0,0 @@--- A simple let statement, to ensure the layout is detected--module Layout.LetStmt where--foo = do-{- ffo -}let x = 1-             y = 2 -- baz-         x+y-
− tests/examples/ghc710/LiftedInfixConstructor.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE DataKinds, TemplateHaskell #-}--applicate :: Bool -> [Stmt] -> ExpQ-applicate rawPatterns stmt = do-    return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g)-                    (VarE 'pure `AppE` f')-                    es--tuple :: Int -> ExpQ-tuple n = do-    ns <- replicateM n (newName "x")-    lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns)
− tests/examples/ghc710/LinePragma.hs 
@@ -1,36 +0,0 @@-module UHC.Light.Compiler.Core.SysF.AsTy-( Ty-, ty2TySysfWithEnv, ty2TyC-, ty2TyCforFFI )-where-import UHC.Light.Compiler.Base.Common-import UHC.Light.Compiler.Opts.Base-import UHC.Light.Compiler.Error-import qualified UHC.Light.Compiler.Core as C-import qualified UHC.Light.Compiler.Ty as T-import UHC.Light.Compiler.FinalEnv--{-# LINE 50 "src/ehc/Core/SysF/AsTy.chs" #-}--- | The type, represented by a term CExpr-type Ty             = C.SysfTy          -- base ty---- | Binding the bound-type TyBind         = C.SysfTyBind-type TyBound        = C.SysfTyBound---- | A sequence of parameters (for now just a single type)-type TySeq          = C.SysfTySeq---{-# LINE 67 "src/ehc/Core/SysF/AsTy.chs" #-}-ty2TySysfWithEnv :: ToSysfEnv -> T.Ty -> Ty-ty2TySysfWithEnv _   t =                                                     t---- | Construct a type for use by AbstractCore-ty2TyC :: EHCOpts -> ToSysfEnv -> T.Ty -> C.CTy-ty2TyC o env t = C.mkCTy o t (ty2TySysfWithEnv env t)--{-# LINE 93 "src/ehc/Core/SysF/AsTy.chs" #-}--- | Construct a type for use by AbstractCore, specifically for use by FFI-ty2TyCforFFI :: EHCOpts -> T.Ty -> C.CTy-ty2TyCforFFI o t = C.mkCTy o t                                t
− tests/examples/ghc710/ListComprehensions.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE ParallelListComp,-             TransformListComp,-             RecordWildCards #-}---             MonadComprehensions,---- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html--import GHC.Exts-import qualified Data.Map as M-import Data.Ord (comparing)-import Data.List (sortBy)---- Let’s look at a simple, normal list comprehension to start:--regularListComp :: [Int]-regularListComp = [ x + y * z-                  | x <- [0..10]-                  , y <- [10..20]-                  , z <- [20..30]-                  ]--parallelListComp :: [Int]-parallelListComp = [ x + y * z-                   | x <- [0..10]-                   | y <- [10..20]-                   | z <- [20..30]-                   ]---- fibs :: [Int]--- fibs = 0 : 1 : zipWith (+) fibs (tail fibs)--fibs :: [Int]-fibs = 0 : 1 : [ x + y-               | x <- fibs-               | y <- tail fibs-               ]--fiblikes :: [Int]-fiblikes = 0 : 1 : [ x + y + z-                   | x <- fibs-                   | y <- tail fibs-                   | z <- tail (tail fibs)-                   ]---- TransformListComp-data Character = Character-  { firstName :: String-  , lastName :: String-  , birthYear :: Int-  } deriving (Show, Eq)--friends :: [Character]-friends = [ Character "Phoebe" "Buffay" 1963-          , Character "Chandler" "Bing" 1969-          , Character "Rachel" "Green" 1969-          , Character "Joey" "Tribbiani" 1967-          , Character "Monica" "Geller" 1964-          , Character "Ross" "Geller" 1966-          ]--oldest :: Int -> [Character] -> [String]-oldest k tbl = [ firstName ++ " " ++ lastName-               | Character{..} <- tbl-               , then sortWith by birthYear-               , then take k-               ]--groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]]-groupByLargest f = sortBy (comparing (negate . length)) . groupWith f--bestBirthYears :: [Character] -> [(Int, [String])]-bestBirthYears tbl = [ (the birthYear, firstName)-                     | Character{..} <- tbl-                     , then group by birthYear using groupByLargest-                     ]--uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs-                                   , let d' = ppDir d-                                   , then group by Down (p,d') using groupWith ]--legendres :: [Poly Rational]-legendres = one : x :-    [ multPoly-        (poly LE [recip (n' + 1)])-        (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n)-                 (poly LE           [-n'] `multPoly` p_nm1)-        )-    | n     <- [1..], let n' = fromInteger n-    | p_n   <- tail legendres-    | p_nm1 <- legendres-    ]--fromGroups' :: (Ord k) => a -> [a] -> Maybe (W.Stack k) -> Groups k -> [a]-                    -> [(Bool,(a, W.Stack k))]-fromGroups' defl defls st gs sls =-    [ (isNew,fromMaybe2 (dl, single w) (l, M.lookup w gs))-        | l <- map Just sls ++ repeat Nothing, let isNew = isNothing l-        | dl <- defls ++ repeat defl-        | w <- W.integrate' $ W.filter (`notElem` unfocs) =<< st ]
− tests/examples/ghc710/LocalDecls2Expected.hs 
@@ -1,6 +0,0 @@-module LocalDecls2Expected where--foo a = bar a-  where-    nn :: Int-    nn = 2
− tests/examples/ghc710/MachineTypes.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module-    Control.Arrow.Machine.Types-where--import qualified Control.Category as Cat-import Data.Profunctor (Profunctor, dimap, rmap)-import Control.Arrow-import Control.Monad-import Control.Monad.Trans-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer hiding ((<>))-import Control.Monad.Identity-import Control.Applicative-import Data.Foldable as Fd-import Data.Traversable as Tv-import Data.Semigroup (Semigroup, (<>))-import Data.Maybe (fromMaybe, isNothing, isJust)-import qualified Control.Monad.Trans.Free as F-import qualified Control.Monad.Trans.Free.Church as F-import Control.Arrow.Machine.ArrowUtil-import GHC.Exts (build)----- | To get multiple outputs by one input, the `Phase` parameter is introduced.------ Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s.-data Phase = Feed | Sweep | Suspend deriving (Eq, Show)--instance-    Monoid Phase-  where-    mempty = Sweep--    mappend Feed _ = Feed-    mappend _ Feed = Feed-    mappend Suspend _ = Suspend-    mappend _ Suspend = Suspend-    mappend Sweep Sweep = Sweep---type ProcType a b c = ProcessA a b c---- | The stream transducer arrow.------ To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`,--- `arr`, functions declared in `Control.Arrow.Machine.Utils`,--- or arrow combinations of them.------ See an introduction at "Control.Arrow.Machine" documentation.-data ProcessA a b c = ProcessA {-    feed :: a b (c, ProcessA a b c),-    sweep :: a b (Maybe c, ProcessA a b c),-    suspend :: !(b -> c)-  }----- For internal use-class-    (Applicative f, Monad f) => ProcessHelper f-  where-    step :: ArrowApply a => ProcessA a b c -> a b (f c, ProcessA a b c)-    helperToMaybe :: f a -> Maybe a-    weakly :: a -> f a--    step' :: ArrowApply a => ProcessA a b c -> a (f b) (f c, ProcessA a b c)-    step' pa = proc hx ->-      do-        let mx = helperToMaybe hx-        maybe-            (arr $ const (suspend pa <$> hx, pa))-            (\x -> proc _ -> step pa -< x)-            mx-                -<< ()-
− tests/examples/ghc710/MagicHash.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE MagicHash #-}--module Data.Text.Internal.Builder.Functions-    (-      (<>)-    , i2d-    ) where--import Data.Monoid (mappend)-import Data.Text.Lazy.Builder (Builder)-import GHC.Base---- | Unsafe conversion for decimal digits.-{-# INLINE i2d #-}-i2d :: Int -> Char-i2d (I# i#) = C# (chr# (ord# '0'# +# i#))--main =-  print (F# (expFloat# 3.45#))---- | The normal 'mappend' function with right associativity instead of--- left.-(<>) :: Builder -> Builder -> Builder-(<>) = mappend-{-# INLINE (<>) #-}--infixr 4 <>--
− tests/examples/ghc710/MangledSemiLet.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE-    BangPatterns-  #-}---mtGamma a b =-  let !x_2 = x*x; !x_4 = x_2*x_2-      v3 = v*v*v-      dv = d * v3-  in 5
− tests/examples/ghc710/Minimal.hs 
@@ -1,37 +0,0 @@-class AwsType a where-    toText :: a -> b---    {-# MINIMAL toText #-}--class Minimal a where-  toText :: a -> b-  {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-}--class Minimal a where-  toText :: a -> b-  {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}--class Minimal a where-  toText :: a -> b-  {-# MINIMAL (toSample | toSamples) #-}--class ManyOps a where-    aOp :: a -> a -> Bool-    bOp :: a -> a -> Bool-    cOp :: a -> a -> Bool-    dOp :: a -> a -> Bool-    eOp :: a -> a -> Bool-    fOp :: a -> a -> Bool-    {-# MINIMAL  ( aOp)-               | ( bOp   , cOp)-               | ((dOp  |  eOp) , fOp)-      #-}--class Foo a where-    bar :: a -> a -> Bool-    foo :: a -> a -> Bool-    baq :: a -> a -> Bool-    baz :: a -> a -> Bool-    quux :: a -> a -> Bool-    {-# MINIMAL bar, (foo, baq | foo, quux) #-}
− tests/examples/ghc710/Mixed.hs 
@@ -1,50 +0,0 @@--import Data.List  ()-import Data.List  hiding ()--infixl 1 `f`--- infixr 2 `\\\`-infix  3 :==>-infix  4 `MkFoo`--data Foo = MkFoo Int | Float :==> Double--x `f` y = x--(\\\) :: (Eq a) => [a] -> [a] -> [a]-(\\\) xs ys =  xs--g x = x + if True then 1 else 2-h x = x + 1::Int--{-# SPECIALISe j :: Int -> Int-                  , Integer -> Integer #-}-j n = n + 1--test = let k x y = x+y in 1 `k` 2 `k` 3--data Rec = (:<-:) { a :: Int, b :: Float }--ng1 x y = negate y--instance (Num a, Num b) => Num (a,b)-  where-   {-# Specialise instance Num (Int,Int) #-}-   negate (a,b) = (ng 'c' a, ng1 'c' b)   where  ng x y = negate y----class Foo1 a where--class Foz a--x = 2 where-y = 3--instance Foo1 Int where--ff = ff where g = g where-type T = Int---
− tests/examples/ghc710/ModuleOnly.hs 
@@ -1,1 +0,0 @@-module ModuleOnly where
− tests/examples/ghc710/MonadComprehensions.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE ParallelListComp,-             TransformListComp,-             RecordWildCards #-}-{-# LANGUAGE MonadComprehensions #-}---- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html--import GHC.Exts-import qualified Data.Map as M-import Data.Ord (comparing)-import Data.List (sortBy)----- Monad Comprehensions--sqrts :: M.Map Int Int-sqrts = M.fromList $ [ (x, sx)-                     | x  <- map (^2) [1..100]-                     | sx <- [1..100]-                     ]--sumIntSqrts :: Int -> Int -> Maybe Int-sumIntSqrts a b = [ x + y-                  | x <- M.lookup a sqrts-                  , y <- M.lookup b sqrts-                  ]--greet :: IO String-greet = [ name-        | name <- getLine-        , _ <- putStrLn $ unwords ["Hello, ", name, "!"]-        ]-
− tests/examples/ghc710/Move1.hs 
@@ -1,53 +0,0 @@-module Move1 where--data Located a = L Int a-type Name = String-hsBinds = undefined-divideDecls = undefined-definingDeclsNames = undefined-nub = undefined-definedPNs :: a -> [b]-definedPNs = undefined-logm = undefined-showGhc = undefined-pnsNeedRenaming = undefined-concatMap1 = undefined---- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath---                 -> Located Name---                 -> RefactGhc [a]-liftToTopLevel' :: Int -> Located Name -> IO [a]-liftToTopLevel' modName pn@(L _ n) = do-  liftToMod-  return []-    where-          {-step1: divide the module's top level declaration list into three parts:-            'parent' is the top level declaration containing the lifted declaration,-            'before' and `after` are those declarations before and after 'parent'.-            step2: get the declarations to be lifted from parent, bind it to liftedDecls -            step3: remove the lifted declarations from parent and extra arguments may be introduce.-            step4. test whether there are any names need to be renamed.-          -}-       liftToMod :: IO ()-       liftToMod = do-                      -- renamed <- getRefactRenamed-                      let renamed = undefined-                      let declsr = hsBinds renamed-                      let (before,parent,after) = divideDecls declsr pn-                      -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++-                      {- ++AZ++ : hsBinds does not return class or instance definitions-                      when (isClassDecl $ ghead "liftToMod" parent)-                            $ error "Sorry, the refactorer cannot lift a definition from a class declaration!"-                      when (isInstDecl $ ghead "liftToMod" parent)-                            $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"-                      -}-                      let liftedDecls = definingDeclsNames [n] parent True True-                          declaredPns = nub $ concatMap1 definedPNs liftedDecls--                      -- TODO: what about declarations between this-                      -- one and the top level that are used in this one?--                      logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))-                      -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns-                      -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns-                      return ()
− tests/examples/ghc710/MultiImplicitParams.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE ImplicitParams #-}--foo = do-  ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos-            ?buttonChanges = _button-        in sink-  return baz
− tests/examples/ghc710/MultiLineCommentWithPragmas.hs 
@@ -1,18 +0,0 @@--{---- this is ugly too: can't use Data.Complex because the qd bindings do--- not implement some low-level functions properly, leading to obscure--- crashes inside various Data.Complex functions...-data Complex c = {-# UNPACK #-} !c :+ {-# UNPACK #-} !c deriving (Read, Show, Eq)---- complex number arithmetic, with extra strictness and cost-centres-instance Num c => Num (Complex c) where-  (!(a :+ b)) + (!(c :+ d)) = {-# SCC "C+" #-} ((a + c) :+ (b + d))-  (!(a :+ b)) - (!(c :+ d)) = {-# SCC "C-" #-} ((a - c) :+ (b - d))-  (!(a :+ b)) * (!(c :+ d)) = {-# SCC "C*" #-} ((a * c - b * d) :+ (a * d + b * c))-  negate !(a :+ b) = (-a) :+ (-b)-  abs x = error $ "Complex.abs: " ++ show x-  signum x = error $ "Complex.signum: " ++ show x-  fromInteger !x = fromInteger x :+ 0--}-
− tests/examples/ghc710/MultiParamTypeClasses.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- From https://ocharles.org.uk/blog/posts/2014-12-13-multi-param-type-classes.html--import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ReaderT)-import Data.Foldable (forM_)-import Data.IORef--class Store store m where- new :: a -> m (store a)- get :: store a -> m a- put :: store a -> a -> m ()--type Present = String-storePresents :: (Store store m, Monad m) => [Present] -> m (store [Present])-storePresents xs = do-  store <- new []-  forM_ xs $ \x -> do-    old <- get store-    put store (x : old)-  return store--instance Store IORef IO where-  new = newIORef-  get = readIORef-  put ioref a = modifyIORef ioref (const a)---- ex ps = do---   store <- storePresents ps---   get (store :: IORef [Present])
− tests/examples/ghc710/MultiWayIf.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE MultiWayIf #-}---instance Animatable Double where-    interpolate ease from to t =-        if | t <= 0 -> from-           | t >= 1 -> to-           | otherwise -> from + easeDouble ease t * (to - from)-    animAdd = (+)-    animSub = (-)-    animZero = 0
− tests/examples/ghc710/NestedDoLambda.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE Arrows #-}--operator = describe "Operators on ProcessA"$-  do-    describe "feedback" $-      do-        it "acts like local variable with hold." $-          do-            let-                pa = proc evx ->-                  do-                    (\evy -> hold 10 -< evy)-                      `feedback` \y ->-                      do-                        returnA -< ((+y) <$> evx, (y+1) <$ evx)-            run pa [1, 2, 3] `shouldBe` [11, 13, 15]--        it "correctly handles stream end." $-          do-            let-                pa = proc x ->-                    (\asx -> returnA -< asx)-                  `feedback`-                    (\asy -> returnA -< (asy::Event Int, x))-                comp = mkProc (PgPush PgStop) >>> pa-            stateProc comp [0, 0] `shouldBe` ([], [0])--        it "correctly handles stream end.(2)" $-          do-            pendingWith "now many utilities behave incorrectly at the end of stream."-
− tests/examples/ghc710/NestedLambda.hs 
@@ -1,8 +0,0 @@----getPath :: [String] -> Filter-getPath names elms =-  let follow = foldl (\f n -> \els-> subElems n $ f els) id' names :: Filter-      id' = id :: Filter-  in  follow elms
− tests/examples/ghc710/NullaryTypeClasses.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE NullaryTypeClasses #-}---- From https://ocharles.org.uk/blog/posts/2014-12-10-nullary-type-classes.html--class Logger where-  logMessage :: String -> IO ()--type Present = String-queueNewChristmasPresents :: Logger => [Present] -> IO ()-queueNewChristmasPresents presents = do-  mapM (logMessage . ("Queueing present for delivery: " ++)) presents-  return ()--instance Logger where-  logMessage t = putStrLn ("[XMAS LOG]: " ++ t)-
− tests/examples/ghc710/Obscure.hs 
@@ -1,29 +0,0 @@-type A = Integer-data B = B { u :: !B, j :: B, r :: !A, i :: [A] } | Y-c=head-k=tail-b x y=x(y)y-n=map(snd)h-m=2:3:5:[7]-f=s(flip(a))t-s x y z=x(y(z))-e=filter(v)[2..221]-z=s(s(s((s)b)(s(s)flip)))s-main=mapM_(print)(m++map(fst)h)-v=s(flip(all)m)(s((.)(/=0))mod)-t=(s(s(s(b))flip)((s)s))(s(B(Y)Y)c)k-g=z(:)(z(,)c(b(s((s)map(*))c)))(s(g)k)-h=c(q):c(k(q)):d(p(t((c)n))(k(n)))(k((k)q))-q=g(scanl1(+)(11:cycle(zipWith(-)((k)e)e)))-a x Y = x-a Y x = x-a x y = case compare((r)x)(r(y)) of-  GT -> a(y)x-  _  -> B(a((j)x)y)(u(x))((r)x)(i(x))-p x y = case compare((r)x)(c(c(y))) of-  GT -> p(f((c)y)x)(k(y))-  _  -> r(x):p(f((i)x)(a(u(x))(j(x))))y-d x y = case compare((c)x)(fst(c(y))) of-  GT -> c(y):(d)x((k)y)-  LT -> d(k(x))y-  EQ -> d((k)x)(k(y))
− tests/examples/ghc710/OptSig.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--errors= do-  let ls :: [[String ]]= runR  readp $ pack "[" `append` (B.tail log) `append` pack "]"-  return ()---- This can be seen as the definition of accumFilter-accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)-accumFilter2 f c_init =-    switch (never &&& attach c_init) afAux-    where-    afAux (c, a) =-            case f c a of-            (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux-            (c', Just b)  -> switch (now b &&& (notYet>>>attach c')) afAux--    attach :: b -> SF (Event a) (Event (b, a))-        attach c = arr (fmap (\a -> (c, a)))
− tests/examples/ghc710/OptSig2.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--errors= do-  let ls :: Int = undefined-  return ()
− tests/examples/ghc710/OveridingPrimitives.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE TypeOperators          #-}--(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts)-(~#) = cascadeW-infixr 0 ~#-
− tests/examples/ghc710/OverloadedStrings.hs 
@@ -1,15 +0,0 @@-{-# Language OverloadedStrings #-}--- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html--import Data.String--n :: Num a => a-n = 43--f  :: Fractional a => a-f = 03.1420---- foo :: Text-foo :: Data.String.IsString a => a-foo = "hello\n there"-
− tests/examples/ghc710/PArr.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module PArr where--blah xs ys = [ (x, y) | x <- xs | y <- ys ]---- bar = [: 1, 2 .. 3 :]----- entry point for desugaring a parallel array comprehension---- parr = [:e | qss:] = <<[:e | qss:]>> () [:():]--{--ary = let arr1 = toP [1..10]-          arr2 = toP [1..10]-          f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :]-          in f !: 1--}---foo = 'a'-
− tests/examples/ghc710/ParensAroundContext.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-module ParensAroundContext where--f :: ((Eq a, _)) => a -> a -> Bool-f x y = x == y
− tests/examples/ghc710/PatBind.hs 
@@ -1,34 +0,0 @@-module   Layout.PatBind where--a,b :: Int-a = 1-b = 2--c :: Maybe (a -> b)-c = Nothing--f :: (Num a1, Num a) => a -> a1 -> ( a, a1 )-f x y = ( x+1, y-1 )---- Chris done comment attachment problem-foo = x-  where -- do stuff-        doStuff = do stuff-x = 1-stuff = 4-- -- Pattern bind-tup :: (Int, Int)-h :: Int-t :: Int-tup@(h,t) = head $ zip [1..10] [3..ff]-  where-    ff :: Int-    ff = 15--blah = do {- ; print "a"- ; print "b"- }--
− tests/examples/ghc710/PatSigBind.hs 
@@ -1,15 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--runCoreRunIO-  :: EHCOpts        -- ^ options, e.g. for turning on tracing (if supported by runner)-     -> Mod         -- ^ the module to run-     -> IO (Either Err RVal)-runCoreRunIO opts mod = do-    catch-      (runCoreRun opts [] mod $ cmodRun opts mod)-      (\(e :: SomeException) -> hFlush stdout >> (return $ Left $ strMsg $ "runCoreRunIO: " ++ show e))---foo = do-  (a :: Int) <- baz-  return grue
− tests/examples/ghc710/PatSynBind.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}---- From https://ocharles.org.uk/blog/posts/2014-12-03-pattern-synonyms.html--import Foreign.C--{---data BlendMode = NoBlending -- | AlphaBlending | AdditiveBlending | ColourModulatedBlending--toBlendMode :: BlendMode -> CInt-toBlendMode NoBlending = 0 -- #{const SDL_BLENDMODE_NONE}--- toBlendMode AlphaBlending = #{const SDL_BLENDMODE_BLEND}--fromBlendMode :: CInt -> Maybe BlendMode-fromBlendMode 0 = Just NoBlending---}--{---pattern AlphaBlending = (1) :: CInt -- #{const SDL_BLENDMODE_BLEND} :: CInt--setUpBlendMode :: CInt -> IO ()-setUpBlendMode AlphaBlending = do-  putStrLn "Enabling Alpha Blending"-  activateAlphaBlendingForAllTextures-  activateRenderAlphaBlending---}--newtype BlendMode = MkBlendMode { unBlendMode :: CInt }--pattern NoBlending = MkBlendMode 0 -- #{const SDL_BLENDMODE_NONE}-pattern AlphaBlending = MkBlendMode 1 -- #{const SDL_BLENDMODE_BLEND}--setUpBlendMode :: BlendMode -> IO ()-setUpBlendMode AlphaBlending = do-  putStrLn "Enabling Alpha Blending"-  activateAlphaBlendingForAllTextures-  activateRenderAlphaBlending--data Renderer--setRenderAlphaBlending :: Renderer -> IO ()-setRenderAlphaBlending r =-  sdlSetRenderDrawBlendMode r (unBlendMode AlphaBlending)--activateAlphaBlendingForAllTextures = return ()-activateRenderAlphaBlending = return ()--sdlSetRenderDrawBlendMode _ _ = return ()---- And from https://www.fpcomplete.com/user/icelandj/Pattern%20synonyms--data Date = Date { month :: Int, day :: Int } deriving Show---- Months-pattern January  day = Date { month = 1,  day = day }-pattern February day = Date { month = 2,  day = day }-pattern March    day = Date { month = 3,  day = day }--- elided-pattern December day = Date { month = 12, day = day }---- Holidays-pattern Christmas    = Date { month = 12, day = 25  }--describe :: Date -> String-describe (January 1)  = "First day of year"-describe (February n) = show n ++ "th of February"-describe Christmas    = "Presents!"-describe _            = "meh"--pattern Christmas2 = December 25--pattern BeforeChristmas <- December (compare 25 -> GT)-pattern Christmas3      <- December (compare 25 -> EQ)-pattern AfterChristmas  <- December (compare 25 -> LT)--react :: Date -> String-react BeforeChristmas = "Waiting :("-react Christmas       = "Presents!"-react AfterChristmas  = "Have to wait a whole year :("-react _               = "It's not even December..."--isItNow :: Int -> (Ordering, Int)-isItNow day = (compare 25 day, day)--pattern BeforeChristmas4 day <- December (isItNow -> (GT, day))-pattern Christmas4           <- December (isItNow -> (EQ, _))-pattern AfterChristmas4  day <- December (isItNow -> (LT, day))--days'tilChristmas :: Date -> Int-days'tilChristmas (BeforeChristmas4 n) = 25 - n-days'tilChristmas Christmas4           = 0-days'tilChristmas (AfterChristmas4 n)  = 365 + 25 - n
− tests/examples/ghc710/PatternGuards.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE PatternGuards #-}--match n-      | Just 5 <- Just n-      , Just 6 <- Nothing-      , Just 7 <- Just 9-      = Just 8
− tests/examples/ghc710/ProcNotation.hs 
@@ -1,12 +0,0 @@-{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts,-  TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-}--valForm initVal vtor label = withInput $-    proc ((),nm,fi) -> do-      s_curr <- keepState initVal -< fi-      valid <- vtor -< s_curr-      case valid of-         Left err -> returnA -< (textField label (Just err) s_curr nm,-                                                   Nothing)-         Right x -> returnA -< (textField label Nothing s_curr nm,-                                Just x)
− tests/examples/ghc710/Process.hs 
@@ -1,717 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module Synthesizer.MIDI.CausalIO.Process (-   Events,--   slice,-   controllerLinear,-   controllerExponential,-   pitchBend,-   channelPressure,-   bendWheelPressure,-   constant,--   Instrument,-   Bank,-   GateChunk,-   noteEvents,-   embedPrograms,-   applyInstrument,-   applyModulatedInstrument,-   flattenControlSchedule,-   applyModulation,-   arrangeStorable,-   sequenceCore,-   sequenceModulated,-   sequenceModulatedMultiProgram,-   sequenceModulatedMultiProgramVelocityPitch,-   sequenceStorable,--   -- auxiliary function-   initWith,-   mapMaybe,-   ) where--import qualified Synthesizer.CausalIO.Gate as Gate-import qualified Synthesizer.CausalIO.Process as PIO--import qualified Synthesizer.MIDI.Value.BendModulation as BM-import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP-import qualified Synthesizer.MIDI.Value as MV--import qualified Synthesizer.MIDI.EventList as MIDIEv-import Synthesizer.MIDI.EventList (StrictTime, )--import qualified Synthesizer.PiecewiseConstant.Signal as PC-import qualified Synthesizer.Storable.Cut as CutSt-import qualified Synthesizer.Generic.Cut as CutG-import qualified Synthesizer.Zip as Zip--import qualified Sound.MIDI.Message.Class.Check as Check-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import Control.DeepSeq (rnf, )--import qualified Data.EventList.Relative.TimeBody  as EventList-import qualified Data.EventList.Relative.BodyTime  as EventListBT-import qualified Data.EventList.Relative.TimeTime  as EventListTT-import qualified Data.EventList.Relative.TimeMixed as EventListTM-import qualified Data.EventList.Relative.MixedTime as EventListMT-import qualified Data.EventList.Absolute.TimeBody  as AbsEventList--import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Class as NonNeg--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing       as RealRing-import qualified Algebra.Field          as Field-import qualified Algebra.Additive       as Additive-import qualified Algebra.ToInteger      as ToInteger--import qualified Data.StorableVector as SV-import qualified Data.StorableVector.ST.Strict as SVST-import Foreign.Storable (Storable, )--import qualified Control.Monad.Trans.Writer as MW-import qualified Control.Monad.Trans.State as MS-import qualified Control.Monad.Trans.Class as MT-import Control.Monad.IO.Class (liftIO, )--import qualified Data.Traversable as Trav-import Data.Traversable (Traversable, )-import Data.Foldable (traverse_, )--import Control.Arrow (Arrow, arr, (^<<), (<<^), )-import Control.Category ((.), )--import qualified Data.Map as Map--import qualified Data.List.HT as ListHT-import qualified Data.Maybe as Maybe-import Data.Monoid (Monoid, mempty, mappend, )-import Data.Maybe (maybeToList, )-import Data.Tuple.HT (mapFst, mapPair, )--import NumericPrelude.Numeric-import NumericPrelude.Base hiding ((.), sequence, )-import Prelude ()---type Events event = EventListTT.T StrictTime [event]---initWith ::-   (y -> c) ->-   c ->-   PIO.T-      (Events y)-      (EventListBT.T PC.ShortStrictTime c)-initWith f initial =-   PIO.traverse initial $-      \evs0 -> do-         y0 <- MS.get-         fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $-            Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0--slice ::-   (Check.C event) =>-   (event -> Maybe Int) ->-   (Int -> y) -> y ->-   PIO.T-      (Events event)-      (EventListBT.T PC.ShortStrictTime y)-slice select f initial =-   initWith f initial . mapMaybe select----mapMaybe ::-   (Arrow arrow, Functor f) =>-   (a -> Maybe b) ->-   arrow (f [a]) (f [b])-mapMaybe f =-   arr $ fmap $ Maybe.mapMaybe f--catMaybes ::-   (Arrow arrow, Functor f) =>-   arrow (f [Maybe a]) (f [a])-catMaybes =-   arr $ fmap Maybe.catMaybes--traverse ::-   (Traversable f) =>-   s -> (a -> MS.State s b) ->-   PIO.T (f [a]) (f [b])-traverse initial f =-   PIO.traverse initial (Trav.traverse (Trav.traverse f))---controllerLinear ::-   (Check.C event, Field.C y) =>-   MIDIEv.Channel ->-   MIDIEv.Controller ->-   (y,y) -> y ->-   PIO.T-      (Events event)-      (EventListBT.T PC.ShortStrictTime y)-controllerLinear chan ctrl bnd initial =-   slice (Check.controller chan ctrl)-      (MV.controllerLinear bnd) initial--controllerExponential ::-   (Check.C event, Trans.C y) =>-   MIDIEv.Channel ->-   MIDIEv.Controller ->-   (y,y) -> y ->-   PIO.T-      (Events event)-      (EventListBT.T PC.ShortStrictTime y)-controllerExponential chan ctrl bnd initial =-   slice (Check.controller chan ctrl)-      (MV.controllerExponential bnd) initial--pitchBend ::-   (Check.C event, Trans.C y) =>-   MIDIEv.Channel ->-   y -> y ->-   PIO.T-      (Events event)-      (EventListBT.T PC.ShortStrictTime y)-pitchBend chan range center =-   slice (Check.pitchBend chan)-      (MV.pitchBend range center) center--channelPressure ::-   (Check.C event, Trans.C y) =>-   MIDIEv.Channel ->-   y -> y ->-   PIO.T-      (Events event)-      (EventListBT.T PC.ShortStrictTime y)-channelPressure chan maxVal initial =-   slice (Check.channelPressure chan)-      (MV.controllerLinear (zero,maxVal)) initial--bendWheelPressure ::-   (Check.C event, RealRing.C y, Trans.C y) =>-   MIDIEv.Channel ->-   Int -> y -> y ->-   PIO.T-      (Events event)-      (EventListBT.T PC.ShortStrictTime (BM.T y))-bendWheelPressure chan-      pitchRange wheelDepth pressDepth =-   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth-   in  initWith toBM (toBM BWP.deflt)-       .-       catMaybes-       .-       traverse BWP.deflt (BWP.check chan)----- might be moved to synthesizer-core-constant ::-   (Arrow arrow) =>-   y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y)-constant y = arr $-   EventListBT.singleton y .-   NonNegW.fromNumberMsg "MIDI.CausalIO.constant" .-   fromIntegral .-   EventListTT.duration--_constant ::-   (Arrow arrow, CutG.Read input) =>-   y -> arrow input (EventListBT.T PC.ShortStrictTime y)-_constant y = arr $-   EventListBT.singleton y .-   NonNegW.fromNumberMsg "MIDI.CausalIO.constant" .-   CutG.length----noteEvents ::-   (Check.C event, Arrow arrow) =>-   MIDIEv.Channel ->-   arrow-      (Events event)-      (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))-noteEvents chan =-   mapMaybe $ MIDIEv.checkNoteEvent chan---embedPrograms ::-   MIDIEv.Program ->-   PIO.T-      (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))-      (Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program)))-embedPrograms initPgm =-   catMaybes .-   traverse initPgm MIDIEv.embedProgramState---type GateChunk = Gate.Chunk MIDIEv.Velocity-type Instrument y chunk = y -> y -> PIO.T GateChunk chunk-type Bank y chunk = MIDIEv.Program -> Instrument y chunk----{--for distinction of notes with the same pitch--We must use Integer instead of Int, in order to avoid an overflow-that would invalidate the check for unmatched NoteOffs-that is based on comparison of the NoteIds.-We cannot re-use NoteIds easily,-since the events at one time point are handled out of order.--}-newtype NoteId = NoteId Integer-   deriving (Show, Eq, Ord)--succNoteId :: NoteId -> NoteId-succNoteId (NoteId n) = NoteId (n+1)--flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]-flattenNoteIdRange (start,afterEnd) =-   takeWhile (<afterEnd) $ iterate succNoteId start---newtype NoteOffList =-   NoteOffList {-      unwrapNoteOffList :: Events (NoteBoundary NoteId)-   }---instance CutG.Read NoteOffList where-   null (NoteOffList evs) =-      EventListTT.isPause evs && EventListTT.duration evs == 0-   length = fromIntegral . EventListTT.duration . unwrapNoteOffList--instance CutG.NormalForm NoteOffList where-   evaluateHead =-      EventListMT.switchTimeL (\t _ -> rnf (NonNegW.toNumber t)) .-      unwrapNoteOffList--instance Monoid NoteOffList where-   mempty = NoteOffList (EventListTT.pause mempty)-   mappend (NoteOffList xs) (NoteOffList ys) =-      NoteOffList (mappend xs ys)--{- |-The function defined here are based on the interpretation-of event lists as piecewise constant signals.-They do not fit to the interpretation of atomic events.-Because e.g. it makes no sense to split an atomic event into two instances by splitAt,-and it is also not clear, whether dropping the first chunk-shall leave a chunk of length zero-or remove that chunk completely.--}-instance CutG.Transform NoteOffList where-   take n (NoteOffList xs) =-      NoteOffList $-      EventListTT.takeTime-         (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs-   drop n (NoteOffList xs) =-      NoteOffList $-      EventListTT.dropTime-         (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs-   splitAt n (NoteOffList xs) =-      mapPair (NoteOffList, NoteOffList) $-      EventListTT.splitAtTime-         (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs--   -- cf. ChunkySize.dropMarginRem-   dropMarginRem =-      CutG.dropMarginRemChunky-         (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList)--   reverse (NoteOffList xs) =-      NoteOffList . EventListTT.reverse $ xs---findEvent ::-   (a -> Bool) ->-   Events a -> (Events a, Maybe a)-findEvent p =-   EventListTT.foldr-      (\t -> mapFst (EventListMT.consTime t))-      (\evs rest ->-         case ListHT.break p evs of-            (prefix, suffix) ->-               mapFst (EventListMT.consBody prefix) $-               case suffix of-                  [] -> rest-                  ev:_ -> (EventListTT.pause mempty, Just ev))-      (EventListBT.empty, Nothing)--gateFromNoteOffs ::-   (MIDIEv.Pitch, NoteId) ->-   NoteOffList ->-   GateChunk-gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) =-   let dur = EventListTT.duration noteOffs-       (sustain, mEnd) =-          findEvent-             (\bnd ->-                case bnd of-                   -- AllNotesOff -> True-                   NoteBoundary endPitch _ noteId ->-                      pitchNoteId == (endPitch, noteId))-          noteOffs-   in  Gate.chunk dur $-       flip fmap mEnd $ \end ->-       (EventListTT.duration sustain,-        case end of-           NoteBoundary _ endVel _ -> endVel-           {--           AllNotesOff -> VoiceMsg.normalVelocity -} )---data NoteBoundary a =-     NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a---   | AllSoundOff-   deriving (Eq, Show)--{- |-We count NoteIds per pitch,-such that the pair (pitch,noteId) identifies a note.-We treat nested notes in a first-in-first-out order (FIFO).-E.g.--> On, On, On, Off, Off, Off--is interpreted as--> On 0, On 1, On 2, Off 0, Off 1, Off 2--NoteOffs without previous NoteOns are thrown away.--}-assignNoteIds ::-   (Traversable f) =>-   PIO.T-      (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])-      (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])-assignNoteIds =-   fmap concat-   ^<<-   traverse Map.empty (\bnd ->-      case bnd of-         MIDIEv.AllNotesOff -> do-            notes <- MS.get-            MS.put Map.empty-            return $-               concatMap (\(pitch, range) ->-                  map-                     (\noteId ->-                        NoteBoundary pitch VoiceMsg.normalVelocity-                           (noteId, Nothing))-                     (flattenNoteIdRange range)) $-               Map.toList notes-         MIDIEv.NoteBoundary pitch vel mpgm ->-            fmap (fmap (\noteId ->-               NoteBoundary pitch vel (noteId,mpgm))) $-            case mpgm of-               Nothing -> do-                  mNoteId <- MS.gets (Map.lookup pitch)-                  case mNoteId of-                     Nothing -> return []-                     Just (nextNoteOffId, nextNoteOnId) ->-                        if nextNoteOffId >= nextNoteOnId-                          then return []-                          else do-                             MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId))-                             return [nextNoteOffId]-               Just _ -> do-                  mNoteId <- MS.gets (Map.lookup pitch)-                  let (nextNoteOffId, nextNoteOnId) =-                         case mNoteId of-                            Nothing -> (NoteId 0, NoteId 0)-                            Just ids -> ids--                  MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId))-                  return [nextNoteOnId])--{-# INLINE velFreqBank #-}-velFreqBank ::-   (Trans.C y) =>-   (MIDIEv.Program -> y -> y -> process) ->-   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process)-velFreqBank bank pgm vel pitch =-   bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch)--applyInstrumentCore ::-   (Arrow arrow) =>-   ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->-   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->-    PIO.T gateCtrl chunk) ->-   arrow-      (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))-      (Zip.T-         NoteOffList-         (Events (PIO.T noteOffListCtrl chunk)))-applyInstrumentCore makeGate bank = arr $-   uncurry Zip.Cons .-   mapFst NoteOffList .-   EventListTT.unzip .-   fmap (ListHT.unzipEithers . fmap (\ev ->-      case ev of---         MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff-         NoteBoundary pitch vel (noteId, mpgm) ->-            case mpgm of-               Nothing -> Left $ NoteBoundary pitch vel noteId-               Just pgm ->-                  Right $-                     bank pgm vel pitch-                     <<^-                     makeGate (pitch, noteId)))--applyInstrument ::-   (Arrow arrow) =>-   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->-    PIO.T GateChunk chunk) ->-   arrow-      (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))-      (Zip.T-         NoteOffList-         (Events (PIO.T NoteOffList chunk)))-applyInstrument bank =-   applyInstrumentCore gateFromNoteOffs bank---type ModulatedBank y ctrl chunk =-        MIDIEv.Program -> y -> y ->-        PIO.T (Zip.T GateChunk ctrl) chunk--applyModulatedInstrument ::-   (Arrow arrow, CutG.Read ctrl) =>-   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->-    PIO.T (Zip.T GateChunk ctrl) chunk) ->-   arrow-      (Zip.T-         (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))-         ctrl)-      (Zip.T-         (Zip.T NoteOffList ctrl)-         (Events (PIO.T (Zip.T NoteOffList ctrl) chunk)))-applyModulatedInstrument bank =-   (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) ->-      Zip.Cons (Zip.Cons noteOffs ctrl) events)-   ^<<-   Zip.arrowFirst-      (applyInstrumentCore-         (Zip.arrowFirst . gateFromNoteOffs) bank)---{- |-Turn an event list with bundles of elements-into an event list with single events.-ToDo: Move to event-list package?--}-flatten ::-   (NonNeg.C time) =>-   a ->-   EventListTT.T time [a] ->-   EventListTT.T time a-flatten empty =-   EventListTT.foldr-      EventListMT.consTime-      (\bt xs ->-         uncurry EventListMT.consBody $-         case bt of-            [] -> (empty, xs)-            b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs))-      EventListBT.empty---flattenControlSchedule ::-   (Monoid chunk, Arrow arrow) =>-   arrow-      (Zip.T ctrl-         (EventListTT.T StrictTime [PIO.T ctrl chunk]))-      (Zip.T ctrl-         (EventListTT.T StrictTime (PIO.T ctrl chunk)))-flattenControlSchedule = arr $-   \(Zip.Cons ctrl evs) ->-      -- Zip.consChecked "flattenControlSchedule" ctrl $-      Zip.Cons ctrl $-      flatten (arr (const mempty)) evs----data CausalState a b =-   forall state.-   CausalState-      (a -> state -> IO (b, state))-      (state -> IO ())-      state--_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)-_applyChunkSimple (CausalState next delete state0) input = do-   (output, state1) <- next input state0-   return (output, CausalState next delete state1)--applyChunk ::-   (CutG.Read a, CutG.Read b) =>-   CausalState a b -> a -> IO (b, Maybe (CausalState a b))-applyChunk (CausalState next delete state0) input = do-   (output, state1) <- next input state0-   cs <--      if CutG.length output < CutG.length input-        then do-           delete state1-           return Nothing-        else return $ Just $ CausalState next delete state1-   return (output, cs)---- could be moved to synthesizer-core-applyModulation ::-   (CutG.Transform ctrl, CutG.NormalForm ctrl,-    CutG.Read chunk,-    Monoid time, ToInteger.C time) =>-   PIO.T-      (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))-      (EventListTT.T time chunk)-applyModulation = PIO.Cons-   (\(Zip.Cons ctrl evs) acc0 -> do-      acc1 <- mapM (flip applyChunk ctrl) acc0-      let (accChunks, acc2) = unzip acc1--      (newChunks, newAcc) <--         MW.runWriterT $-         flip MS.evalStateT ctrl $-         EventListTT.mapM-            (\time -> do-               ctrl_ <- MS.gets (CutG.drop (fromIntegral time))-               MS.put ctrl_-               return (case CutG.evaluateHead ctrl_ of () -> time))-            (\(PIO.Cons next create delete) -> do-               state0 <- liftIO create-               (chunk, state1) <--                  liftIO . applyChunk (CausalState next delete state0)-                  =<< MS.get-               MT.lift $ MW.tell $ maybeToList state1-               return chunk)-            evs--      return-         (EventListTM.prependBodyEnd-             (EventList.fromPairList $-              map ((,) mempty) accChunks)-             newChunks,-          Maybe.catMaybes acc2 ++ newAcc))--   (return [])-   (mapM_ (\(CausalState _ close state) -> close state))---- move synthesizer-core:CausalIO-arrangeStorable ::-   (Arrow arrow, Storable a, Additive.C a) =>-   arrow-      (EventListTT.T StrictTime (SV.Vector a))-      (SV.Vector a)-arrangeStorable =-   arr $ \evs ->-   SVST.runSTVector (do-      v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero-      mapM_ (uncurry $ CutSt.addChunkToBuffer v) $-         AbsEventList.toPairList $-         AbsEventList.mapTime fromIntegral $-         EventList.toAbsoluteEventList 0 $-         EventListTM.switchTimeR const evs-      return v)----sequenceCore ::-   (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) =>-   MIDIEv.Channel ->-   Bank y chunk ->-   PIO.T (Events event) (EventListTT.T StrictTime chunk)-sequenceCore channel bank =-   applyModulation-   .-   flattenControlSchedule-   .-   applyInstrument (velFreqBank bank)-   .-   assignNoteIds-   .-   embedPrograms (VoiceMsg.toProgram 0)-   .-   noteEvents channel---sequenceModulated ::-   (Check.C event, Monoid chunk, CutG.Read chunk,-    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>-   MIDIEv.Channel ->-   ModulatedBank y ctrl chunk ->-   PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)-sequenceModulated channel bank =-   applyModulation-   .-   flattenControlSchedule-   .-   applyModulatedInstrument (velFreqBank bank)-   .-   Zip.arrowFirst-      (assignNoteIds-       .-       embedPrograms (VoiceMsg.toProgram 0)-       .-       noteEvents channel)---sequenceModulatedMultiProgram ::-   (Check.C event, Monoid chunk, CutG.Read chunk,-    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>-   MIDIEv.Channel ->-   MIDIEv.Program ->-   ModulatedBank y ctrl chunk ->-   PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)-sequenceModulatedMultiProgram channel initPgm bank =-   applyModulation-   .-   flattenControlSchedule-   .-   applyModulatedInstrument (velFreqBank bank)-   .-   Zip.arrowFirst-      (assignNoteIds-       .-       embedPrograms initPgm-       .-       noteEvents channel)----- | may replace the other functions-sequenceModulatedMultiProgramVelocityPitch ::-   (Check.C event, Monoid chunk, CutG.Read chunk,-    CutG.Transform ctrl, CutG.NormalForm ctrl) =>-   MIDIEv.Channel ->-   MIDIEv.Program ->-   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->-    PIO.T (Zip.T GateChunk ctrl) chunk) ->-   PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)-sequenceModulatedMultiProgramVelocityPitch channel initPgm bank =-   applyModulation-   .-   flattenControlSchedule-   .-   applyModulatedInstrument bank-   .-   Zip.arrowFirst-      (assignNoteIds-       .-       embedPrograms initPgm-       .-       noteEvents channel)---sequenceStorable ::-   (Check.C event, Storable a, Additive.C a, Trans.C y) =>-   MIDIEv.Channel ->-   Bank y (SV.Vector a) ->-   PIO.T (Events event) (SV.Vector a)-sequenceStorable channel bank =-   arrangeStorable-   .-   sequenceCore channel bank
− tests/examples/ghc710/Process1.hs 
@@ -1,7 +0,0 @@-module Synthesizer.MIDI.CausalIO.Process1 where--gateFromNoteOffs=-   let dur = 1-   in (d, 3-          {--            AllNotesOff -> VoiceMsg.normalVelocity -} )
− tests/examples/ghc710/Pseudonym.hs 
@@ -1,41 +0,0 @@-default(Int);q s=s++ss s;ss ""=" \"\"";ss s=" "++show(take 50 s)++"++\n"++- ss(dd 50 s);t3="   ";z n=t3++" xo"!!n:t3;zl n = z(l n);j=head$[m|- (m,0)<-zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m=- "default(Int);q s=s++ss s;ss \"\"=\" \\\"\\\"\";ss s=\" \"++s"++- "how(take 50 s)++\"++\\n\"++\n ss(dd 50 s);t3=\"   \";z n"++- "=t3++\" xo\"!!n:t3;zl n = z(l n);j=head$[m|\n (m,0)<-"++- "zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m=\n"-vv="\n "++z0++";z0=z"++z0++"0 ;a=\n "++zl 4++"-0;b="++zl 7++"-0;c="++zl 1++- "\n "++z0++"-0;ms"++z0++"=[[4,\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\n ,0,8],[1, 5,3],[4,0,3],[1,0,2]]\n ;main=putStr(unlines[q m,q y,vv\n "++z0++"]);x="- ++z0++"1; d=\n "++zl 6++"-0;e="++zl 0++"-0;f="++zl 5++"\n "++z0++"-0"- ++";o="++z0++"2;p=[\n e,c,g,i,a,f,d,b,h];r=[\"\",\"You \"\n ++\"win\",\"I win\"]!!head([w|w<-[1\n ,2],x<-ms,all(\\x->w==l x)x]++[0\n "++z0++"]);n="++z0++"1"- ++"9;g=\n "++zl 2++"-0;h="++zl 8++"-0;i="++zl 3++"\n "++z0++"-0;dd"++z0++- "=drop\n\n"++r-;y= "vv=\"\\n \"++z0++\";z0=z\"++z0++\"0 ;a=\\n \"++zl 4++\"-0;b"++- "=\"++zl 7++\"-0;c=\"++zl 1++\n \"\\n \"++z0++\"-0;ms\"++z0+"++- "+\"=[[4,\\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\\n ,0,8],"++- "[1, 5,3],[4,0,3],[1,0,2]]\\n ;main=putStr(unlines[q"++- " m,q y,vv\\n \"++z0++\"]);x=\"\n ++z0++\"1; d=\\n \"++zl 6"++- "++\"-0;e=\"++zl 0++\"-0;f=\"++zl 5++\"\\n \"++z0++\"-0\"\n +"++- "+\";o=\"++z0++\"2;p=[\\n e,c,g,i,a,f,d,b,h];r=[\\\"\\\",\\\""++- "You \\\"\\n ++\\\"win\\\",\\\"I win\\\"]!!head([w|w<-[1\\n ,2]"++- ",x<-ms,all(\\\\x->w==l x)x]++[0\\n \"++z0++\"]);n=\"++z0"++- "++\"1\"\n ++\"9;g=\\n \"++zl 2++\"-0;h=\"++zl 8++\"-0;i=\"++"++- "zl 3++\"\\n \"++z0++\"-0;dd\"++z0++\n \"=drop\\n\\n\"++r\n;y="--        ;z0=z       0 ;a=-        -0;b=       -0;c=-        -0;ms       =[[4,- 7,1],[6,0,5],[2,8,3],[4,6,2],[7- ,0,8],[1, 5,3],[4,0,3],[1,0,2]]- ;main=putStr(unlines[q m,q y,vv-        ]);x=       1; d=-        -0;e=       -0;f=-        -0;o=       2;p=[- e,c,g,i,a,f,d,b,h];r=["","You "- ++"win","I win"]!!head([w|w<-[1- ,2],x<-ms,all(\x->w==l x)x]++[0-        ]);n=       19;g=-        -0;h=       -0;i=-        -0;dd       =drop-
− tests/examples/ghc710/PuncFunctions.hs 
@@ -1,25 +0,0 @@--- | Compares two functions taking one container-(=*=) :: (Eq' a b) => (f -> a) -> (g -> b)-      -> SameAs f g r -> r -> Property-(f =*= g) sa i = f (toF sa i) =^= g (toG sa i)---- | Compares two functions taking one scalar and one container-(=?*=) :: (Eq' a b) => (t -> f -> a) -> (t -> g -> b)-       -> SameAs f g r -> r -> t -> Property-(f =?*= g) sa i t = (f t =*= g t) sa i---- | Compares functions taking two scalars and one container-(=??*=) :: (Eq' a b) => (t -> s -> f -> a) -> (t -> s -> g -> b)-        -> SameAs f g r -> r -> t -> s -> Property-(f =??*= g) sa i t s = (f t s =*= g t s) sa i---- | Compares two functions taking two containers-(=**=) :: (Eq' a b) => (f -> f -> a) -> (g -> g -> b)-       -> SameAs f g r -> r -> r -> Property-(f =**= g) sa i = (f (toF sa i) =*= g (toG sa i)) sa---- | Compares two functions taking one container with preprocessing-(=*==) :: (Eq' f g) => (z -> f) -> (z -> g) -> (p -> z)-       -> SameAs f g r -> p -> Property-(f =*== g) p _ i = f i' =^= g i'-  where i' = p i
− tests/examples/ghc710/QuasiQuote.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module QuasiQuote where--import T7918A--ex1 = [qq|e1|]-ex2 = [qq|e2|]-ex3 = [qq|e3|]-ex4 = [qq|e4|]--tx1 = undefined :: [qq|t1|]-tx2 = undefined :: [qq|t2|]-tx3 = undefined :: [qq|t3|]-tx4 = undefined :: [qq|t4|]--px1 [qq|p1|] = undefined-px2 [qq|p2|] = undefined-px3 [qq|p3|] = undefined-px4 [qq|p4|] = undefined--{-# LANGUAGE QuasiQuotes #-}--testComplex    = assertBool "" ([istr|-        ok-#{Foo 4 "Great!" : [Foo 3 "Scott!"]}-        then-|] == ("\n" ++-    "        ok\n" ++-    "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++-    "        then\n"))-
− tests/examples/ghc710/QuasiQuote2.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Test where--a = bar-    where-        bar = [q|-            |]--b = bar-    where-        bar = [q|-           |]--c = bar-    where-        bar = [q|-             |]--d = [q|-            |]
− tests/examples/ghc710/RSA.hs 
@@ -1,19 +0,0 @@-import Data.Char-e=181021504832735228091659724090293195791121747536890433--u(f,m)x=i(m(x),       [],let(a,b)=f(x)       in(a:u(f,m)b))-(v,h)=(foldr(\x(y    )->00+128*y+x)0,u(     sp(25),((==)"")))-p::(Integer,Integer )->Integer      ->     Integer    --NotInt-p(n,m)x     =i(n==0 ,1,i(z n             ,q(n,m)x,    r(n,m)x))-i(n,e,d     )=if(n) then(e)              else  (d)    --23+3d4f-(g,main     ,s,un)= (\x->x,             y(j),\x->x*x,unlines)--)-j(o)=i(take(2)o==   "e=","e="++t        (drop(4-2)o),i(d>e,k,l)o)-l=un.map (show.p      (e,n).v.map(      fromIntegral{-g-}.ord)).h-k=co.map(map(chr       .fromIntegral    ).w.p(d,n).   read).lines-(t,y)=(\ (o:q)->              i(o=='-'  ,'1','-' ):   q,interact)-q(n,m)x=   mod(s(    p(        div(n)2, m{-jl-})x)    )m--hd&&gdb-(r,z,co)    =(\(n,   m)x->mod(x*p(n-1,  m)x)m,even    ,concat)--6-(w,sp)=(    u(\x->(   mod(x)128,div(x   )128),(==0    )),splitAt)--d=563347325936+1197371806136556985877790097-563347325936-n=351189532146914946493104395525009571831256157560461451
− tests/examples/ghc710/RankNTypes.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}---- from https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html--import System.Random-import Control.Monad.State-import Data.Char---id' :: forall a. a -> a-id' x = x--f = print (id' (3 :: Integer),-           id' "blah")---- rank 2 polymorphism-type IdFunc = forall a. a -> a--id'' :: IdFunc-id'' x = x--someInt :: IdFunc -> Integer-someInt id' = id' 3---- rank 3 polymorphism-type SomeInt = IdFunc -> Integer--someOtherInt :: SomeInt -> Integer-someOtherInt someInt' =-    someInt' id + someInt' id---- random numbers--data Player =-    Player {-      playerName :: String,-      playerPos  :: (Double, Double)-    }-    deriving (Eq, Ord, Show)---{--randomPlayer-    :: (MonadIO m, MonadState g m, RandomGen g)-    => m Player--}--type GenAction m = forall a. (Random a) => m a--type GenActionR m = forall a. (Random a) => (a, a) -> m a---- genRandom :: (RandomGen g) => GenAction (State g)--- genRandom = state random--genRandomR :: (RandomGen g) => GenActionR (State g)-genRandomR range = state (randomR range)--genRandom :: (Random a, RandomGen g) => State g a-genRandom = state random---randomPlayer :: (MonadIO m) => GenActionR m -> m Player-randomPlayer genR = do-    liftIO (putStrLn "Generating random player...")--    len <- genR (8, 12)-    name <- replicateM len (genR ('a', 'z'))-    x <- genR (-100, 100)-    y <- genR (-100, 100)--    liftIO (putStrLn "Done.")-    return (Player name (x, y))--main :: IO ()-main = randomPlayer randomRIO >>= print---- scott encoding--data List a-    = Cons a (List a)-    | Nil--uncons :: (a -> List a -> r) -> r -> List a -> r-uncons co ni (Cons x xs) = co x xs-uncons co ni Nil         = ni--listNull :: List a -> Bool-listNull = uncons (\_ _ -> False) True--listMap :: (a -> b) -> List a -> List b-listMap f =-    uncons (\x xs -> Cons (f x) (listMap f xs))-           Nil--newtype ListS a =-    ListS {-      unconsS :: forall r. (a -> ListS a -> r) -> r -> r-    }--nilS :: ListS a-nilS = ListS (\co ni -> ni)--consS :: a -> ListS a -> ListS a-consS x xs = ListS (\co ni -> co x xs)--unconsS' :: (a -> ListS a -> r) -> r -> ListS a -> r-unconsS' co ni (ListS f) = f co ni--instance Functor ListS where-    fmap f =-        unconsS' (\x xs -> consS (f x) (fmap f xs))-                 nilS---- Church Encoding-newtype ListC a =-    ListC {-      foldC :: forall r. (a -> r -> r) -> r -> r-    }--foldC' :: (a -> r -> r) -> r -> ListC a -> r-foldC' co ni (ListC f) = f co ni--instance Functor ListC where-    fmap f = foldC' (\x xs -> consC (f x) xs) nilC--consC = undefined-nilC = undefined---- GADTs and continuation passing style-data Some :: * -> * where-    SomeInt  :: Int -> Some Int-    SomeChar :: Char -> Some Char-    Anything :: a -> Some a---unSome :: Some a -> a-unSome (SomeInt x) = x + 3-unSome (SomeChar c) = toLower c-unSome (Anything x) = x---newtype SomeC a =-    SomeC {-      runSomeC ::-          forall r.-          ((a ~ Int) => Int -> r) ->-          ((a ~ Char) => Char -> r) ->-          (a -> r) ->-          r-      }---- dependent types--idk :: forall (a :: *). a -> a-idk x = x-
− tests/examples/ghc710/RdrNames.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-}-module RdrNames where--import Data.Monoid---- -------------------------------------------------------------------------        |  'type' qcname            {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))---                                            [mj AnnType $1,mj AnnVal $2] }---- Tested in DataFamilies.hs---- -------------------------------------------------------------------------        | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))---                                       [mo $1,mj AnnVal $2,mc $3] }-ff = (RdrNames.:::) 0 1----- -------------------------------------------------------------------------        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))---                                       [mo $1,mj AnnVal $2,mc $3] }-data FF = ( :::  ) Int Int---- -------------------------------------------------------------------------        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))---                                       [mj AnnBackquote $1,mj AnnVal $2---                                       ,mj AnnBackquote $3] }-data GG = GG Int Int-gg = 0 `  GG ` 1---- -------------------------------------------------------------------------        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2))---                                       [mj AnnBackquote $1,mj AnnVal $2---                                       ,mj AnnBackquote $3] }-vv = "a" ` mappend  ` "b"---- -------------------------------------------------------------------------        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))---                                       [mj AnnBackquote $1,mj AnnVal $2---                                       ,mj AnnBackquote $3] }-vvq = "a" `  Data.Monoid.mappend ` "b"---- -------------------------------------------------------------------------        | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)---                                              [mo $1,mc $2] }--- Tested in Vect.hs---- -------------------------------------------------------------------------        | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)---                                              [mo $1,mc $2] }--- Tested in Vect.hs---- -------------------------------------------------------------------------        | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple---                                                        (snd $2 + 1)))---                                       (mo $1:mc $3:(mcommas (fst $2))) }-ng :: (, , ,) Int Int Int Int-ng = undefined---- -------------------------------------------------------------------------        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple---                                                        (snd $2 + 1)))---                                       (mo $1:mc $3:(mcommas (fst $2))) }--- Tested in Unboxed.hs---- -------------------------------------------------------------------------        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)---                                       [mo $1,mj AnnRarrow $2,mc $3] }--ft :: (->) a b-ft = undefined--fp :: (   ->    ) a b-fp = undefined--type family F a :: * -> * -> *-type instance F Int = (->)-type instance F Char = ( ,  )---- -------------------------------------------------------------------------        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] }-lt :: [] a-lt = undefined---- -------------------------------------------------------------------------        | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }---- GHC source indicates this constuctor is only available in PrelPArr--- ltp :: [::] a--- ltp = undefined---- -------------------------------------------------------------------------        | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)---                                        [mo $1,mj AnnTildehsh $2,mc $3] }---- primitive type?--- Refl Int :: ~# * Int Int--- Refl Maybe :: ~# (* -> *) Maybe Maybe---- | A data constructor used to box up all unlifted equalities------ The type constructor is special in that GHC pretends that it--- has kind (? -> ? -> Fact) rather than (* -> * -> *)-data (~) a b = Eq# ((~#) a b)-data (  ~ ) a b = Eq# (( ~#  ) a b)--data Coercible a b = MkCoercible ((~#) a b)----- -------------------------------------------------------------------------        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))---                                               [mo $1,mj AnnVal $2,mc $3] }--- TBD---- -------------------------------------------------------------------------        | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)---                                               [mo $1,mj AnnTilde $2,mc $3] }---- ------------------------------------------------------------------------- tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))---                                        [mj AnnBackquote $1,mj AnnVal $2---                                        ,mj AnnBackquote $3] }---- ------------------------------------------------------------------------{- From #haskell-emacs-gracjan> did you know that this is legal haskell:-<gracjan> (+ 1) ` fmap {- -} ` [1,2,3]--}-xxx = (+ 1) ` fmap {- -} ` [1,2,3]
− tests/examples/ghc710/RebindableSyntax.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction #-}---- From https://ocharles.org.uk/blog/guest-posts/2014-12-06-rebindable-syntax.html--import Prelude hiding ((>>), (>>=), return)-import Data.Monoid-import Control.Monad ((<=<))-import Data.Map as M--addNumbers = do-  80-  60-  10-  where (>>) = (+)-        return = return--(>>) = mappend-return = mempty---- We can perform the same computation as above using the Sum wrapper:--someSum :: Sum Int-someSum = do-    Sum 80-    Sum 60-    Sum 10-    return--someProduct :: Product Int-someProduct = do-    Product 10-    Product 30---- Why not try something non-numeric?--tummyMuscle :: String-tummyMuscle = do-    "a"-    "b"---ff = let-  (>>)    = flip (.)-  return  = id--  arithmetic = do-      (+1)-      (*100)-      (/300)-      return--  -- Here, the input is numeric and all functions operate on a number.-  -- What if we want to take a list and output a string? No problem:--  check = do-      sum-      sqrt-      floor-      show-  in 4
− tests/examples/ghc710/RecordSemi.hs 
@@ -1,15 +0,0 @@--- | Generate a generate statement for the builtin function "fst"-genFst :: BuiltinBuilder-genFst = genNoInsts genFst'-genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]-genFst' res f args@[(arg,argType)] = do {-  ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType-  ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]-  ; let {-        ; labels      = getFieldLabels arg_htype 0-        ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)-        ; assign      = mkUncondAssign res argexprA-        } ;-    -- Return the generate functions-  ; return [assign]-  }
− tests/examples/ghc710/RecordUpdate.hs 
@@ -1,6 +0,0 @@--data Foo = F { f1 :: Int, f2 :: String }--foo :: Int -> Foo -> Foo-foo v f = f { f1 = v }-
− tests/examples/ghc710/RecordWildcard.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---parseArgs =-  Args-        { equalProb = E `elem` opts-        , ..-        }
− tests/examples/ghc710/RecursiveDo.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE RecursiveDo #-}--- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html--import Control.Monad.Fix--data RoseTree a = RoseTree a [RoseTree a]-  deriving (Show)--exampleTree :: RoseTree Int-exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []]--pureMax :: Ord a => RoseTree a -> RoseTree (a, a)-pureMax tree =-  let (t, largest) = go largest tree-  in t- where-  go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a)-  go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x)-  go biggest (RoseTree x xs) =-      let sub = map (go biggest) xs-          (xs', largests) = unzip sub-      in (RoseTree (x, biggest) xs', max x (maximum largests))--t = pureMax exampleTree---- -----------------------------------------------------------------------impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b))-impureMin f tree = do-  rec (t, largest) <- go largest tree-  return t- where-  go smallest (RoseTree x []) = do-    b <- f x-    return (RoseTree (x, smallest) [], b)--  go smallest (RoseTree x xs) = do-    sub <- mapM (go smallest) xs-    b <- f x-    let (xs', bs) = unzip sub-    return (RoseTree (x, smallest) xs', min b (minimum bs))--budget :: String -> IO Int-budget "Ada"      = return 10 -- A struggling startup programmer-budget "Curry"    = return 50 -- A big-earner in finance-budget "Dijkstra" = return 20 -- Teaching is the real reward-budget "Howard"   = return 5  -- An frugile undergraduate!--inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" []-                            , RoseTree "Curry" [ RoseTree "Howard" []]-                            ]--ti = impureMin budget inviteTree--simplemdo = mdo-  return 5-
− tests/examples/ghc710/RedundantDo.hs 
@@ -1,4 +0,0 @@-foo =-  case x of-    True -> foo-    False -> foo
− tests/examples/ghc710/Remorse.hs 
@@ -1,88 +0,0 @@-import Prelude as P;import Data.Char as C;import Data.List;import System.Environment as S;-main = do- (.--.)<-(--.|.--.+);(.-)<-(--.|.-+)- case (.-) of ["+",(.-)]->(-|---|--+) (.-);["-",(.-)]->(..-.|.-.|--+) (.-);_->(.|.-.)("Usage: "++(.--.)++" (+/-) F.hs")- where- (-|---|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--).(--.).(-..-))(..-.))- (..-.|.-.|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--|=).(--.|=).(-..-))(..-.))---- | (--| ): (-.-.|---|-.|...-|.|.-.|-) (-.-.|....|.-|.-.) -> (--|---|.-.|...|.)-_--| 'a'=".-";_--| 'b'="-...";_--| 'c'="-.-.";_--| 'd'= "-..";_--| 'e'=".";-_--| 'f'="..-.";_--| 'g'="--.";_--| 'h'="....";_--| 'i'="..";_--| 'j'=".---";-_--| 'k'="-.-";_--| 'l'=".-..";_--| 'm'="--";_--| 'n'="-.";_--| 'o'="---";-_--| 'p'=".--.";_--| 'q'="--.-";_--| 'r'=".-.";_--| 's'="...";_--| 't'="-";-_--| 'u'="..-";_--| 'v'="...-";_--| 'w'=".--";_--| 'x'="-..-";_--| 'y'="-.--";-_--| 'z'="--..";_--| '0'="-----";_--| '1'=".----";_--| '2'="..---";-_--| '3'="...--";_--| '4'="....-";_--| '5'=".....";_--| '6'="-....";-_--| '7'="--...";_--| '8'="---..";_--| '9'="----.";_--| '_'="!";_--| '\''="=";-_--| (-.-.)- |'A'<=(-.-.)&&(-.-.)<='Z'=(()--| (-|.-..+) (-.-.))++"+"- |(-..|.|..-.)=[(-.-.)]---- | (--|=): (..|-.|...-) of (--| )-(--|=) (...)=(..-.)[(-.-.)|(-.-.)<-['a'..'z']++['0'..'9']++['A'..'Z']++['_','\''],()--| (-.-.)==(...)]- where (..-.)[]=(....|-..) (...);(..-.) (-.-.|...)=(....|-..) (-.-.|...)---- | (.--): (-.-.|---|-.|...-|.|.-.|-) (.--|---|.-.|-..)-(.--) (...)- |(...).|.-..["e","i","m","o","t"]=(.--)((...)++" ") -- (...|---|--|.) (..-|-.|-|..|-..|-.--) (.|-..-|-.-.|.|.--.|-|..|---|-.|...):- -- .=(-.-.|---|--|.--.|---|...|..|-|..|---|-.), ..=(-.|..-|--|.|.-.|..|-.-.) (.-.|.-|-.|--.|.), --/---=(.|-.|-..)-of-(.-..|..|-.|.) (-.-.|---|--|--|.|-.|-), -=(...|..-|-...|-|.-.|.-|-.-.|-|..|---|-.)- |(...).|.-..(-.-|.|-.--|...)=(...)- |(..|-..) (...)=(('(':).(++")").(-.-.|-.-.).(..|.--.) "|".(--|.--.)((--| )()))(...)- |(..|-.|..-.|-..-) (...)=((-|.-..).(..|-).(.--).(-|.-..).(..|-))(...)- |(-..|.|..-.)=(...)- where- (..|-..)((-..-):_)=(..|.-..+) (-..-)||(-..-)=='_'- (..|-.|..-.|-..-)((-..-):_)=(-..-)=='`'---- | (.--|=): do (..|-.|...-) of (.--)-(.--|=) (...)- |(...)=="|"="|"- |(..|-..) (...)=((--|.--.) (--|=).(-.-.|....|.-.|...).(-|.-..).(..|-))(...)- |(---|-.|.) (...)='`':((--|=).(..|-))(...):"`"- |(..|-.|..-.|-..-) (...)='`':((--|.--.) (--|=).(-.-.|....|.-.|...))(...)++"`"- |(-..|.|..-.)=(...)- where- (..|-..)('(':(....):(-| ))=(.--.|.-.|.) (....)&&(.-..|.-) (-| )==')'&&(.-|.-..)(??)((..|-) (-| ))- (..|-..) _=False- (.--.|.-.|.) (-.-.)=(-.-.).|.-..".-"- (..|-.|..-.|-..-) (...)=(.--.|.-.|.) ((....|-..) (...))&&(.-|.-..)(??)((-|.-..) (...))&&(.-|-.)(=='|')(...)- (---|-.|.) (...)=(.-|.-..) (.--.|.-.|.) ((..|-) (...))&&(.-..|.-) (...)=='|'- (-.-.|....|.-.|...) (...)=case (-..|.--+)(=='|')(...) of []->[];(...)->let ((.--),(...|...))=(-...|.-.)(=='|')(...) in (.--):(-.-.|....|.-.|...) (...|...)---- | (.--.|.-.|.|-..) (---|-.) (-.-.|....|.-|.-.|...)-(??)(-.-.)=(-.-.).|.-..".-+/=!|"---- | (.-..|.|-..-) (...|.-.|-.-.) -> (-|---|-.-) (...|-|.-.|.|.-|--)-(-..-)[]=[]-(-..-)((-.-.):(...))|(..|...+) (-.-.)=((-.-.):(...|...)):(-..-) (.-.|--) where ((...|...),(.-.|--))=(...|.--.) (..|...+) (...)-(-..-) (...)=(-|---|-.-):(-..-) (.-.|--) where ((-|---|-.-),(.-.|--))=(....|-..)((.--.|.-..|.|-..-) (...))---- | (--.): (--.|.-..|..-|.) (...|.|--.-) (-|---|-.-|...) -> (...|..|-.|--.|.-..|.) (-|---|-.-)-(--.)((--.-):".":(-.):(.-.|--))|(..|..-+)((....|-..) (--.-))=(--.)(((--.-)++"."++(-.)):(.-.|--))-(--.)("`":(.-.|--))=case (--.) (.-.|--) of ((--.-|-.):"`":(.-.|--))->("`"++(--.-|-.)++"`"):(--.) (.-.|--);_->("`":(.-.|--))-(--.)((...):(...|...))=(...):(--.) (...|...)-(--.)[]=[]---- | (--.|=): (.-..|..|-.-|.) (--.) in (.-.|.|...-)-(--.|=)("(":(-.):")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--)-(--.|=)("(":(-.):" ":")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--)-(--.|=)("|":(.-.|--))="|":(--.|=) (.-.|--)-(--.|=)((-.):(...|...):(.-.|--))|(.-|.-..)(.|.-..".-")((..|-) (-.))&&(.-..|.-) (-.)=='|'&&(.-|.-..) (..|...+) (...|...)=(-.):(--.|=) (.-.|--)-(--.|=)((-.):(.-.|--))=(-.):(--.|=) (.-.|--)-(--.|=)[]=[]---- | (....|.-|...|-.-|.|.-..|.-..) (-.-|.|-.--|.--|---|.-.|-..|...)-(-.-|.|-.--|...)=- ["case","class","data","default","deriving","do","else"- ,"if","import","in","infix","infixl","infixr","instance","let","module"- ,"newtype","of","then","type","where","_","main","foreign","ccall","as"]---- | (.-|-...|-...|.-.|.|...-) (.-..|..|-...) (..-.|-.|...)-(-.-.|-.-.)=P.concat;(.|.-..) (-..-)=P.elem (-..-);(--|.--.)=P.map;(-.-.|--+)=P.concatMap;-(...|.--.)=P.span;(-...|.-.)=P.break;(..|.--.)=intersperse;(-..|.--+)=P.dropWhile;-(....|-..)=P.head;(-|.-..)=P.tail;(..|-)=P.init;(.-..|.-)=P.last;-(-|.-..+)=C.toLower;(..|.-..+)=C.isLower;(..|...+)=C.isSpace;(..|..-+)=C.isUpper;-(.-.|..-.+)=P.readFile;(.--.|...+)=P.putStr;(.|.-.)=P.error;-(--.|.-+)=S.getArgs;(--.|.--.+)=S.getProgName;-(.-|.-..)=P.all;(.-|-.)=P.any;(-..|.|..-.)=P.otherwise;(.--.|.-..|.|-..-)=P.lex;
− tests/examples/ghc710/Roles.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE RoleAnnotations, PolyKinds #-}--module Roles where--data T1 a = K1 a-data T2 a = K2 a-data T3 (a :: k) = K3-data T4 (a :: * -> *) b = K4 (a b)--data T5 a = K5 a-data T6 a = K6-data T7 a b = K7 b--type role T1 nominal-type role T2 representational-type role T3 phantom-type role T4 nominal _-type role T5 _
− tests/examples/ghc710/Rules.hs 
@@ -1,39 +0,0 @@-module Rules where--import Data.Char--{-# RULES "map-loop" [ ~  ]  forall f . map' f = map' (id . f) #-}--{-# NOINLINE map' #-}-map' f [] = []-map' f (x:xs) = f x : map' f xs--main = print (map' toUpper "Hello, World")---- Should warn-foo1 x = x-{-# RULES "foo1" [ 1] forall x. foo1 x = x #-}---- Should warn-foo2 x = x-{-# INLINE foo2 #-}-{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-}---- Should not warn-foo3 x = x-{-# NOINLINE foo3 #-}-{-# RULES "foo3" forall x. foo3 x = x #-}--{-# NOINLINE f #-}-f :: Int -> String-f x = "NOT FIRED"--{-# NOINLINE neg #-}-neg :: Int -> Int-neg = negate--{-# RULES-     "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED"- #-}--
− tests/examples/ghc710/RulesSemi.hs 
@@ -1,9 +0,0 @@--{-# RULES-  "cFloatConv/Float->Float"    forall (x::Float).  cFloatConv x = x;-  "cFloatConv/Double->Double"  forall (x::Double). cFloatConv x = x;-  "cFloatConv/Float->CFloat"   forall (x::Float).  cFloatConv x = CFloat x;-  "cFloatConv/CFloat->Float"   forall (x::Float).  cFloatConv CFloat x = x;-  "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x;-  "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x- #-};
− tests/examples/ghc710/ScopedTypeVariables.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- from https://ocharles.org.uk/blog/guest-posts/2014-12-20-scoped-type-variables.html--import qualified Data.Map as Map--insertMany ::  forall k v . Ord k => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v-insertMany f vs m = foldr f1 m vs-  where-    f1 :: (k, v) -> Map.Map k v -> Map.Map k v-    f1 (k,v) m = Map.insertWith f k v m
− tests/examples/ghc710/SemiInstance.hs 
@@ -1,11 +0,0 @@--instance ArrowTransformer (AbortT v) where {-  lift = AbortT . (>>> arr Right);-  tmap f = AbortT . f . unwrapAbortT;-};--instance MakeValueTuple Float  where type ValueTuple Float  = Value Float  ; valueTupleOf = valueOf--instance Foo where {-  type ListElement Zero (a,r) = a;-}
− tests/examples/ghc710/SemiWorkout.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE KindSignatures-           , GADTs-           , ScopedTypeVariables-           , PatternSignatures-           , MultiParamTypeClasses-           , FunctionalDependencies-           , FlexibleInstances-           , UndecidableInstances-           , TypeFamilies-           , FlexibleContexts-           #-}--instance forall init prog prog' fromO fromI progOut progIn-                sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem-                keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem current current' invertedSessionsMe invertedSessionsThem .-    ( ProgramToMVarsOutgoingT prog prog ~ progOut-    , ProgramToMVarsOutgoingT prog' prog' ~ progIn-    , SWellFormedConfig init (D0 E) prog-    , SWellFormedConfig init (D0 E) prog'-    , TyListIndex progOut init (MVar (ProgramCell (Cell fromO)))-    , TyListIndex progIn init (MVar (ProgramCell (Cell fromI)))-    , TyListIndex prog init current'-    , Expand prog current' current-    , MapLookup (TyMap sessionsToIdxMe idxsToPairStructsMe) init-                    (MVar (Map (RawPid, RawPid) (MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))))-    , TyListMember invertedSessionsThem init True-    , MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem-    , MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem-                    (SessionState prog prog' (current, fromO, fromI)) (TyMap keyToIdxMe' idxToValueMe')-    ) =>-    CreateSession False init prog prog'-                  sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem-                  keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem where-                      createSession init FF (Pid remotePid _) =-                          InterleavedChain $-                              \ipid@(IPid (Pid localPid localSTMap) _) mp ->-                                  do { let pidFuncMapMVar :: MVar (Map (RawPid, RawPid)-                                                                       (MVar (PairStruct init prog prog'-                                                                              ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))-                                               = mapLookup localSTMap init-                                     ; pidFuncMap <- takeMVar pidFuncMapMVar-                                     ; emptyMVar :: MVar (TyMap keyToIdxMe' idxToValueMe') <- newEmptyMVar-                                     ; psMVar :: MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))-                                              <- case Map.lookup (localPid, remotePid) pidFuncMap of-                                                   Nothing-                                                       -> do { empty <- newEmptyMVar-                                                             ; putMVar pidFuncMapMVar (Map.insert (localPid, remotePid) empty pidFuncMap)-                                                             ; return empty-                                                             }-                                                   (Just mv)-                                                       -> do { putMVar pidFuncMapMVar pidFuncMap-                                                             ; return mv-                                                             }-                                     ; let idxOfThem :: idxOfThem = mapSize mp-                                           ps :: PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))-                                              = PS localPid (f idxOfThem mp emptyMVar)-                                     ; putMVar psMVar ps-                                     ; mp' <- takeMVar emptyMVar-                                     ; return (idxOfThem, mp', ipid)-                                     }
− tests/examples/ghc710/Shebang.hs 
@@ -1,5 +0,0 @@-#!/usr/bin/env runhaskell-{-# LANGUAGE OverloadedStrings #-}-import Aws.SSSP.App--main = web
− tests/examples/ghc710/ShiftingLambda.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-}-spec :: Spec-spec = do-  describe "split4'8" $ do-    it "0xabc" $ do-      split4'8 0xabc `shouldBe` (0x0a, 0xbc)-    it "0xfff" $ do-      split4'8 0xfff `shouldBe` (0x0f, 0xff)--    describe "(x, y) = split4'8 z" $ do-      prop "x <= 0x0f" $-        \z -> let (x, _) =  split4'8 z in x <= 0x0f-      prop "x << 8 | y == z" $ do-        \z -> let (x, y) = split4'8 z in-          fromIntegral x `shiftL` 8 .|. fromIntegral y == z--match s@Status{ pos, flips, captureAt, captureLen }-  | isOne ?pat = ite (pos .>= strLen) __FAIL__ one-  | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of-    POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps--foo = 1
− tests/examples/ghc710/Sigs.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}--module Sigs where---- TypeSig-f :: Num a => a -> a-f = undefined--pattern Single :: () => (Show a) => a -> [a]-pattern Single x = [x]--g :: (Show a) => [a] -> a-g (Single x) = x---- Fixities--infixr  6 +++-infixr  7 ***,///--(+++) :: Int -> Int -> Int-a +++ b = a + 2*b--(***) :: Int -> Int -> Int-a *** b = a - 4*b--(///) :: Int -> Int -> Int-a /// b = 2*a - 3*b---- Inline signatures--{-# Inline g #-}-{-# INLINE [~34] f #-}---- Specialise signature---- Multiple sigs-x,y,z :: Int-x = 0-y = 0-z = 0
− tests/examples/ghc710/Simple.hs 
@@ -1,12 +0,0 @@---- blah-x :: (Int)-x = 1--(y) = 1--z :: t-z = do-  let-    a = 1-  return a
− tests/examples/ghc710/SimpleComplexTuple.hs 
@@ -1,3 +0,0 @@---foo ((-),(.))= (5,6)
− tests/examples/ghc710/SimpleDo.hs 
@@ -1,4 +0,0 @@--foo = do-  let    x = 1 -- a comment-  return x
− tests/examples/ghc710/SlidingDataClassDecl.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeSynonymInstances       #-}---instance HasTrie R2Basis where-    data R2Basis :->: x = R2Trie x x-    trie f = R2Trie (f XB) (f YB)-    untrie (R2Trie x _y) XB = x-    untrie (R2Trie _x y) YB = y-    enumerate (R2Trie x y)  = [(XB,x),(YB,y)]
− tests/examples/ghc710/SlidingDoClause.hs 
@@ -1,13 +0,0 @@----- :bounds narrowing 35-bndCom tenv args =-  do { (bound,size) <- getBounds fail args-     ; let get (s,m,ref) = do { n <- readRef ref; return(s++" = "++show n++ m)}-     ; if bound == ""-          then do { xs <- mapM get boundRef; warnM [Dl xs "\n"]}-          else case find (\ (nm,info,ref) -> nm==bound) boundRef of-                Just (_,_,ref) -> writeRef ref size-                Nothing -> fail ("Unknown bound '"++bound++"'")-     ; return tenv-     }
− tests/examples/ghc710/SlidingLambda.hs 
@@ -1,3 +0,0 @@-{-# LANGUAGE ImplicitParams #-}--foo = choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps
− tests/examples/ghc710/SlidingListComp.hs 
@@ -1,8 +0,0 @@---foo =-  [concatMap (\(n, f) -> [findPath copts v >>= f (listArg "ghc" as) | v <- listArg n as]) [-                    ("project", Update.scanProject),-                    ("file", Update.scanFile),-                    ("path", Update.scanDirectory)],-                map (Update.scanCabal (listArg "ghc" as)) cabals]
− tests/examples/ghc710/SlidingRecordSetter.hs 
@@ -1,4 +0,0 @@--selfQualify mod rsets = let defs = Set.fromList (map rs_name rsets)-                        in map (descend (f defs))-                               (map (\RS{..} -> RS{rs_name = qualify mod rs_name, ..}) rsets)
− tests/examples/ghc710/SpacesSplice.hs 
@@ -1,3 +0,0 @@-{-# LANGUAGE TemplateHaskell            #-}--makeLenses '' PostscriptFont
− tests/examples/ghc710/Splice.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-          MultiParamTypeClasses, TypeSynonymInstances #-}--module Splice where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH--foo $( return $ VarP $ mkName "x" ) = x-bar $( [p| x |] ) = x--baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |]---class Eq a => MyClass a-data Foo = Foo deriving Eq--instance MyClass Foo--data Bar = Bar-  deriving Eq--type Baz = Bar-instance MyClass Baz--data Quux a  = Quux a   deriving Eq-data Quux2 a = Quux2 a  deriving Eq-instance Eq a  => MyClass (Quux a)-instance Ord a => MyClass (Quux2 a)--class MyClass2 a b-instance MyClass2 Int Bool--makeLenses '' PostscriptFont--$(return [])--main = do-    putStrLn $(do { info <- reify ''MyClass; lift (pprint info) })-    print $(isInstance ''Eq [ConT ''Foo] >>= lift)-    print $(isInstance ''MyClass [ConT ''Foo] >>= lift)-    print $ not $(isInstance ''Show [ConT ''Foo] >>= lift)-    print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one-    print $(isInstance ''MyClass [ConT ''Baz] >>= lift)-    print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one-    print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one-    print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift)-    print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift)-
− tests/examples/ghc710/SpliceSemi.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType)
− tests/examples/ghc710/StaticPointers.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE StaticPointers #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Main where--import GHC.StaticPtr-import GHC.Word-import GHC.Generics-import Data.Data-import Data.Binary-import Data.ByteString--fact :: Int -> Int-fact 0 = 1-fact n = n * fact (n - 1)--main = do-  let sptr :: StaticPtr (Int -> Int)-      sptr = static fact-  print $ staticPtrInfo sptr-  print $ deRefStaticPtr sptr 10---- -----------------------------------------------------------------------type StaticKey1 = Fingerprint---- Defined in GHC.Fingerprint.-data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64-  deriving (Generic, Typeable)--staticKey :: StaticPtr a -> StaticKey1-staticKey = undefined--
− tests/examples/ghc710/Stmts.hs 
@@ -1,22 +0,0 @@-module Stmts where---- Make sure we get all the semicolons in statements--foo :: IO ()-foo = do-  do { ;;;; a }-  a--bar :: IO ()-bar = do-  { ;-    a ;;-    b-  }--baz :: IO ()-baz = do { ;; s ; s ; ; s ;; }--a = undefined-b = undefined-s = undefined
− tests/examples/ghc710/StrangeTypeClass.hs 
@@ -1,18 +0,0 @@----instance-  (-  ) => Elms Z ix where-  data Elm Z ix = ElmZ !ix-  type Arg Z = Z-  getArg !(ElmZ _) = Z-  getIdx !(ElmZ ix) = ix-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--foo :: (Eq a) => a-> Bool-foo = undefined--bar :: (   ) => a-> Bool-bar = undefined
− tests/examples/ghc710/Stream.hs 
@@ -1,156 +0,0 @@-module Stream (Stream, carry, addStream, rationalToStream,-                streamToFloat, addFiniteStream, negate', average) where--import Data.Ratio---type Digit = Integer-type Stream = [Integer]------ Convert from a Rational fraction to its stream representation-rationalToStream :: Rational -> Stream-rationalToStream x-        |t<1            = 0:rationalToStream t-        |otherwise      = 1:rationalToStream (t-1)-        where t = 2*x------- Convert from a stream to the Float value-streamToFloat :: Stream -> Float-streamToFloat x =  f x (1)--f :: Stream -> Integer -> Float-f [] n = 0-f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1)-------- Add two stream-addStream :: Stream -> Stream -> Stream-addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys))-                                where u = interim x1 x2 y1 y2-                                      c = carry x2 x3 y2 y3------ Compute carry, the C(i) value, given x(i) and y(i)-carry :: Digit -> Digit -> Digit -> Digit -> Digit-carry x1 x2 y1 y2-        |t>1                    =  1-        |t<(-1)                 = -1-        |t==1 && (minus1 x2 y2) =  0-        |t==1 && not (minus1 x2 y2) = 1-        |t==(-1) && (minus1 x2 y2) = -1-        |t==(-1) && not (minus1 x2 y2) = 0-        |t==0                           = 0-        where t = x1+y1------ Computer the interim sum, the U(i) value, given x(i), y(i) and c(i)-interim :: Digit -> Digit -> Digit -> Digit -> Digit-interim x1 x2 y1 y2-                |t>1                    =  0-                |t<(-1)                 = 0-                |t==1 && (minus1 x2 y2) =  1-                |t==1 && not (minus1 x2 y2) = -1-                |t==(-1) && (minus1 x2 y2) = 1-                |t==(-1) && not (minus1 x2 y2) = -1-                |t==0                           = 0-                where t = x1+y1------ Check if at least one of 2 digits is -1-minus1 :: Digit -> Digit -> Bool-minus1 x y = (x==(-1))|| (y==(-1))--------- Algin two stream so that they have the same length-align :: Stream -> Stream -> (Stream, Stream)-align xs ys-        |x>y            = (xs, (copy 0 (x-y)) ++ys)-        |otherwise      = ((copy 0 (y-x)) ++ xs, ys)-        where x = toInteger(length xs)-              y = toInteger(length ys)------ Generate a list of x-copy :: Integer -> Integer -> [Integer]-copy x n = [x| i<- [1..n]]---------- Add two finite stream (to add the integral part)-addFiniteStream :: Stream -> Stream -> Stream-addFiniteStream xs ys = add' u v-                        where (u,v) = align xs ys------ Utility function for addFinitieStream-add' :: Stream -> Stream -> Stream-add' u v = normalise (f u v)-       where f [] [] = []-             f (x:xs) (y:ys) = (x+y):f xs ys----- Normalise the sum-normalise :: Stream -> Stream-normalise = foldr f [0]-            where f x (y:ys) = (u:v:ys)-                              where u = (x+y) `div` 2-                                    v = (x+y) `mod` 2----- Negate a stream-negate' :: Stream -> Stream-negate' = map (*(-1))------ Compute average of two stream--- Using [-2,-1,0,1,2] to add, and then divide by 2-average :: Stream -> Stream -> Stream-average xs ys = div2 (add xs ys)----- Addition of two streams, using [-2,-1,0,1,2]-add :: Stream -> Stream -> Stream-add (x:xs) (y:ys) = (x+y):(add xs ys)----- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1]-div2 :: Stream -> Stream-div2 (2:xs)             = 1:div2 xs-div2 ((-2):xs)          = (-1):div2 xs-div2 (0:xs)             = 0:div2 xs-div2 (1:(-2):xs)        = div2 (0:0:xs)-div2 (1:(-1):xs)        = div2 (0:1:xs)-div2 (1:0:xs)           = div2 (0:2:xs)-div2 (1:1:xs)           = div2 (2:(-1):xs)-div2 (1:2:xs)           = div2 (2:0:xs)-div2 ((-1):(-2):xs)     = div2 ((-2):0:xs)-div2 ((-1):(-1):xs)     = div2 ((-2):1:xs)-div2 ((-1):0:xs)        = div2 (0:(-2):xs)-div2 ((-1):1:xs)        = div2 (0:(-1):xs)-div2 ((-1):2:xs)        = div2 (0:0:xs)----test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3)))
− tests/examples/ghc710/StrictLet.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE MagicHash #-}--{--If the (unboxed, hence strict) "let thunk =" would survive to the CallArity-stage, it might yield wrong results (eta-expanding thunk and hence "cond" would-be called multiple times).--It does not actually happen (CallArity sees a "case"), so this test just-safe-guards against future changes here.--}--import Debug.Trace-import GHC.Exts-import System.Environment--cond :: Int# -> Bool-cond x = trace ("cond called with " ++ show (I# x)) True-{-# NOINLINE cond #-}---bar (I# x) =-    let go n = let x = thunk n-               in case n of-                    100# -> I# x-                    _    -> go (n +# 1#)-    in go x-  where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#)---main = do-    args <- getArgs-    bar (length args) `seq` return ()
− tests/examples/ghc710/StringGap.hs 
@@ -1,8 +0,0 @@-module StringGap where---- based on https://www.reddit.com/r/haskelltil/comments/3duhdf/haskell_ignores_all_whitespace_enclosed_in/--foo = "lorem ipsum \-      \dolor sit amet"--bar = "lorem ipsum \     \dolor sit amet"
− tests/examples/ghc710/T10196.hs 
@@ -1,13 +0,0 @@-module T10196 where--data X = Xᵦ | Xᵤ | Xᵩ | Xᵢ | Xᵪ | Xᵣ--f :: Int-f =-  let xᵦ = 1-      xᵤ = xᵦ-      xᵩ = xᵤ-      xᵢ = xᵩ-      xᵪ = xᵢ-      xᵣ = xᵪ-  in xᵣ
− tests/examples/ghc710/T10942.hs 
@@ -1,6 +0,0 @@--- Let's trick you-{-# LANGUAGE ExplicitForAll #-}-module Test (foo) where--foo :: forall a. a -> a-foo x = x
− tests/examples/ghc710/T2388.hs 
@@ -1,14 +0,0 @@-module T2388 where--import Data.Bits-import Data.Word-import Data.Int--test1 :: Word32 -> Char-test1 w | w .&. 0x80000000 /= 0 = 'a'-test1 _ = 'b'---- this should use a testq instruction on x86_64-test2 :: Int64 -> Char-test2 w | w .&. (-3) /= 0 = 'a'-test2 _ = 'b'
− tests/examples/ghc710/T3132.hs 
@@ -1,6 +0,0 @@-module T3132 where--import Data.Array.Unboxed--step :: UArray Int Double -> [Double]-step y = [y!1 + y!0]
− tests/examples/ghc710/T5951.hs 
@@ -1,11 +0,0 @@-module T5951 where--class A a-class B b-class C c--instance-       A =>-       B =>-       C where-         foo = undefined
− tests/examples/ghc710/T7918A.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module T7918A where--import Language.Haskell.TH-import Language.Haskell.TH.Quote--qq = QuasiQuoter {-         quoteExp  = \str -> case str of-                                "e1" -> [| True |]-                                "e2" -> [| id True |]-                                "e3" -> [| True || False |]-                                "e4" -> [| False |]-       , quoteType = \str -> case str of-                                "t1" -> [t| Bool |]-                                "t2" -> [t| Maybe Bool |]-                                "t3" -> [t| Either Bool Int |]-                                "t4" -> [t| Int |]-       , quotePat  = let x = VarP (mkName "x")-                         y = VarP (mkName "y")-                     in \str -> case str of-                                  "p1" -> return $ x-                                  "p2" -> return $ ConP 'Just [x]-                                  "p3" -> return $ TupP [x, y]-                                  "p4" -> return $ y-       , quoteDec  = undefined-       }
− tests/examples/ghc710/TH.hs 
@@ -1,71 +0,0 @@-{-# Language TemplateHaskell #-}---- from https://ocharles.org.uk/blog/guest-posts/2014-12-22-template-haskell.html--import Language.Haskell.TH--e1 :: IO Exp-e1 = runQ [| 1 + 2 |]--e2 :: Integer-e2 = $( return (InfixE (Just (LitE (IntegerL 1)))-                       (VarE (mkName "+"))-                       (Just (LitE (IntegerL 2)))-               )-      )--fibs :: [Integer]-fibs = 0 : 1 : zipWith (+) fibs (tail fibs)--fibQ :: Int -> Q Exp-fibQ n = [| fibs !! n |]---- e3 gives stage restriction, need to import this module to get it--- e3 = $(fibQ 22)--e4 = $(runQ [| fibs !! $( [| 8 |]) |])--e5 :: IO Exp-e5 = runQ [| 1 + 2 |]--e6 :: IO [Dec]-e6 = runQ [d|x = 5|]--e7 :: IO Type-e7 = runQ [t|Int|]--e8 :: IO Pat-e8 = runQ [p|(x,y)|]--myExp :: Q Exp; myExp = runQ [| 1 + 2 |]--e9 = runQ(myExp) >>= putStrLn.pprint---- -----------------------------------------------------------------------isPrime :: (Integral a) => a -> Bool-isPrime k | k <=1 = False | otherwise = not $ elem 0 (map (mod k)[2..k-1])--nextPrime :: (Integral a) => a -> a-nextPrime n | isPrime n = n | otherwise = nextPrime (n+1)---- returns a list of all primes between n and m, using the nextPrime function-doPrime :: (Integral a) => a -> a -> [a]-doPrime n m-        | curr > m = []-        | otherwise = curr:doPrime (curr+1) m-        where curr = nextPrime n---- and our Q expression-primeQ :: Int -> Int -> Q Exp-primeQ n m = [| doPrime n m |]---- stage restriction on e10--- e10 = $(primeQ 0 67)---- -----------------------------------------------------------------------e11 = $(stringE . show =<< reify ''Bool)---- stage restriction e12--- e12 = $(stringE . show =<< reify 'primeQ)
− tests/examples/ghc710/THMonadInstance.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE-  TemplateHaskell,-  MultiParamTypeClasses,-  FunctionalDependencies,-  UndecidableInstances-  #-}---genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec]-genCodingInstance ht ctn chs = do-  let n = const Nothing-  [d|-    instance Monad m => EncodeM m $(ht) $(conT ctn) where-      encodeM h = return $ $(-        caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ]-       )--    instance Monad m => DecodeM m $(ht) $(conT ctn) where-      decodeM c = return $ $(-        caseE [| c |] [ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs ]-       )-   |]
− tests/examples/ghc710/TemplateHaskell.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}--foo = $footemplate--makeSplices ''Foo--old = $(old)--bar = $$bartemplate--bar = [e| quasi |]--bar = [| quasi |]--baz = [quoter| quasi |]--[t| Map.Map T.Text $tc |]--{-# ANN module $([| 1 :: Int |]) #-}--foo = [t| HT.HashTable $(varT s) Int-                   (Result $(varT str) $tt) |]--objc_emit--objc_import [""]---$(do-    return $ foreignDecl cName ("build" ++ a) ([[t| Ptr Builder |]] ++ ats ++ [[t| CString |]]) [t| Ptr $(rt) |]- )--foo = do-  let elemSize = [|sizeOf (undefined :: $(elemType))|]-      alignment _ = alignment (undefined :: $(elemType))-  return bar--class QQExp a b where-  qqExp x = [||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]--class QQExp2 a b where-  qqExp x = [e||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]
− tests/examples/ghc710/TransformListComp.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE TransformListComp #-}--oldest :: [Int] -> [String]-oldest tbl = [ "str"-             | n <- tbl-             , then id-             ]
− tests/examples/ghc710/Trit.hs 
@@ -1,112 +0,0 @@-module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction',-                neg, addTrits, subTrits, shiftLeft, shiftRight, multiply-                ) where--import Stream-import Utilities-import Data.Ratio--type Mantissa = Stream-type Fraction = Stream-type Trit     = (Mantissa, Fraction)----- Convert from a Rational number to its Trit representation (Integral, Fraction)-rationalToTrit :: Rational -> Trit-rationalToTrit x-                |x<1            = ([0], rationalToStream x)-                |otherwise      = (u', rationalToStream v)-                where   u = n `div` d-                        u' = toBinary u-                        v = x - (toRational u)-                        n = numerator x-                        d = denominator x----- Get the integral part of Trit-getIntegral :: Trit -> Mantissa-getIntegral = fst------ Get the fraction part of Trit, with n digit of the stream-getFraction :: Int -> Trit -> Stream-getFraction n = take n. snd----- Get the fraction part of Trit-getFraction' :: Trit -> Stream-getFraction' = snd------ Negate a Trit-neg :: Trit -> Trit-neg (a, b) = (negate' a, negate' b)------ Add two Trits-addTrits :: Trit -> Trit -> Trit-addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys))-                                           where u' = addFiniteStream m1 m2-                                                 c = [carry x1 x2 y1 y2]-                                                 u = addFiniteStream u' c------ Substraction of 2 Trits-subTrits :: Trit -> Trit -> Trit-subTrits x y = addTrits x (neg y)------ Shift left = *2 opertaion with Trit-shiftLeft :: Trit -> Trit-shiftLeft (x, (y:ys)) = (x++ [y], ys)----- Shift right = /2 operation with Trit-shiftRight :: Trit -> Integer -> Trit-shiftRight (x, xs) 1 = (init x, (u:xs))-                    where u = last x-shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1)-                    where u = last x------ Multiply a Trit stream by 1,0 or -1, simply return the stream-mulOneDigit :: Integer -> Stream -> Stream-mulOneDigit x xs-              |x==1      = xs-              |x==0      = zero'-              |otherwise = negate' xs-              where zero' = (0:zero')--------- Multiplication of two streams-multiply :: Stream -> Stream -> Stream-multiply (a0:a1:x) (b0:b1:y) = average p q-                               where p = average (a1*b0: (average (mulOneDigit b1 x)-                                                                 (mulOneDigit a1 y)))-                                                 (average (mulOneDigit b0 x)-                                                          (mulOneDigit a0 y))-                                     q = (a0*b0:a0*b1:a1*b1:(multiply x y))-----start0 = take 30 (multiply (rationalToStream (1%2)) zo)--zo :: Stream-zo = 1:(-1):zero-     where zero = 0:zero--start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4))))---
− tests/examples/ghc710/Tuple.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE TupleSections #-}--baz = (1, "hello", 6.5,,) 'a' (Just ())-
− tests/examples/ghc710/TupleSections.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE TupleSections #-}--foo = do-  liftIO $ atomicModifyIORef ciTokens ((,()) . f)-  liftIO $ atomicModifyIORef ciTokens (((),) . f)-  liftIO $ atomicModifyIORef ciTokens ((,) . f)---- | Make bilateral dictionary from PoliMorf.-mkPoli :: [P.Entry] -> Poli-mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)--foo = baz-  where-    _1 = ((,Nothing,Nothing,Nothing,Nothing,Nothing) . Just <$>)-    _2 = ((Nothing,,Nothing,Nothing,Nothing,Nothing) . Just <$>)-    _3 = ((Nothing,Nothing,,Nothing,Nothing,Nothing) . Just <$>)-    _4 = ((Nothing,Nothing,Nothing,,Nothing,Nothing) . Just <$>)-    _5 = ((Nothing,Nothing,Nothing,Nothing,,Nothing) . Just <$>)-    _6 = ((Nothing,Nothing,Nothing,Nothing,Nothing,) . Just <$>)--foo = (,,(),,,())
− tests/examples/ghc710/TypeBrackets.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--foo (f :: (Maybe t -> Int)) =-     undefined--type (((f `ObjectsFUnder` a))) = ConstF f a :/\: f-type   (f `ObjectsFOver`  a)   = f :/\: ConstF f a--type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a-type (c `ObjectsOver`  a) = Id c `ObjectsFOver`  a-
− tests/examples/ghc710/TypeBrackets2.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleInstances #-}----- | The style and color attributes can either be the terminal defaults. Or be equivalent to the--- previously applied style. Or be a specific value.-data MaybeDefault v where-    Default :: MaybeDefault v-    KeepCurrent :: MaybeDefault v-    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v-    SetTo2 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v--bar :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a])-baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v--instance Dsp (S n) where-  data (ASig (S n)) = S_A CVar-  data (KSig (S n)) = S_K CVar-  data (INum (S n)) = S_I CVar-  getSr    = fst <$> ask-  getKsmps = snd <$> ask
− tests/examples/ghc710/TypeBrackets4.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}---type family ((a :: Bool) || (b :: Bool)) :: Bool-type instance 'True  || a = 'True-type instance a || 'True  = 'True-type instance 'False || a = a-type instance a || 'False = a
− tests/examples/ghc710/TypeFamilies2.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--type family (++) (a :: [k]) (b :: [k]) :: [k] where-    '[]       ++ b = b-    (a ': as) ++ b = a ': (as ++ b)--type family F a :: * -> * -> *-type instance F Int = (->)-type instance F Char = ( ,  )
− tests/examples/ghc710/TypeInstance.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}--class TrieKey k where-  type instance TrieRep k = TrieRepDefault k
− tests/examples/ghc710/TypeOperators.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}---- From https://ocharles.org.uk/blog/posts/2014-12-08-type-operators.html--import Data.String--data I a = I { unI :: a }-data Var a x = Var { unK :: a }--infixr 8 +-data ((f + g)) a = InL (f a) | InR (g a)--- data (f + g) a = InL (f a) | InR (g a)--class sub :<: sup where-  inj :: sub a -> sup a--instance (sym :<: sym) where-  inj = id--instance (sym1 :<: (sym1 + sym2)) where inj = InL--instance (sym1 :<: sym3) => (sym1 :<: (sym2 + sym3)) where-  inj = InR . inj--instance (I :<: g, IsString s) => IsString ((f + g) s) where-  fromString = inj . I . fromString--var :: (Var a :<: f) => a -> f e-var = inj . Var--elim :: (I :<: f) => (a -> b) -> (Var a + f) b -> f b-elim eval f =-  case f of-    InL (Var xs) -> inj (I (eval xs))-    InR g        -> g------------------------------------------------------------------------------------data UserVar = UserName--data ChristmasVar = ChristmasPresent--email :: [(Var UserVar + Var ChristmasVar + I) String]-email = [ "Dear "-        , var UserName-        , ", thank you for your recent email to Santa & Santa Inc."-        , "You have asked for a: "-        , var ChristmasPresent-        ]--main :: IO ()-main =-  do name <- getLine-     present <- getLine-     putStrLn (concatMap (unI .-                          (elim (\ChristmasPresent -> present) .-                           elim (\UserName -> name)))-                         email)--{---*Main> main-Ollie-Lambda Necklace-Dear Ollie, thank you for your recent email to Santa & Santa Inc.You have asked for a: Lambda Necklace---}
− tests/examples/ghc710/TypeSignature.hs 
@@ -1,12 +0,0 @@-module TypeSignature where--{- Lifting baz to the top level should bring in xx and a as parameters,-   and update the signature to include these--}-foo a = (baz xx a)-  where-    xx :: Int -> Int -> Int-    xx p1 p2 = p1 + p2--baz :: (Int -> Int -> Int) -> Int ->Int-baz xx a = xx 1 a
− tests/examples/ghc710/TypeSignatureParens.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--pTokenCost :: forall loc state a .((Show a, Eq a,  loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str  a state loc) [a])-pTokenCost as cost = 5--pTokenCostStr :: forall a .((Show a) => [a] -> Int -> String)-pTokenCostStr as cost = "5"
− tests/examples/ghc710/TypeSynOperator.hs 
@@ -1,3 +0,0 @@-{-# LANGUAGE TypeOperators #-}--type a :-> t = a
− tests/examples/ghc710/TypeSynParens.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--class Compilable a where-   type CompileResult a :: *--instance Compilable a => Compilable [a] where-   type CompileResult [a] = [CompileResult a]--instance Compilable a => Compilable (Maybe a) where-   type CompileResult (Maybe a) = Maybe (CompileResult a)--instance Compilable InterpreterStmt where-   type CompileResult InterpreterStmt = [Hask.Stmt]--instance Compilable ModuleSpan where-   type CompileResult ModuleSpan = Hask.Module--instance Compilable StatementSpan where-   type (CompileResult StatementSpan) = [Stmt]
− tests/examples/ghc710/Unboxed.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE UnboxedTuples #-}-module Layout.Unboxed where--f1 :: (Num a1, Num a) => a -> a1 -> (# , #) a a1-f1 x y = (# , #) (x+1) (y-1)--f2 x y z  = (# ,, #) x y z
− tests/examples/ghc710/Undefined10.hs 
@@ -1,643 +0,0 @@-{--    Copyright 2013-2015 Mario Blazevic--    License: BSD3 (see BSD3-LICENSE.txt file)--}---- | This module defines the 'FactorialMonoid' class and some of its instances.-----{-# LANGUAGE Haskell2010, Trustworthy #-}--module Data.Monoid.Factorial (-   -- * Classes-   FactorialMonoid(..), StableFactorialMonoid,-   -- * Monad function equivalents-   mapM, mapM_-   )-where--import Prelude hiding (break, drop, dropWhile, foldl, foldMap, foldr, last, length, map, mapM, mapM_, max, min,-                       null, reverse, span, splitAt, take, takeWhile)--import Control.Arrow (first)-import qualified Control.Monad as Monad-import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))-import qualified Data.Foldable as Foldable-import qualified Data.List as List-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Lazy as LazyByteString-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LazyText-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Map as Map-import qualified Data.Sequence as Sequence-import qualified Data.Set as Set-import qualified Data.Vector as Vector-import Data.Int (Int64)-import Data.Numbers.Primes (primeFactors)--import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)---- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of--- a 'Product' are literally its prime factors:------ prop> factors (Product 12) == [Product 2, Product 2, Product 3]------ Factors of a list are /not/ its elements but all its single-item sublists:------ prop> factors "abc" == ["a", "b", "c"]------ The methods of this class satisfy the following laws:------ > mconcat . factors == id--- > null == List.null . factors--- > List.all (\prime-> factors prime == [prime]) . factors--- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix)--- > reverse == mconcat . List.reverse . factors--- > primePrefix == maybe mempty fst . splitPrimePrefix--- > primeSuffix == maybe mempty snd . splitPrimeSuffix--- > inits == List.map mconcat . List.tails . factors--- > tails == List.map mconcat . List.tails . factors--- > foldl f a == List.foldl f a . factors--- > foldl' f a == List.foldl' f a . factors--- > foldr f a == List.foldr f a . factors--- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m)--- > List.all (List.all (not . pred) . factors) . split pred--- > mconcat . intersperse prime . split (== prime) == id--- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m)--- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ())--- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0)--- > let (prefix, suffix, s') = spanMaybe s f m--- >     foldMaybe = foldl g (Just s)--- >     g s m = s >>= flip f m--- > in all ((Nothing ==) . foldMaybe) (inits prefix)--- >    && prefix == last (filter (isJust . foldMaybe) $ inits m)--- >    && Just s' == foldMaybe prefix--- >    && m == prefix <> suffix------ A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should--- be implemented only for performance reasons.-class MonoidNull m => FactorialMonoid m where-   -- | Returns a list of all prime factors; inverse of mconcat.-   factors :: m -> [m]-   -- | The prime prefix, 'mempty' if none.-   primePrefix :: m -> m-   -- | The prime suffix, 'mempty' if none.-   primeSuffix :: m -> m-   -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'.-   splitPrimePrefix :: m -> Maybe (m, m)-   -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'.-   splitPrimeSuffix :: m -> Maybe (m, m)-   -- | Returns the list of all prefixes of the argument, 'mempty' first.-   inits :: m -> [m]-   -- | Returns the list of all suffixes of the argument, 'mempty' last.-   tails :: m -> [m]-   -- | Like 'List.foldl' from "Data.List" on the list of 'primes'.-   foldl :: (a -> m -> a) -> a -> m -> a-   -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'.-   foldl' :: (a -> m -> a) -> a -> m -> a-   -- | Like 'List.foldr' from "Data.List" on the list of 'primes'.-   foldr :: (m -> a -> a) -> a -> m -> a-   -- | The 'length' of the list of 'primes'.-   length :: m -> Int-   -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the-   -- structure elements.-   foldMap :: Monoid n => (m -> n) -> m -> n-   -- | Like 'List.span' from "Data.List" on the list of 'primes'.-   span :: (m -> Bool) -> m -> (m, m)-   -- | Equivalent to 'List.break' from "Data.List".-   break :: (m -> Bool) -> m -> (m, m)-   -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes-   -- satisfying the predicate are not a part of the result.-   split :: (m -> Bool) -> m -> [m]-   -- | Equivalent to 'List.takeWhile' from "Data.List".-   takeWhile :: (m -> Bool) -> m -> m-   -- | Equivalent to 'List.dropWhile' from "Data.List".-   dropWhile :: (m -> Bool) -> m -> m-   -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.-   spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)-   -- | Strict version of 'spanMaybe'.-   spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)-   -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'.-   splitAt :: Int -> m -> (m, m)-   -- | Equivalent to 'List.drop' from "Data.List".-   drop :: Int -> m -> m-   -- | Equivalent to 'List.take' from "Data.List".-   take :: Int -> m -> m-   -- | Equivalent to 'List.reverse' from "Data.List".-   reverse :: m -> m--   factors = List.unfoldr splitPrimePrefix-   primePrefix = maybe mempty fst . splitPrimePrefix-   primeSuffix = maybe mempty snd . splitPrimeSuffix-   splitPrimePrefix x = case factors x-                        of [] -> Nothing-                           prefix : rest -> Just (prefix, mconcat rest)-   splitPrimeSuffix x = case factors x-                        of [] -> Nothing-                           fs -> Just (mconcat (List.init fs), List.last fs)-   inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty]-   tails m = m : maybe [] (tails . snd) (splitPrimePrefix m)-   foldl f f0 = List.foldl f f0 . factors-   foldl' f f0 = List.foldl' f f0 . factors-   foldr f f0 = List.foldr f f0 . factors-   length = List.length . factors-   foldMap f = foldr (mappend . f) mempty-   span p m0 = spanAfter id m0-      where spanAfter f m = case splitPrimePrefix m-                            of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest-                               _ -> (f mempty, m)-   break = span . (not .)-   spanMaybe s0 f m0 = spanAfter id s0 m0-      where spanAfter g s m = case splitPrimePrefix m-                              of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest-                                                    | otherwise -> (g mempty, m, s)-                                 Nothing -> (m0, m, s)-   spanMaybe' s0 f m0 = spanAfter id s0 m0-      where spanAfter g s m = seq s $-                              case splitPrimePrefix m-                              of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest-                                                    | otherwise -> (g mempty, m, s)-                                 Nothing -> (m0, m, s)-   split p m = prefix : splitRest-      where (prefix, rest) = break p m-            splitRest = case splitPrimePrefix rest-                        of Nothing -> []-                           Just (_, tl) -> split p tl-   takeWhile p = fst . span p-   dropWhile p = snd . span p-   splitAt n0 m0 | n0 <= 0 = (mempty, m0)-                 | otherwise = split' n0 id m0-      where split' 0 f m = (f mempty, m)-            split' n f m = case splitPrimePrefix m-                           of Nothing -> (f mempty, m)-                              Just (prime, rest) -> split' (pred n) (f . mappend prime) rest-   drop n p = snd (splitAt n p)-   take n p = fst (splitAt n p)-   reverse = mconcat . List.reverse . factors-   {-# MINIMAL factors | splitPrimePrefix #-}---- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law:------ > factors (a <> b) == factors a <> factors b-class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m--instance FactorialMonoid () where-   factors () = []-   primePrefix () = ()-   primeSuffix () = ()-   splitPrimePrefix () = Nothing-   splitPrimeSuffix () = Nothing-   length () = 0-   reverse = id--instance FactorialMonoid a => FactorialMonoid (Dual a) where-   factors (Dual a) = fmap Dual (reverse $ factors a)-   length (Dual a) = length a-   primePrefix (Dual a) = Dual (primeSuffix a)-   primeSuffix (Dual a) = Dual (primePrefix a)-   splitPrimePrefix (Dual a) = case splitPrimeSuffix a-                               of Nothing -> Nothing-                                  Just (p, s) -> Just (Dual s, Dual p)-   splitPrimeSuffix (Dual a) = case splitPrimePrefix a-                               of Nothing -> Nothing-                                  Just (p, s) -> Just (Dual s, Dual p)-   inits (Dual a) = fmap Dual (reverse $ tails a)-   tails (Dual a) = fmap Dual (reverse $ inits a)-   reverse (Dual a) = Dual (reverse a)--instance (Integral a, Eq a) => FactorialMonoid (Sum a) where-   primePrefix (Sum a) = Sum (signum a )-   primeSuffix = primePrefix-   splitPrimePrefix (Sum 0) = Nothing-   splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a))-   splitPrimeSuffix (Sum 0) = Nothing-   splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a))-   length (Sum a) = abs (fromIntegral a)-   reverse = id--instance Integral a => FactorialMonoid (Product a) where-   factors (Product a) = List.map Product (primeFactors a)-   reverse = id--instance FactorialMonoid a => FactorialMonoid (Maybe a) where-   factors Nothing = []-   factors (Just a) | null a = [Just a]-                    | otherwise = List.map Just (factors a)-   length Nothing = 0-   length (Just a) | null a = 1-                   | otherwise = length a-   reverse = fmap reverse--instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where-   factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b)-   primePrefix (a, b) | null a = (a, primePrefix b)-                      | otherwise = (primePrefix a, mempty)-   primeSuffix (a, b) | null b = (primeSuffix a, b)-                      | otherwise = (mempty, primeSuffix b)-   splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b)-                             of (Just (ap, as), _) -> Just ((ap, mempty), (as, b))-                                (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs))-                                (Nothing, Nothing) -> Nothing-   splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b)-                             of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs))-                                (Just (ap, as), Nothing) -> Just ((ap, b), (as, b))-                                (Nothing, Nothing) -> Nothing-   inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b)-   tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b)-   foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y-      where f1 a = f a . fromFst-            f2 a = f a . fromSnd-   foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y-      where f1 a = f a . fromFst-            f2 a = f a . fromSnd-            a' = foldl' f1 a0 x-   foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x-   foldMap f (x, y) = foldMap (f . fromFst) x `mappend` foldMap (f . fromSnd) y-   length (a, b) = length a + length b-   span p (x, y) = ((xp, yp), (xs, ys))-      where (xp, xs) = span (p . fromFst) x-            (yp, ys) | null xs = span (p . fromSnd) y-                     | otherwise = (mempty, y)-   spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)-                         | otherwise = ((xp, mempty), (xs, y), s1)-     where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x-           (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y-   spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)-                          | otherwise = ((xp, mempty), (xs, y), s1)-     where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x-           (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y-   split p (x0, y0) = fst $ List.foldr combine (ys, False) xs-      where xs = List.map fromFst $ split (p . fromFst) x0-            ys = List.map fromSnd $ split (p . fromSnd) y0-            combine x (~(y:rest), False) = (mappend x y : rest, True)-            combine x (rest, True) = (x:rest, True)-   splitAt n (x, y) = ((xp, yp), (xs, ys))-      where (xp, xs) = splitAt n x-            (yp, ys) | null xs = splitAt (n - length x) y-                     | otherwise = (mempty, y)-   reverse (a, b) = (reverse a, reverse b)--{-# INLINE fromFst #-}-fromFst :: Monoid b => a -> (a, b)-fromFst a = (a, mempty)--{-# INLINE fromSnd #-}-fromSnd :: Monoid a => b -> (a, b)-fromSnd b = (mempty, b)--instance FactorialMonoid [x] where-   factors xs = List.map (:[]) xs-   primePrefix [] = []-   primePrefix (x:_) = [x]-   primeSuffix [] = []-   primeSuffix xs = [List.last xs]-   splitPrimePrefix [] = Nothing-   splitPrimePrefix (x:xs) = Just ([x], xs)-   splitPrimeSuffix [] = Nothing-   splitPrimeSuffix xs = Just (splitLast id xs)-      where splitLast f last@[_] = (f [], last)-            splitLast f ~(x:rest) = splitLast (f . (x:)) rest-   inits = List.inits-   tails = List.tails-   foldl _ a [] = a-   foldl f a (x:xs) = foldl f (f a [x]) xs-   foldl' _ a [] = a-   foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs-   foldr _ f0 [] = f0-   foldr f f0 (x:xs) = f [x] (foldr f f0 xs)-   length = List.length-   foldMap f = mconcat . List.map (f . (:[]))-   break f = List.break (f . (:[]))-   span f = List.span (f . (:[]))-   dropWhile f = List.dropWhile (f . (:[]))-   takeWhile f = List.takeWhile (f . (:[]))-   spanMaybe s0 f l = (prefix' [], suffix' [], s')-      where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l-            g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True)-                                           | otherwise = (prefix, suffix . (x:), s1, False)-   spanMaybe' s0 f l = (prefix' [], suffix' [], s')-      where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l-            g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True)-                                           | otherwise = (prefix, suffix . (x:), s1, False)-   splitAt = List.splitAt-   drop = List.drop-   take = List.take-   reverse = List.reverse--instance FactorialMonoid ByteString.ByteString where-   factors x = factorize (ByteString.length x) x-      where factorize 0 _ = []-            factorize n xs = xs1 : factorize (pred n) xs'-              where (xs1, xs') = ByteString.splitAt 1 xs-   primePrefix = ByteString.take 1-   primeSuffix x = ByteString.drop (ByteString.length x - 1) x-   splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x)-   splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x)-   inits = ByteString.inits-   tails = ByteString.tails-   foldl f = ByteString.foldl f'-      where f' a byte = f a (ByteString.singleton byte)-   foldl' f = ByteString.foldl' f'-      where f' a byte = f a (ByteString.singleton byte)-   foldr f = ByteString.foldr (f . ByteString.singleton)-   break f = ByteString.break (f . ByteString.singleton)-   span f = ByteString.span (f . ByteString.singleton)-   spanMaybe s0 f b = case ByteString.foldr g id b (0, s0)-                      of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')-      where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s')-                            | otherwise = (i, s)-   spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0)-                       of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')-      where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')-                            | otherwise = (i, s)-   dropWhile f = ByteString.dropWhile (f . ByteString.singleton)-   takeWhile f = ByteString.takeWhile (f . ByteString.singleton)-   length = ByteString.length-   split f = ByteString.splitWith f'-      where f' = f . ByteString.singleton-   splitAt = ByteString.splitAt-   drop = ByteString.drop-   take = ByteString.take-   reverse = ByteString.reverse--instance FactorialMonoid LazyByteString.ByteString where-   factors x = factorize (LazyByteString.length x) x-      where factorize 0 _ = []-            factorize n xs = xs1 : factorize (pred n) xs'-               where (xs1, xs') = LazyByteString.splitAt 1 xs-   primePrefix = LazyByteString.take 1-   primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x-   splitPrimePrefix x = if LazyByteString.null x then Nothing-                        else Just (LazyByteString.splitAt 1 x)-   splitPrimeSuffix x = if LazyByteString.null x then Nothing-                        else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x)-   inits = LazyByteString.inits-   tails = LazyByteString.tails-   foldl f = LazyByteString.foldl f'-      where f' a byte = f a (LazyByteString.singleton byte)-   foldl' f = LazyByteString.foldl' f'-      where f' a byte = f a (LazyByteString.singleton byte)-   foldr f = LazyByteString.foldr f'-      where f' byte a = f (LazyByteString.singleton byte) a-   length = fromIntegral . LazyByteString.length-   break f = LazyByteString.break (f . LazyByteString.singleton)-   span f = LazyByteString.span (f . LazyByteString.singleton)-   spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0)-                      of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')-      where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s')-                            | otherwise = (i, s)-   spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0)-                       of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')-      where g w cont (i, s)-              | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')-              | otherwise = (i, s)-   dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton)-   takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton)-   split f = LazyByteString.splitWith f'-      where f' = f . LazyByteString.singleton-   splitAt = LazyByteString.splitAt . fromIntegral-   drop n = LazyByteString.drop (fromIntegral n)-   take n = LazyByteString.take (fromIntegral n)-   reverse = LazyByteString.reverse--instance FactorialMonoid Text.Text where-   factors = Text.chunksOf 1-   primePrefix = Text.take 1-   primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x)-   splitPrimePrefix = fmap (first Text.singleton) . Text.uncons-   splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x))-   inits = Text.inits-   tails = Text.tails-   foldl f = Text.foldl f'-      where f' a char = f a (Text.singleton char)-   foldl' f = Text.foldl' f'-      where f' a char = f a (Text.singleton char)-   foldr f = Text.foldr f'-      where f' char a = f (Text.singleton char) a-   length = Text.length-   span f = Text.span (f . Text.singleton)-   break f = Text.break (f . Text.singleton)-   dropWhile f = Text.dropWhile (f . Text.singleton)-   takeWhile f = Text.takeWhile (f . Text.singleton)-   spanMaybe s0 f t = case Text.foldr g id t (0, s0)-                      of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')-      where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s')-                            | otherwise = (i, s)-   spanMaybe' s0 f t = case Text.foldr g id t (0, s0)-                       of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')-      where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')-                            | otherwise = (i, s)-   split f = Text.split f'-      where f' = f . Text.singleton-   splitAt = Text.splitAt-   drop = Text.drop-   take = Text.take-   reverse = Text.reverse--instance FactorialMonoid LazyText.Text where-   factors = LazyText.chunksOf 1-   primePrefix = LazyText.take 1-   primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x)-   splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons-   splitPrimeSuffix x = if LazyText.null x-                        then Nothing-                        else Just (LazyText.init x, LazyText.singleton (LazyText.last x))-   inits = LazyText.inits-   tails = LazyText.tails-   foldl f = LazyText.foldl f'-      where f' a char = f a (LazyText.singleton char)-   foldl' f = LazyText.foldl' f'-      where f' a char = f a (LazyText.singleton char)-   foldr f = LazyText.foldr f'-      where f' char a = f (LazyText.singleton char) a-   length = fromIntegral . LazyText.length-   span f = LazyText.span (f . LazyText.singleton)-   break f = LazyText.break (f . LazyText.singleton)-   dropWhile f = LazyText.dropWhile (f . LazyText.singleton)-   takeWhile f = LazyText.takeWhile (f . LazyText.singleton)-   spanMaybe s0 f t = case LazyText.foldr g id t (0, s0)-                      of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')-      where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s')-                            | otherwise = (i, s)-   spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0)-                       of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')-      where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')-                            | otherwise = (i, s)-   split f = LazyText.split f'-      where f' = f . LazyText.singleton-   splitAt = LazyText.splitAt . fromIntegral-   drop n = LazyText.drop (fromIntegral n)-   take n = LazyText.take (fromIntegral n)-   reverse = LazyText.reverse--instance Ord k => FactorialMonoid (Map.Map k v) where-   factors = List.map (uncurry Map.singleton) . Map.toAscList-   primePrefix map | Map.null map = map-                   | otherwise = uncurry Map.singleton $ Map.findMin map-   primeSuffix map | Map.null map = map-                   | otherwise = uncurry Map.singleton $ Map.findMax map-   splitPrimePrefix = fmap singularize . Map.minViewWithKey-      where singularize ((k, v), rest) = (Map.singleton k v, rest)-   splitPrimeSuffix = fmap singularize . Map.maxViewWithKey-      where singularize ((k, v), rest) = (rest, Map.singleton k v)-   foldl f = Map.foldlWithKey f'-      where f' a k v = f a (Map.singleton k v)-   foldl' f = Map.foldlWithKey' f'-      where f' a k v = f a (Map.singleton k v)-   foldr f = Map.foldrWithKey f'-      where f' k v a = f (Map.singleton k v) a-   length = Map.size-   reverse = id--instance FactorialMonoid (IntMap.IntMap a) where-   factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList-   primePrefix map | IntMap.null map = map-                   | otherwise = uncurry IntMap.singleton $ IntMap.findMin map-   primeSuffix map | IntMap.null map = map-                   | otherwise = uncurry IntMap.singleton $ IntMap.findMax map-   splitPrimePrefix = fmap singularize . IntMap.minViewWithKey-      where singularize ((k, v), rest) = (IntMap.singleton k v, rest)-   splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey-      where singularize ((k, v), rest) = (rest, IntMap.singleton k v)-   foldl f = IntMap.foldlWithKey f'-      where f' a k v = f a (IntMap.singleton k v)-   foldl' f = IntMap.foldlWithKey' f'-      where f' a k v = f a (IntMap.singleton k v)-   foldr f = IntMap.foldrWithKey f'-      where f' k v a = f (IntMap.singleton k v) a-   length = IntMap.size-   reverse = id--instance FactorialMonoid IntSet.IntSet where-   factors = List.map IntSet.singleton . IntSet.toAscList-   primePrefix set | IntSet.null set = set-                   | otherwise = IntSet.singleton $ IntSet.findMin set-   primeSuffix set | IntSet.null set = set-                   | otherwise = IntSet.singleton $ IntSet.findMax set-   splitPrimePrefix = fmap singularize . IntSet.minView-      where singularize (min, rest) = (IntSet.singleton min, rest)-   splitPrimeSuffix = fmap singularize . IntSet.maxView-      where singularize (max, rest) = (rest, IntSet.singleton max)-   foldl f = IntSet.foldl f'-      where f' a b = f a (IntSet.singleton b)-   foldl' f = IntSet.foldl' f'-      where f' a b = f a (IntSet.singleton b)-   foldr f = IntSet.foldr f'-      where f' a b = f (IntSet.singleton a) b-   length = IntSet.size-   reverse = id--instance FactorialMonoid (Sequence.Seq a) where-   factors = List.map Sequence.singleton . Foldable.toList-   primePrefix = Sequence.take 1-   primeSuffix q = Sequence.drop (Sequence.length q - 1) q-   splitPrimePrefix q = case Sequence.viewl q-                        of Sequence.EmptyL -> Nothing-                           hd Sequence.:< rest -> Just (Sequence.singleton hd, rest)-   splitPrimeSuffix q = case Sequence.viewr q-                        of Sequence.EmptyR -> Nothing-                           rest Sequence.:> last -> Just (rest, Sequence.singleton last)-   inits = Foldable.toList . Sequence.inits-   tails = Foldable.toList . Sequence.tails-   foldl f = Foldable.foldl f'-      where f' a b = f a (Sequence.singleton b)-   foldl' f = Foldable.foldl' f'-      where f' a b = f a (Sequence.singleton b)-   foldr f = Foldable.foldr f'-      where f' a b = f (Sequence.singleton a) b-   span f = Sequence.spanl (f . Sequence.singleton)-   break f = Sequence.breakl (f . Sequence.singleton)-   dropWhile f = Sequence.dropWhileL (f . Sequence.singleton)-   takeWhile f = Sequence.takeWhileL (f . Sequence.singleton)-   spanMaybe s0 f b = case Foldable.foldr g id b (0, s0)-                      of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')-      where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s')-                            | otherwise = (i, s)-   spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0)-                       of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')-      where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')-                            | otherwise = (i, s)-   splitAt = Sequence.splitAt-   drop = Sequence.drop-   take = Sequence.take-   length = Sequence.length-   reverse = Sequence.reverse--instance Ord a => FactorialMonoid (Set.Set a) where-   factors = List.map Set.singleton . Set.toAscList-   primePrefix set | Set.null set = set-                   | otherwise = Set.singleton $ Set.findMin set-   primeSuffix set | Set.null set = set-                   | otherwise = Set.singleton $ Set.findMax set-   splitPrimePrefix = fmap singularize . Set.minView-      where singularize (min, rest) = (Set.singleton min, rest)-   splitPrimeSuffix = fmap singularize . Set.maxView-      where singularize (max, rest) = (rest, Set.singleton max)-   foldl f = Foldable.foldl f'-      where f' a b = f a (Set.singleton b)-   foldl' f = Foldable.foldl' f'-      where f' a b = f a (Set.singleton b)-   foldr f = Foldable.foldr f'-      where f' a b = f (Set.singleton a) b-   length = Set.size-   reverse = id--instance FactorialMonoid (Vector.Vector a) where-   factors x = factorize (Vector.length x) x-      where factorize 0 _ = []-            factorize n xs = xs1 : factorize (pred n) xs'-               where (xs1, xs') = Vector.splitAt 1 xs-   primePrefix = Vector.take 1-   primeSuffix x = Vector.drop (Vector.length x - 1) x-   splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x)-   splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x)-   inits x0 = initsWith x0 []-      where initsWith x rest | Vector.null x = x:rest-                             | otherwise = initsWith (Vector.unsafeInit x) (x:rest)-   tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x)-   foldl f = Vector.foldl f'-      where f' a byte = f a (Vector.singleton byte)-   foldl' f = Vector.foldl' f'-      where f' a byte = f a (Vector.singleton byte)-   foldr f = Vector.foldr f'-      where f' byte a = f (Vector.singleton byte) a-   break f = Vector.break (f . Vector.singleton)-   span f = Vector.span (f . Vector.singleton)-   dropWhile f = Vector.dropWhile (f . Vector.singleton)-   takeWhile f = Vector.takeWhile (f . Vector.singleton)-   spanMaybe s0 f v = case Vector.ifoldr g Left v s0-                      of Left s' -> (v, Vector.empty, s')-                         Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')-      where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s'-                         | otherwise = Right (i, s)-   spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0-                       of Left s' -> (v, Vector.empty, s')-                          Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')-      where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s')-                         | otherwise = Right (i, s)-   splitAt = Vector.splitAt-   drop = Vector.drop-   take = Vector.take-   length = Vector.length-   reverse = Vector.reverse--instance StableFactorialMonoid ()-instance StableFactorialMonoid a => StableFactorialMonoid (Dual a)-instance StableFactorialMonoid [x]-instance StableFactorialMonoid ByteString.ByteString-instance StableFactorialMonoid LazyByteString.ByteString-instance StableFactorialMonoid Text.Text-instance StableFactorialMonoid LazyText.Text-instance StableFactorialMonoid (Sequence.Seq a)-instance StableFactorialMonoid (Vector.Vector a)---- | A 'Monad.mapM' equivalent.-mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b-mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f)---- | A 'Monad.mapM_' equivalent.-mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m ()-mapM_ f = foldr ((>>) . f) (return ())
− tests/examples/ghc710/Undefined11.hs 
@@ -1,423 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Algebra.Additive (-    -- * Class-    C,-    zero,-    (+), (-),-    negate, subtract,--    -- * Complex functions-    sum, sum1,-    sumNestedAssociative,-    sumNestedCommutative,--    -- * Instance definition helpers-    elementAdd, elementSub, elementNeg,-    (<*>.+), (<*>.-), (<*>.-$),--    -- * Instances for atomic types-    propAssociative,-    propCommutative,-    propIdentity,-    propInverse,-  ) where--import qualified Algebra.Laws as Laws--import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  )-import Data.Word (Word, Word8, Word16, Word32, Word64, )--import qualified NumericPrelude.Elementwise as Elem-import Control.Applicative (Applicative(pure, (<*>)), )-import Data.Tuple.HT (fst3, snd3, thd3, )-import qualified Data.List.Match as Match--import qualified Data.Complex as Complex98-import qualified Data.Ratio as Ratio98-import qualified Prelude as P-import Prelude (Integer, Float, Double, fromInteger, )-import NumericPrelude.Base---infixl 6  +, ---{- |-Additive a encapsulates the notion of a commutative group, specified-by the following laws:--@-          a + b === b + a-    (a + b) + c === a + (b + c)-       zero + a === a-   a + negate a === 0-@--Typical examples include integers, dollars, and vectors.--Minimal definition: '+', 'zero', and ('negate' or '(-)')--}--class C a where-    {-# MINIMAL zero, (+), ((-) | negate) #-}-    -- | zero element of the vector space-    zero     :: a-    -- | add and subtract elements-    (+), (-) :: a -> a -> a-    -- | inverse with respect to '+'-    negate   :: a -> a--    {-# INLINE negate #-}-    negate a = zero - a-    {-# INLINE (-) #-}-    a - b    = a + negate b--{- |-'subtract' is @(-)@ with swapped operand order.-This is the operand order which will be needed in most cases-of partial application.--}-subtract :: C a => a -> a -> a-subtract = flip (-)-----{- |-Sum up all elements of a list.-An empty list yields zero.--This function is inappropriate for number types like Peano.-Maybe we should make 'sum' a method of Additive.-This would also make 'lengthLeft' and 'lengthRight' superfluous.--}-sum :: (C a) => [a] -> a-sum = foldl (+) zero--{- |-Sum up all elements of a non-empty list.-This avoids including a zero which is useful for types-where no universal zero is available.--}-sum1 :: (C a) => [a] -> a-sum1 = foldl1 (+)---{- |-Sum the operands in an order,-such that the dependencies are minimized.-Does this have a measurably effect on speed?--Requires associativity.--}-sumNestedAssociative :: (C a) => [a] -> a-sumNestedAssociative [] = zero-sumNestedAssociative [x] = x-sumNestedAssociative xs = sumNestedAssociative (sum2 xs)--{--Make sure that the last entries in the list-are equally often part of an addition.-Maybe this can reduce rounding errors.-The list that sum2 computes is a breadth-first-flattened binary tree.--Requires associativity and commutativity.--}-sumNestedCommutative :: (C a) => [a] -> a-sumNestedCommutative [] = zero-sumNestedCommutative xs@(_:rs) =-   let ys = xs ++ Match.take rs (sum2 ys)-   in  last ys--_sumNestedCommutative :: (C a) => [a] -> a-_sumNestedCommutative [] = zero-_sumNestedCommutative xs@(_:rs) =-   let ys = xs ++ take (length rs) (sum2 ys)-   in  last ys--{--[a,b,c, a+b,c+(a+b)]-[a,b,c,d, a+b,c+d,(a+b)+(c+d)]-[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)]-[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))]--}--sum2 :: (C a) => [a] -> [a]-sum2 (x:y:rest) = (x+y) : sum2 rest-sum2 xs = xs----{- |-Instead of baking the add operation into the element function,-we could use higher rank types-and pass a generic @uncurry (+)@ to the run function.-We do not do so in order to stay Haskell 98-at least for parts of NumericPrelude.--}-{-# INLINE elementAdd #-}-elementAdd ::-   (C x) =>-   (v -> x) -> Elem.T (v,v) x-elementAdd f =-   Elem.element (\(x,y) -> f x + f y)--{-# INLINE elementSub #-}-elementSub ::-   (C x) =>-   (v -> x) -> Elem.T (v,v) x-elementSub f =-   Elem.element (\(x,y) -> f x - f y)--{-# INLINE elementNeg #-}-elementNeg ::-   (C x) =>-   (v -> x) -> Elem.T v x-elementNeg f =-   Elem.element (negate . f)----- like <*>-infixl 4 <*>.+, <*>.-, <*>.-$--{- |-> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b)-> addPair = Elem.run2 $ Elem.with (,) <*>.+  fst <*>.+  snd--}-{-# INLINE (<*>.+) #-}-(<*>.+) ::-   (C x) =>-   Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a-(<*>.+) f acc =-   f <*> elementAdd acc--{-# INLINE (<*>.-) #-}-(<*>.-) ::-   (C x) =>-   Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a-(<*>.-) f acc =-   f <*> elementSub acc--{-# INLINE (<*>.-$) #-}-(<*>.-$) ::-   (C x) =>-   Elem.T v (x -> a) -> (v -> x) -> Elem.T v a-(<*>.-$) f acc =-   f <*> elementNeg acc----- * Instances for atomic types--instance C Integer where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Float   where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Double  where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)---instance C Int     where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Int8    where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Int16   where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Int32   where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Int64   where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)---instance C Word    where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Word8   where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Word16  where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Word32  where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)--instance C Word64  where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = P.fromInteger 0-   negate = P.negate-   (+)    = (P.+)-   (-)    = (P.-)------- * Instances for composed types--instance (C v0, C v1) => C (v0, v1) where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = (,) zero zero-   (+)    = Elem.run2 $ pure (,) <*>.+  fst <*>.+  snd-   (-)    = Elem.run2 $ pure (,) <*>.-  fst <*>.-  snd-   negate = Elem.run  $ pure (,) <*>.-$ fst <*>.-$ snd--instance (C v0, C v1, C v2) => C (v0, v1, v2) where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero   = (,,) zero zero zero-   (+)    = Elem.run2 $ pure (,,) <*>.+  fst3 <*>.+  snd3 <*>.+  thd3-   (-)    = Elem.run2 $ pure (,,) <*>.-  fst3 <*>.-  snd3 <*>.-  thd3-   negate = Elem.run  $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3---instance (C v) => C [v] where-   zero   = []-   negate = map negate-   (+) (x:xs) (y:ys) = (+) x y : (+) xs ys-   (+) xs     []     = xs-   (+) []     ys     = ys-   (-) (x:xs) (y:ys) = (-) x y : (-) xs ys-   (-) xs     []     = xs-   (-) []     ys     = negate ys---instance (C v) => C (b -> v) where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero       _ = zero-   (+)    f g x = (+) (f x) (g x)-   (-)    f g x = (-) (f x) (g x)-   negate f   x = negate (f x)---- * Properties--propAssociative :: (Eq a, C a) => a -> a -> a -> Bool-propCommutative :: (Eq a, C a) => a -> a -> Bool-propIdentity    :: (Eq a, C a) => a -> Bool-propInverse     :: (Eq a, C a) => a -> Bool--propCommutative  =  Laws.commutative (+)-propAssociative  =  Laws.associative (+)-propIdentity     =  Laws.identity (+) zero-propInverse      =  Laws.inverse (+) negate zero------ legacy--instance (P.Integral a) => C (Ratio98.Ratio a) where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero                =  P.fromInteger 0-   (+)                 =  (P.+)-   (-)                 =  (P.-)-   negate              =  P.negate--instance (P.RealFloat a) => C (Complex98.Complex a) where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero                =  P.fromInteger 0-   (+)                 =  (P.+)-   (-)                 =  (P.-)-   negate              =  P.negate
− tests/examples/ghc710/Undefined13.hs 
@@ -1,130 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.TigHTTP.Papillon (-    ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),-        parseContentType, showContentType,-) where--import Data.Char-import Text.Papillon--import Data.ByteString (ByteString)-import Data.ByteString.Char8 (pack)-import qualified Data.ByteString as BS--import Network.TigHTTP.Token--data ContentType = ContentType Type Subtype [Parameter]-    deriving (Show, Eq)--parseContentType :: BS.ByteString -> ContentType-parseContentType ct = case runError . contentType $ parse ct of-    Left _ -> error "parseContentType"-    Right (r, _) -> r--showContentType :: ContentType -> BS.ByteString-showContentType (ContentType t st ps) = showType t-    `BS.append` "/"-    `BS.append` showSubtype st-    `BS.append` showParameters ps--data Type-    = Text-    | TypeRaw BS.ByteString-    deriving (Show, Eq)--mkType :: BS.ByteString -> Type-mkType "text" = Text-mkType t = TypeRaw t--showType :: Type -> BS.ByteString-showType Text = "text"-showType (TypeRaw t) = t--data Subtype-    = Plain-    | Html-    | Css-    | SubtypeRaw BS.ByteString-    deriving (Show, Eq)--mkSubtype :: BS.ByteString -> Subtype-mkSubtype "html" = Html-mkSubtype "plain" = Plain-mkSubtype "css" = Css-mkSubtype s = SubtypeRaw s--showSubtype :: Subtype -> BS.ByteString-showSubtype Plain = "plain"-showSubtype Html = "html"-showSubtype Css = "css"-showSubtype (SubtypeRaw s) = s--data Parameter-    = Charset Charset-    | ParameterRaw BS.ByteString BS.ByteString-    deriving (Show, Eq)--mkParameter :: BS.ByteString -> BS.ByteString -> Parameter-mkParameter "charset" "UTF-8" = Charset Utf8-mkParameter "charset" v = Charset $ CharsetRaw v-mkParameter a v = ParameterRaw a v--showParameters :: [Parameter] -> BS.ByteString-showParameters [] = ""-showParameters (Charset v : ps) = "; " `BS.append` "charset"-    `BS.append` "=" `BS.append` showCharset v `BS.append` showParameters ps-showParameters (ParameterRaw a v : ps) = "; " `BS.append` a-    `BS.append` "=" `BS.append` v `BS.append` showParameters ps--data Charset-    = Utf8-    | CharsetRaw BS.ByteString-    deriving (Show, Eq)--showCharset :: Charset -> BS.ByteString-showCharset Utf8 = "UTF-8"-showCharset (CharsetRaw cs) = cs--bsconcat :: [ByteString] -> ByteString-bsconcat = BS.concat--[papillon|--source: ByteString--contentType :: ContentType-    = c:token '/' sc:token ps:(';' ' '* p:parameter { p })*-    { ContentType (mkType c) (mkSubtype sc) ps }--token :: ByteString-    = t:<isTokenChar>+          { pack t }--quotedString :: ByteString-    = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"'-                        { bsconcat t }--quotedPair :: Char-    = '\\' c:<isAscii>          { c }--crlf :: () = '\r' '\n'--lws :: () = _:crlf _:(' ' / '\t')+---- text :: ByteString---  = ts:(cs:<isTextChar>+ { cs } / _:lws { " " })+     { pack $ concat ts }--qdtext :: ByteString-    = ts:(cs:<isQdtextChar>+ { cs } / _:lws { " " })+   { pack $ concat ts }--parameter :: Parameter-    = a:attribute '=' v:value               { mkParameter a v }--attribute :: ByteString = t:token               { t }--value :: ByteString-    = t:token                       { t }-    / qs:quotedString                   { qs }--|]
− tests/examples/ghc710/Undefined2.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Zip--- Copyright   :  (c) Nils Schweinsberg 2011,---                (c) George Giorgidze 2011---                (c) University Tuebingen 2011--- License     :  BSD-style (see the file libraries/base/LICENSE)--- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Monadic zipping (used for monad comprehensions)-----------------------------------------------------------------------------------module Control.Monad.Zip where--import Prelude-import Control.Monad (liftM)---- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith`------ Instances should satisfy the laws:------ * Naturality :------   > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb)------ * Information Preservation:------   > liftM (const ()) ma = liftM (const ()) mb---   > ==>---   > munzip (mzip ma mb) = (ma, mb)----class Monad m => MonadZip m where--    mzip :: m a -> m b -> m (a,b)-    mzip = mzipWith (,)--    mzipWith :: (a -> b -> c) -> m a -> m b -> m c-    mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)--    munzip :: m (a,b) -> (m a, m b)-    munzip mab = (liftM fst mab, liftM snd mab)-    -- munzip is a member of the class because sometimes-    -- you can implement it more efficiently than the-    -- above default code.  See Trac #4370 comment by giorgidze-    {-# MINIMAL mzip | mzipWith #-}--instance MonadZip [] where-    mzip     = zip-    mzipWith = zipWith-    munzip   = unzip-
− tests/examples/ghc710/Undefined3.hs 
@@ -1,340 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Foldable--- Copyright   :  Ross Paterson 2005--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Class of data structures that can be folded to a summary value.------ Many of these functions generalize "Prelude", "Control.Monad" and--- "Data.List" functions of the same names from lists to any 'Foldable'--- functor.  To avoid ambiguity, either import those modules hiding--- these names or qualify uses of these function names with an alias--- for this module.-----------------------------------------------------------------------------------module Data.Foldable (-    -- * Folds-    Foldable(..),-    -- ** Special biased folds-    foldrM,-    foldlM,-    -- ** Folding actions-    -- *** Applicative actions-    traverse_,-    for_,-    sequenceA_,-    asum,-    -- *** Monadic actions-    mapM_,-    forM_,-    sequence_,-    msum,-    -- ** Specialized folds-    toList,-    concat,-    concatMap,-    and,-    or,-    any,-    all,-    sum,-    product,-    maximum,-    maximumBy,-    minimum,-    minimumBy,-    -- ** Searches-    elem,-    notElem,-    find-    ) where--import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_,-                elem, notElem, concat, concatMap, and, or, any, all,-                sum, product, maximum, minimum)-import qualified Prelude (foldl, foldr, foldl1, foldr1)-import qualified Data.List as List (foldl')-import Control.Applicative-import Control.Monad (MonadPlus(..))-import Data.Maybe (fromMaybe, listToMaybe)-import Data.Monoid-import Data.Proxy--import GHC.Exts (build)-import GHC.Arr---- | Data structures that can be folded.------ Minimal complete definition: 'foldMap' or 'foldr'.------ For example, given a data type------ > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)------ a suitable instance would be------ > instance Foldable Tree where--- >    foldMap f Empty = mempty--- >    foldMap f (Leaf x) = f x--- >    foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r------ This is suitable even for abstract types, as the monoid is assumed--- to satisfy the monoid laws.  Alternatively, one could define @foldr@:------ > instance Foldable Tree where--- >    foldr f z Empty = z--- >    foldr f z (Leaf x) = f x z--- >    foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l----class Foldable t where-    -- | Combine the elements of a structure using a monoid.-    fold :: Monoid m => t m -> m-    fold = foldMap id--    -- | Map each element of the structure to a monoid,-    -- and combine the results.-    foldMap :: Monoid m => (a -> m) -> t a -> m-    foldMap f = foldr (mappend . f) mempty--    -- | Right-associative fold of a structure.-    ---    -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@-    foldr :: (a -> b -> b) -> b -> t a -> b-    foldr f z t = appEndo (foldMap (Endo . f) t) z--    -- | Right-associative fold of a structure,-    -- but with strict application of the operator.-    foldr' :: (a -> b -> b) -> b -> t a -> b-    foldr' f z0 xs = foldl f' id xs z0-      where f' k x z = k $! f x z--    -- | Left-associative fold of a structure.-    ---    -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@-    foldl :: (b -> a -> b) -> b -> t a -> b-    foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z--    -- | Left-associative fold of a structure.-    -- but with strict application of the operator.-    ---    -- @'foldl' f z = 'List.foldl'' f z . 'toList'@-    foldl' :: (b -> a -> b) -> b -> t a -> b-    foldl' f z0 xs = foldr f' id xs z0-      where f' x k z = k $! f z x--    -- | A variant of 'foldr' that has no base case,-    -- and thus may only be applied to non-empty structures.-    ---    -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@-    foldr1 :: (a -> a -> a) -> t a -> a-    foldr1 f xs = fromMaybe (error "foldr1: empty structure")-                    (foldr mf Nothing xs)-      where-        mf x Nothing = Just x-        mf x (Just y) = Just (f x y)--    -- | A variant of 'foldl' that has no base case,-    -- and thus may only be applied to non-empty structures.-    ---    -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@-    foldl1 :: (a -> a -> a) -> t a -> a-    foldl1 f xs = fromMaybe (error "foldl1: empty structure")-                    (foldl mf Nothing xs)-      where-        mf Nothing y = Just y-        mf (Just x) y = Just (f x y)-    {-# MINIMAL foldMap | foldr #-}---- instances for Prelude types--instance Foldable Maybe where-    foldr _ z Nothing = z-    foldr f z (Just x) = f x z--    foldl _ z Nothing = z-    foldl f z (Just x) = f z x--instance Foldable [] where-    foldr = Prelude.foldr-    foldl = Prelude.foldl-    foldl' = List.foldl'-    foldr1 = Prelude.foldr1-    foldl1 = Prelude.foldl1--instance Foldable (Either a) where-    foldMap _ (Left _) = mempty-    foldMap f (Right y) = f y--    foldr _ z (Left _) = z-    foldr f z (Right y) = f y z--instance Foldable ((,) a) where-    foldMap f (_, y) = f y--    foldr f z (_, y) = f y z--instance Ix i => Foldable (Array i) where-    foldr f z = Prelude.foldr f z . elems-    foldl f z = Prelude.foldl f z . elems-    foldr1 f = Prelude.foldr1 f . elems-    foldl1 f = Prelude.foldl1 f . elems--instance Foldable Proxy where-    foldMap _ _ = mempty-    {-# INLINE foldMap #-}-    fold _ = mempty-    {-# INLINE fold #-}-    foldr _ z _ = z-    {-# INLINE foldr #-}-    foldl _ z _ = z-    {-# INLINE foldl #-}-    foldl1 _ _ = error "foldl1: Proxy"-    {-# INLINE foldl1 #-}-    foldr1 _ _ = error "foldr1: Proxy"-    {-# INLINE foldr1 #-}--instance Foldable (Const m) where-    foldMap _ _ = mempty---- | Monadic fold over the elements of a structure,--- associating to the right, i.e. from right to left.-foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b-foldrM f z0 xs = foldl f' return xs z0-  where f' k x z = f x z >>= k---- | Monadic fold over the elements of a structure,--- associating to the left, i.e. from left to right.-foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b-foldlM f z0 xs = foldr f' return xs z0-  where f' x k z = f z x >>= k---- | Map each element of a structure to an action, evaluate--- these actions from left to right, and ignore the results.-traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()-traverse_ f = foldr ((*>) . f) (pure ())---- | 'for_' is 'traverse_' with its arguments flipped.-for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()-{-# INLINE for_ #-}-for_ = flip traverse_---- | Map each element of a structure to a monadic action, evaluate--- these actions from left to right, and ignore the results.-mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()-mapM_ f = foldr ((>>) . f) (return ())---- | 'forM_' is 'mapM_' with its arguments flipped.-forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()-{-# INLINE forM_ #-}-forM_ = flip mapM_---- | Evaluate each action in the structure from left to right,--- and ignore the results.-sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()-sequenceA_ = foldr (*>) (pure ())---- | Evaluate each monadic action in the structure from left to right,--- and ignore the results.-sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()-sequence_ = foldr (>>) (return ())---- | The sum of a collection of actions, generalizing 'concat'.-asum :: (Foldable t, Alternative f) => t (f a) -> f a-{-# INLINE asum #-}-asum = foldr (<|>) empty---- | The sum of a collection of actions, generalizing 'concat'.-msum :: (Foldable t, MonadPlus m) => t (m a) -> m a-{-# INLINE msum #-}-msum = foldr mplus mzero---- These use foldr rather than foldMap to avoid repeated concatenation.---- | List of elements of a structure.-toList :: Foldable t => t a -> [a]-{-# INLINE toList #-}-toList t = build (\ c n -> foldr c n t)---- | The concatenation of all the elements of a container of lists.-concat :: Foldable t => t [a] -> [a]-concat = fold---- | Map a function over all the elements of a container and concatenate--- the resulting lists.-concatMap :: Foldable t => (a -> [b]) -> t a -> [b]-concatMap = foldMap---- | 'and' returns the conjunction of a container of Bools.  For the--- result to be 'True', the container must be finite; 'False', however,--- results from a 'False' value finitely far from the left end.-and :: Foldable t => t Bool -> Bool-and = getAll . foldMap All---- | 'or' returns the disjunction of a container of Bools.  For the--- result to be 'False', the container must be finite; 'True', however,--- results from a 'True' value finitely far from the left end.-or :: Foldable t => t Bool -> Bool-or = getAny . foldMap Any---- | Determines whether any element of the structure satisfies the predicate.-any :: Foldable t => (a -> Bool) -> t a -> Bool-any p = getAny . foldMap (Any . p)---- | Determines whether all elements of the structure satisfy the predicate.-all :: Foldable t => (a -> Bool) -> t a -> Bool-all p = getAll . foldMap (All . p)---- | The 'sum' function computes the sum of the numbers of a structure.-sum :: (Foldable t, Num a) => t a -> a-sum = getSum . foldMap Sum---- | The 'product' function computes the product of the numbers of a structure.-product :: (Foldable t, Num a) => t a -> a-product = getProduct . foldMap Product---- | The largest element of a non-empty structure.-maximum :: (Foldable t, Ord a) => t a -> a-maximum = foldr1 max---- | The largest element of a non-empty structure with respect to the--- given comparison function.-maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a-maximumBy cmp = foldr1 max'-  where max' x y = case cmp x y of-                        GT -> x-                        _  -> y---- | The least element of a non-empty structure.-minimum :: (Foldable t, Ord a) => t a -> a-minimum = foldr1 min---- | The least element of a non-empty structure with respect to the--- given comparison function.-minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a-minimumBy cmp = foldr1 min'-  where min' x y = case cmp x y of-                        GT -> y-                        _  -> x---- | Does the element occur in the structure?-elem :: (Foldable t, Eq a) => a -> t a -> Bool-elem = any . (==)---- | 'notElem' is the negation of 'elem'.-notElem :: (Foldable t, Eq a) => a -> t a -> Bool-notElem x = not . elem x---- | The 'find' function takes a predicate and a structure and returns--- the leftmost element of the structure matching the predicate, or--- 'Nothing' if there is no such element.-find :: Foldable t => (a -> Bool) -> t a -> Maybe a-find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])-
− tests/examples/ghc710/Undefined4.hs 
@@ -1,280 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Traversable--- Copyright   :  Conor McBride and Ross Paterson 2005--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Class of data structures that can be traversed from left to right,--- performing an action on each element.------ See also------  * \"Applicative Programming with Effects\",---    by Conor McBride and Ross Paterson,---    /Journal of Functional Programming/ 18:1 (2008) 1-13, online at---    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.------  * \"The Essence of the Iterator Pattern\",---    by Jeremy Gibbons and Bruno Oliveira,---    in /Mathematically-Structured Functional Programming/, 2006, online at---    <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.------  * \"An Investigation of the Laws of Traversals\",---    by Mauro Jaskelioff and Ondrej Rypacek,---    in /Mathematically-Structured Functional Programming/, 2012, online at---    <http://arxiv.org/pdf/1202.2919>.------ Note that the functions 'mapM' and 'sequence' generalize "Prelude"--- functions of the same names from lists to any 'Traversable' functor.--- To avoid ambiguity, either import the "Prelude" hiding these names--- or qualify uses of these function names with an alias for this module.-----------------------------------------------------------------------------------module Data.Traversable (-    -- * The 'Traversable' class-    Traversable(..),-    -- * Utility functions-    for,-    forM,-    mapAccumL,-    mapAccumR,-    -- * General definitions for superclass methods-    fmapDefault,-    foldMapDefault,-    ) where--import Prelude hiding (mapM, sequence, foldr)-import qualified Prelude (mapM, foldr)-import Control.Applicative-import Data.Foldable (Foldable())-import Data.Monoid (Monoid)-import Data.Proxy--import GHC.Arr---- | Functors representing data structures that can be traversed from--- left to right.------ Minimal complete definition: 'traverse' or 'sequenceA'.------ A definition of 'traverse' must satisfy the following laws:------ [/naturality/]---   @t . 'traverse' f = 'traverse' (t . f)@---   for every applicative transformation @t@------ [/identity/]---   @'traverse' Identity = Identity@------ [/composition/]---   @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@------ A definition of 'sequenceA' must satisfy the following laws:------ [/naturality/]---   @t . 'sequenceA' = 'sequenceA' . 'fmap' t@---   for every applicative transformation @t@------ [/identity/]---   @'sequenceA' . 'fmap' Identity = Identity@------ [/composition/]---   @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@------ where an /applicative transformation/ is a function------ @t :: (Applicative f, Applicative g) => f a -> g a@------ preserving the 'Applicative' operations, i.e.------  * @t ('pure' x) = 'pure' x@------  * @t (x '<*>' y) = t x '<*>' t y@------ and the identity functor @Identity@ and composition of functors @Compose@--- are defined as------ >   newtype Identity a = Identity a--- >--- >   instance Functor Identity where--- >     fmap f (Identity x) = Identity (f x)--- >--- >   instance Applicative Indentity where--- >     pure x = Identity x--- >     Identity f <*> Identity x = Identity (f x)--- >--- >   newtype Compose f g a = Compose (f (g a))--- >--- >   instance (Functor f, Functor g) => Functor (Compose f g) where--- >     fmap f (Compose x) = Compose (fmap (fmap f) x)--- >--- >   instance (Applicative f, Applicative g) => Applicative (Compose f g) where--- >     pure x = Compose (pure (pure x))--- >     Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)------ (The naturality law is implied by parametricity.)------ Instances are similar to 'Functor', e.g. given a data type------ > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)------ a suitable instance would be------ > instance Traversable Tree where--- >    traverse f Empty = pure Empty--- >    traverse f (Leaf x) = Leaf <$> f x--- >    traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r------ This is suitable even for abstract types, as the laws for '<*>'--- imply a form of associativity.------ The superclass instances should satisfy the following:------  * In the 'Functor' instance, 'fmap' should be equivalent to traversal---    with the identity applicative functor ('fmapDefault').------  * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be---    equivalent to traversal with a constant applicative functor---    ('foldMapDefault').----class (Functor t, Foldable t) => Traversable t where-    -- | Map each element of a structure to an action, evaluate-    -- these actions from left to right, and collect the results.-    traverse :: Applicative f => (a -> f b) -> t a -> f (t b)-    traverse f = sequenceA . fmap f--    -- | Evaluate each action in the structure from left to right,-    -- and collect the results.-    sequenceA :: Applicative f => t (f a) -> f (t a)-    sequenceA = traverse id--    -- | Map each element of a structure to a monadic action, evaluate-    -- these actions from left to right, and collect the results.-    mapM :: Monad m => (a -> m b) -> t a -> m (t b)-    mapM f = unwrapMonad . traverse (WrapMonad . f)--    -- | Evaluate each monadic action in the structure from left to right,-    -- and collect the results.-    sequence :: Monad m => t (m a) -> m (t a)-    sequence = mapM id-    {-# MINIMAL traverse | sequenceA #-}---- instances for Prelude types--instance Traversable Maybe where-    traverse _ Nothing = pure Nothing-    traverse f (Just x) = Just <$> f x--instance Traversable [] where-    {-# INLINE traverse #-} -- so that traverse can fuse-    traverse f = Prelude.foldr cons_f (pure [])-      where cons_f x ys = (:) <$> f x <*> ys--    mapM = Prelude.mapM--instance Traversable (Either a) where-    traverse _ (Left x) = pure (Left x)-    traverse f (Right y) = Right <$> f y--instance Traversable ((,) a) where-    traverse f (x, y) = (,) x <$> f y--instance Ix i => Traversable (Array i) where-    traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)--instance Traversable Proxy where-    traverse _ _ = pure Proxy-    {-# INLINE traverse #-}-    sequenceA _ = pure Proxy-    {-# INLINE sequenceA #-}-    mapM _ _ = return Proxy-    {-# INLINE mapM #-}-    sequence _ = return Proxy-    {-# INLINE sequence #-}--instance Traversable (Const m) where-    traverse _ (Const m) = pure $ Const m---- general functions---- | 'for' is 'traverse' with its arguments flipped.-for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)-{-# INLINE for #-}-for = flip traverse---- | 'forM' is 'mapM' with its arguments flipped.-forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)-{-# INLINE forM #-}-forM = flip mapM---- left-to-right state transformer-newtype StateL s a = StateL { runStateL :: s -> (s, a) }--instance Functor (StateL s) where-    fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v)--instance Applicative (StateL s) where-    pure x = StateL (\ s -> (s, x))-    StateL kf <*> StateL kv = StateL $ \ s ->-        let (s', f) = kf s-            (s'', v) = kv s'-        in (s'', f v)---- |The 'mapAccumL' function behaves like a combination of 'fmap'--- and 'foldl'; it applies a function to each element of a structure,--- passing an accumulating parameter from left to right, and returning--- a final value of this accumulator together with the new structure.-mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)-mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s---- right-to-left state transformer-newtype StateR s a = StateR { runStateR :: s -> (s, a) }--instance Functor (StateR s) where-    fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v)--instance Applicative (StateR s) where-    pure x = StateR (\ s -> (s, x))-    StateR kf <*> StateR kv = StateR $ \ s ->-        let (s', v) = kv s-            (s'', f) = kf s'-        in (s'', f v)---- |The 'mapAccumR' function behaves like a combination of 'fmap'--- and 'foldr'; it applies a function to each element of a structure,--- passing an accumulating parameter from right to left, and returning--- a final value of this accumulator together with the new structure.-mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)-mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s---- | This function may be used as a value for `fmap` in a `Functor`---   instance, provided that 'traverse' is defined. (Using---   `fmapDefault` with a `Traversable` instance defined only by---   'sequenceA' will result in infinite recursion.)-fmapDefault :: Traversable t => (a -> b) -> t a -> t b-{-# INLINE fmapDefault #-}-fmapDefault f = getId . traverse (Id . f)---- | This function may be used as a value for `Data.Foldable.foldMap`--- in a `Foldable` instance.-foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m-foldMapDefault f = getConst . traverse (Const . f)---- local instances--newtype Id a = Id { getId :: a }--instance Functor Id where-    fmap f (Id x) = Id (f x)--instance Applicative Id where-    pure = Id-    Id f <*> Id x = Id (f x)-
− tests/examples/ghc710/Undefined5.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE QuasiQuotes #-}-module Algebra.Ring.Polynomial.Parser ( monomial, expression, variable, variableWithPower-                                      , number, integer, natural, parsePolyn) where-import           Algebra.Ring.Polynomial.Monomorphic-import           Control.Applicative                 hiding (many)-import qualified Data.Map                            as M-import           Data.Ratio-import qualified Numeric.Algebra as NA-import           Text.Peggy--[peggy|-expression :: Polynomial Rational-  = expr !.--letter :: Char-  = [a-zA-Z]--variable :: Variable-  = letter ('_' integer)? { Variable $1 (fromInteger <$> $2) }--variableWithPower :: (Variable, Integer)-  = variable "^" natural { ($1, $2) }-  / variable  { ($1, 1) }--expr :: Polynomial Rational-  = expr "+" term { $1 + $2 }-  / expr "-" term { $1 - $2 }-  / term--term :: Polynomial Rational-   = number space* monoms { injectCoeff $1 * $3 }-   / number { injectCoeff $1 }-   / monoms--monoms :: Polynomial Rational-  = monoms space * fact { $1 * $3 }-  / fact--fact :: Polynomial Rational-  = fact "^" natural { $1 ^ $2 }-  / "(" expr ")"-  / monomial { toPolyn [($1, 1)] }--monomial :: Monomial-  = variableWithPower+ { M.fromListWith (+) $1 }--number :: Rational-  = integer "/" integer { $1 % $2 }-  / integer '.' [0-9]+ { realToFrac (read (show $1 ++ '.' : $2) :: Double) }-  / integer { fromInteger $1 }--integer :: Integer-  = "-" natural { negate $1 }-  / natural--natural :: Integer-  = [1-9] [0-9]* { read ($1 : $2) }--|]--toPolyn :: [(Monomial, Ratio Integer)] -> Polynomial (Ratio Integer)-toPolyn = normalize . Polynomial . M.fromList--parsePolyn :: String -> Either ParseError (Polynomial Rational)-parsePolyn = parseString expression "polynomial"
− tests/examples/ghc710/Undefined6.hs 
@@ -1,238 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses-           , TypeFamilies #-}--module Vision.Image.Class (-    -- * Classes-      Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..)-    , FunctorImage (..)-    -- * Functions-    , (!), (!?), nChannels, pixel-    -- * Conversion-    , Convertible (..), convert-    ) where--import Data.Convertible (Convertible (..), convert)-import Data.Int-import Data.Vector.Storable (Vector, generate, unfoldr)-import Data.Word-import Foreign.Storable (Storable)-import Prelude hiding (map, read)--import Vision.Primitive (-      Z (..), (:.) (..), Point, Size-    , fromLinearIndex, toLinearIndex, shapeLength-    )---- Classes ------------------------------------------------------------------------- | Determines the number of channels and the type of each pixel of the image--- and how images are represented.-class Pixel p where-    type PixelChannel p--    -- | Returns the number of channels of the pixel.-    ---    -- Must not consume 'p' (could be 'undefined').-    pixNChannels :: p -> Int--    pixIndex :: p -> Int -> PixelChannel p--instance Pixel Int16 where-    type PixelChannel Int16 = Int16-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Int32 where-    type PixelChannel Int32 = Int32-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Int where-    type PixelChannel Int = Int-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Word8 where-    type PixelChannel Word8 = Word8-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Word16 where-    type PixelChannel Word16 = Word16-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Word32 where-    type PixelChannel Word32 = Word32-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Word where-    type PixelChannel Word = Word-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Float where-    type PixelChannel Float = Float-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Double where-    type PixelChannel Double = Double-    pixNChannels _   = 1-    pixIndex     p _ = p--instance Pixel Bool where-    type PixelChannel Bool = Bool-    pixNChannels _   = 1-    pixIndex     p _ = p---- | Provides an abstraction for images which are not defined for each of their--- pixels. The interface is similar to 'Image' except that indexing functions--- don't always return.------ Image origin (@'ix2' 0 0@) is located in the upper left corner.-class Storable (ImagePixel i) => MaskedImage i where-    type ImagePixel i--    shape :: i -> Size--    -- | Returns the pixel\'s value at 'Z :. y, :. x'.-    maskedIndex :: i -> Point -> Maybe (ImagePixel i)-    maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img)-    {-# INLINE maskedIndex #-}--    -- | Returns the pixel\'s value as if the image was a single dimension-    -- vector (row-major representation).-    maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i)-    maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img)-    {-# INLINE maskedLinearIndex #-}--    -- | Returns the non-masked values of the image.-    values :: i -> Vector (ImagePixel i)-    values !img =-        unfoldr step 0-      where-        !n = shapeLength (shape img)--        step !i | i >= n                              = Nothing-                | Just p <- img `maskedLinearIndex` i = Just (p, i + 1)-                | otherwise                           = step (i + 1)-    {-# INLINE values #-}--    {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}--type ImageChannel i = PixelChannel (ImagePixel i)---- | Provides an abstraction over the internal representation of an image.------ Image origin is located in the lower left corner.-class MaskedImage i => Image i where-    -- | Returns the pixel value at 'Z :. y :. x'.-    index :: i -> Point -> ImagePixel i-    index img = (img `linearIndex`) . toLinearIndex (shape img)-    {-# INLINE index #-}--    -- | Returns the pixel value as if the image was a single dimension vector-    -- (row-major representation).-    linearIndex :: i -> Int -> ImagePixel i-    linearIndex img = (img `index`) . fromLinearIndex (shape img)-    {-# INLINE linearIndex #-}--    -- | Returns every pixel values as if the image was a single dimension-    -- vector (row-major representation).-    vector :: i -> Vector (ImagePixel i)-    vector img = generate (shapeLength $ shape img) (img `linearIndex`)-    {-# INLINE vector #-}--    {-# MINIMAL index | linearIndex #-}---- | Provides ways to construct an image from a function.-class FromFunction i where-    type FromFunctionPixel i--    -- | Generates an image by calling the given function for each pixel of the-    -- constructed image.-    fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i--    -- | Generates an image by calling the last function for each pixel of the-    -- constructed image.-    ---    -- The first function is called for each line, generating a line invariant-    -- value.-    ---    -- This function is faster for some image representations as some recurring-    -- computation can be cached.-    fromFunctionLine :: Size -> (Int -> a)-                     -> (a -> Point -> FromFunctionPixel i) -> i-    fromFunctionLine size line f =-        fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt)-    {-# INLINE fromFunctionLine #-}--    -- | Generates an image by calling the last function for each pixel of the-    -- constructed image.-    ---    -- The first function is called for each column, generating a column-    -- invariant value.-    ---    -- This function *can* be faster for some image representations as some-    -- recurring computations can be cached. However, it may requires a vector-    -- allocation for these values. If the column invariant is cheap to-    -- compute, prefer 'fromFunction'.-    fromFunctionCol :: Storable b => Size -> (Int -> b)-                    -> (b -> Point -> FromFunctionPixel i) -> i-    fromFunctionCol size col f =-        fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt)-    {-# INLINE fromFunctionCol #-}--    -- | Generates an image by calling the last function for each pixel of the-    -- constructed image.-    ---    -- The two first functions are called for each line and for each column,-    -- respectively, generating common line and column invariant values.-    ---    -- This function is faster for some image representations as some recurring-    -- computation can be cached. However, it may requires a vector-    -- allocation for column values. If the column invariant is cheap to-    -- compute, prefer 'fromFunctionLine'.-    fromFunctionCached :: Storable b => Size-                       -> (Int -> a)               -- ^ Line function-                       -> (Int -> b)               -- ^ Column function-                       -> (a -> b -> Point-                           -> FromFunctionPixel i) -- ^ Pixel function-                       -> i-    fromFunctionCached size line col f =-        fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt)-    {-# INLINE fromFunctionCached #-}--    {-# MINIMAL fromFunction #-}---- | Defines a class for images on which a function can be applied. The class is--- different from 'Functor' as there could be some constraints and--- transformations the pixel and image types.-class (MaskedImage src, MaskedImage res) => FunctorImage src res where-    map :: (ImagePixel src -> ImagePixel res) -> src -> res---- Functions ----------------------------------------------------------------------- | Alias of 'maskedIndex'.-(!?) :: MaskedImage i => i -> Point -> Maybe (ImagePixel i)-(!?) = maskedIndex-{-# INLINE (!?) #-}---- | Alias of 'index'.-(!) :: Image i => i -> Point -> ImagePixel i-(!) = index-{-# INLINE (!) #-}---- | Returns the number of channels of an image.-nChannels :: (Pixel (ImagePixel i), MaskedImage i) => i -> Int-nChannels img = pixNChannels (pixel img)-{-# INLINE nChannels #-}---- | Returns an 'undefined' instance of a pixel of the image. This is sometime--- useful to satisfy the type checker as in a call to 'pixNChannels' :------ > nChannels img = pixNChannels (pixel img)-pixel :: MaskedImage i => i -> ImagePixel i-pixel _ = undefined
− tests/examples/ghc710/Undefined7.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, StandaloneDeriving, DeriveDataTypeable #-}--module Test where--import Control.Applicative-import Control.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Binary-import Data.Binary.Get-import Data.Binary.Put-import qualified Data.Map as M-import Data.Generics--import Data.Binary.ISO8583-import Data.Binary.ISO8583.TH--[binary|-  Message-  2 pan embedded 2-  4 amount int 12-  11 stan int 6-  43 termAddress TermAddress 222-|]--deriving instance Eq Message-deriving instance Show Message--data TermAddress = TermAddress {-      tOwner :: B.ByteString,-      tCity :: B.ByteString,-      tOther :: L.ByteString }-  deriving (Eq, Show, Typeable)--instance Binary TermAddress where-  -- NB: this implementation is smth odd and usable only for this testcase.-  get =-    TermAddress-      <$> B.filter (/= 0x20) `fmap` getByteString 30-      <*> B.filter (/= 0x20) `fmap` getByteString 30-      <*> L.filter (/= 0x20) `fmap` getRemainingLazyByteString--  put (TermAddress owner city other) = do-    putByteStringPad 30 owner-    putByteStringPad 30 city-    putLazyByteStringPad 162 other--instance Binary Message where-  get = do-    m <- getBitmap getMessage-    return $ constructMessage m--  put msg = do-    putBitmap' (putMessage msg)--testMsg :: Message-testMsg = Message {-  pan = Just $ toBS "12345678",-  amount = Just $ 100500,-  stan = Just $ 123456,-  termAddress = Just $ TermAddress {-                  tOwner = toBS "TestBank",-                  tCity = toBS "Magnitogorsk",-                  tOther = L.empty }-}--test :: IO ()-test = do-  let bstr = encode testMsg-      msg = decode bstr-  if msg /= testMsg-    then fail $ "Encode/decode mismatch:\n" ++-           show testMsg ++ "\n /= \n" ++-           show msg-    else putStrLn "passed."-
− tests/examples/ghc710/Undefined8.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports #-}--module Text.Markdown.Pap.Parser (-    parseMrd-) where--import Control.Arrow-import "monads-tf" Control.Monad.State-import "monads-tf" Control.Monad.Error-import Data.Maybe-import Data.Char-import Text.Papillon--import Text.Markdown.Pap.Text--parseMrd :: String -> Maybe [Text]-parseMrd src = case flip runState (0, [- 1]) $ runErrorT $ markdown $ parse src of-    (Right (r, _), _) -> Just r-    _ -> Nothing--clear :: State (Int, [Int]) Bool-clear = put (0, [- 1]) >> return True--reset :: State (Int, [Int]) Bool-reset = modify (first $ const 0) >> return True--count :: State (Int, [Int]) ()-count = modify $ first (+ 1)--deeper :: State (Int, [Int]) Bool-deeper = do-    (n, n0 : ns) <- get-    if n > n0 then put (n, n : n0 : ns) >> return True else return False--same :: State (Int, [Int]) Bool-same = do-    (n, n0 : _) <- get-    return $ n == n0--shallow :: State (Int, [Int]) Bool-shallow = do-    (n, n0 : ns) <- get-    if n < n0 then put (n, ns) >> return True else return False--[papillon|--monad: State (Int, [Int])--markdown :: [Text]-    = md:(m:markdown1 _:dmmy[clear] { return m })*      { return md }--markdown1 :: Text-    = h:header              { return h }-    / l:link '\n'*              { return l }-    / i:image '\n'*             { return i }-    / l:list '\n'*              { return $ List l }-    / c:code                { return $ Code c }-    / p:paras               { return $ Paras p }--header :: Text-    = n:sharps _:<isSpace>* l:line '\n'+    { return $ Header n l }-    / l:line '\n' _:equals '\n'+        { return $ Header 1 l }-    / l:line '\n' _:hyphens '\n'+       { return $ Header 2 l }--sharps :: Int-    = '#' n:sharps              { return $ n + 1 }-    / '#'                   { return 1 }--equals :: ()-    = '=' _:equals-    / '='--hyphens :: ()-    = '-' _:hyphens-    / '-'--line :: String-    = l:<(`notElem` "#\n")>+        { return l }--line' :: String-    = l:<(`notElem` "\n")>+         { return l }--code :: String-    = l:fourSpacesLine c:code       { return $ l ++ c }-    / l:fourSpacesLine          { return l }--fourSpacesLine :: String-    = _:fourSpaces l:line' ns:('\n' { return '\n' })+   { return $ l ++ ns }--fourSpaces :: ()-    = ' ' ' ' ' ' ' '--list :: List = _:cnt _:dmmy[deeper] l:list1 ls:list1'* _:shllw  { return $ l : ls }--cnt :: () = _:dmmy[reset] _:(' ' { count })*--list1' :: List1-    = _:cnt _:dmmy[same] l:list1        { return l }--list1 :: List1-    = _:listHead ' ' l:line '\n' ls:list?-        { return $ BulItem l $ fromMaybe [] ls }-    / _:nListHead ' ' l:line '\n' ls:list?-        { return $ OrdItem l $ fromMaybe [] ls }--listHead :: ()-    = '*' / '-' / '+'--nListHead :: ()-    = _:<isDigit>+ '.'--paras :: [String]-    = ps:para+              { return ps }--para :: String-    = ls:(!_:('!') !_:listHead !_:nListHead !_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para)-                        { return $ unwords ls }--shllw :: ()-    = _:dmmy[shallow]-    / !_-    / !_:list--dmmy :: () =--link :: Text-    = '[' t:<(/= ']')>+ ']' ' '* '(' a:<(/= ')')>+ ')' { return $ Link t a "" }--image :: Text-    = '!' '[' alt:<(/= ']')>+ ']' ' '* '(' addrs:<(`notElem` ")\" ")>+ ' '*-        '"' t:<(/= '"')>+ '"' ')'-        { return $ Image alt addrs t }--|]
− tests/examples/ghc710/Undefined9.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies #-}--module Image.PNG (isPNG, pngSize) where--import Data.Maybe-import File.Binary.PNG-import File.Binary-import File.Binary.Instances-import File.Binary.Instances.BigEndian--isPNG :: String -> Bool-isPNG img = isJust (fromBinary () img :: Maybe (PNGHeader, String))--pngSize :: String -> Maybe (Double, Double)-pngSize src = case getChunks src of-    Right cs -> Just-        (fromIntegral $ width $ ihdr cs, fromIntegral $ height $ ihdr cs)-    _ -> Nothing--[binary|--PNGHeader deriving Show--1: 0x89-3: "PNG"-2: "\r\n"-1: "\SUB"-1: "\n"--|]
− tests/examples/ghc710/Unicode.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--module Unicode where--import Control.Monad.Trans.State.Strict---- | 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 α-  }---- | We'll run an ABT computation by starting the variable counter at @0@.----runM ∷ M α → α-runM (M m) = evalState m 0----- | To indicate that a term is in normal form.----stepsExhausted-  ∷ Applicative m-  ⇒ StepT m α-stepsExhausted = StepT . MaybeT $ pure Nothing--stepsExhausted2-  ∷ Applicative m-  => m α-stepsExhausted2 = undefined
− tests/examples/ghc710/UnicodeSyntaxFailure.hs 
@@ -1,3 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--foo x = addToEnv (∀)
− tests/examples/ghc710/Utilities.hs 
@@ -1,17 +0,0 @@-module Utilities (toBinary, fl) where--import Stream-import Data.Ratio---- Convert from an Integer to its signed-digit representation-toBinary :: Integer -> Stream-toBinary 0 = [0]-toBinary x = toBinary t ++ [x `mod` 2]-             where t = x `div` 2----fl :: Stream -> Stream-fl (x:xs) = (f x):xs-          where f 0 = 1-                f 1 = 0
− tests/examples/ghc710/Utils2.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-module Utils2 where---import Control.Applicative (Applicative(..))-import Control.Monad (when, liftM, ap)-import Control.Exception-import Data.Data-import Data.List-import Data.Maybe-import Data.Monoid---- import Language.Haskell.GHC.ExactPrint.Utils-import Language.Haskell.GHC.ExactPrint.Types hiding (showGhc)--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 DynFlags       as GHC-import qualified FastString     as GHC-import qualified ForeignCall    as GHC-import qualified GHC            as GHC-import qualified GHC.Paths      as GHC-import qualified Lexer          as GHC-import qualified Name           as GHC-import qualified NameSet        as GHC-import qualified Outputable     as GHC-import qualified RdrName        as GHC-import qualified SrcLoc         as GHC-import qualified StringBuffer   as GHC-import qualified UniqSet        as GHC-import qualified Unique         as GHC-import qualified Var            as GHC--import qualified Data.Map as Map---- -----------------------------------------------------------------------instance AnnotateP GHC.RdrName where-  annotateP l n = do-    case rdrName2String n of-      "[]" -> do-        addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG-        addDeltaAnnotation GHC.AnnCloseS -- ']' BUG-      "()" -> do-        addDeltaAnnotation GHC.AnnOpenP -- '('-        addDeltaAnnotation GHC.AnnCloseP -- ')'-      "(##)" -> do-        addDeltaAnnotation GHC.AnnOpen -- '(#'-        addDeltaAnnotation GHC.AnnClose -- '#)'-      "[::]" -> do-        addDeltaAnnotation GHC.AnnOpen -- '[:'-        addDeltaAnnotation GHC.AnnClose -- ':]'-      _ ->  do-        addDeltaAnnotation GHC.AnnType-        addDeltaAnnotation GHC.AnnOpenP -- '('-        addDeltaAnnotationLs GHC.AnnBackquote 0-        addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)'-        cnt <- countAnnsAP GHC.AnnVal-        cntT <- countAnnsAP GHC.AnnCommaTuple-        cntR <- countAnnsAP GHC.AnnRarrow-        case cnt of-          0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal-          1 -> addDeltaAnnotation GHC.AnnVal-          x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x)-        addDeltaAnnotation GHC.AnnTildehsh-        addDeltaAnnotation GHC.AnnTilde-        addDeltaAnnotation GHC.AnnRarrow-        addDeltaAnnotationLs GHC.AnnBackquote 1-        addDeltaAnnotation GHC.AnnCloseP -- ')'--  -- temporary, for test-class (Typeable ast) => AnnotateP ast where-  annotateP :: GHC.SrcSpan -> ast -> IO ()--addDeltaAnnotation = undefined-addDeltaAnnotations = undefined-addDeltaAnnotationLs = undefined-addDeltaAnnotationExt = undefined-countAnnsAP = undefined-showGhc = undefined-rdrName2String = undefined-
− tests/examples/ghc710/ViewPatterns.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE ViewPatterns #-}---- From https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns-import Prelude hiding (length)--data JList a = Empty-             | Single a-             | Join (JList a) (JList a)--data JListView a = Nil-                 | Cons a (JList a)---view :: JList a -> JListView a-view Empty = Nil-view (Single a) = Cons a Empty-view (Join (view -> Cons xh xt) y) = Cons xh $ Join xt y-view (Join (view -> Nil) y) = view y--length :: JList a -> Integer-length (view -> Nil) = 0-length (view -> Cons x xs) = 1 + length xs-
− tests/examples/ghc710/Warning.hs 
@@ -1,16 +0,0 @@--module Warning-{-# WARNINg ["This is a module warning",-             "multi-line"] #-}-  where--{-# Warning   foo ,  bar-         ["This is a multi-line",-          "deprecation message",-          "for foo"] #-}-foo :: Int-foo = 4--bar :: Char-bar = 'c'-
− tests/examples/ghc710/Zipper.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Zipper--- Copyright   :  (c) Michael D. Adams, 2010--- License     :  BSD-style (see the LICENSE file)------ ``Scrap Your Zippers: A Generic Zipper for Heterogeneous Types.--- Michael D. Adams.  WGP '10: Proceedings of the 2010 ACM SIGPLAN--- workshop on Generic programming, 2010.''------ See <http://www.cs.indiana.edu/~adamsmd/papers/scrap_your_zippers/>-----------------------------------------------------------------------------------{-# OPTIONS -Wall #-}-{-# LANGUAGE Rank2Types, GADTs #-}--module Zipper where--import Data.Generics-import Control.Monad ((<=<), MonadPlus, mzero, mplus, liftM)-import Data.Maybe (fromJust)---- Core types---- | A generic zipper with a root object of type @root@.-data Zipper root =-  forall hole. (Data hole) =>-    Zipper hole (Context hole root)------ Internal types and functions-data Context hole root where-    CtxtNull :: Context a a-    CtxtCons ::-      forall hole root rights parent. (Data parent) =>-        Left (hole -> rights)-        -> Right rights parent-        -> Context parent root-        -> Context hole root--combine :: Left (hole -> rights)-         -> hole-         -> Right rights parent-         -> parent-combine lefts hole rights =-  fromRight ((fromLeft lefts) hole) rights--data Left expects-  = LeftUnit expects-  | forall b. (Data b) => LeftCons (Left (b -> expects)) b--toLeft :: (Data a) => a -> Left a-toLeft a = gfoldl LeftCons LeftUnit a--fromLeft :: Left r -> r-fromLeft (LeftUnit a)   = a-fromLeft (LeftCons f b) = fromLeft f b--data Right provides parent where-  RightNull :: Right parent parent-  RightCons ::-    (Data b) => b -> Right a t -> Right (b -> a) t--fromRight :: r -> Right r parent -> parent-fromRight f (RightNull)     = f-fromRight f (RightCons b r) = fromRight (f b) r---- | Apply a generic monadic transformation to the hole-transM :: (Monad m) => GenericM m -> Zipper a -> m (Zipper a)-transM f (Zipper hole ctxt) = do-  hole' <- f hole-  return (Zipper hole' ctxt)---- Generic zipper traversals----- Traversal helpers--- | A movement operation such as 'left', 'right', 'up', or 'down'.-type Move a = Zipper a -> Maybe (Zipper a)---- | Apply a generic query using the specified movement operation.-moveQ :: Move a -- ^ Move operation-      -> b -- ^ Default if can't move-      -> (Zipper a -> b) -- ^ Query if can move-      -> Zipper a -- ^ Zipper-      -> b-moveQ move b f z = case move z of-                     Nothing -> b-                     Just z' -> f z'---- | Repeatedly apply a monadic 'Maybe' generic transformation at the--- top-most, left-most position that the transformation returns--- 'Just'.  Behaves like iteratively applying 'zsomewhere' but is--- more efficient because it re-evaluates the transformation--- at only the parents of the last successful application.-zreduce :: GenericM Maybe -> Zipper a -> Zipper a-zreduce f z =-  case transM f z of-    Nothing ->-      downQ (g z) (zreduce f . leftmost) z where-        g z' = rightQ (upQ z' g z') (zreduce f) z'-    Just x  -> zreduce f (reduceAncestors1 f x x)--reduceAncestors1 ::-  GenericM Maybe -> Zipper a -> Zipper a -> Zipper a-reduceAncestors1 f z def = upQ def g z where-  g z' = reduceAncestors1 f z' def' where-    def' = case transM f z' of-             Nothing -> def-             Just x  -> reduceAncestors1 f x x-------- Query--- | Apply a generic query to the left sibling if one exists.-leftQ :: b -- ^ Value to return of no left sibling exists.-      -> (Zipper a -> b) -> Zipper a -> b-leftQ b f z = moveQ left b f z---- | Apply a generic query to the right sibling if one exists.-rightQ :: b -- ^ Value to return if no right sibling exists.-       -> (Zipper a -> b) -> Zipper a -> b-rightQ b f z = moveQ right b f z---- | Apply a generic query to the parent if it exists.-downQ :: b -- ^ Value to return if no children exist.-      -> (Zipper a -> b) -> Zipper a -> b-downQ b f z = moveQ down b f z---- | Apply a generic query to the rightmost child if one exists.-upQ :: b -- ^ Value to return if parent does not exist.-    -> (Zipper a -> b) -> Zipper a -> b-upQ b f z = moveQ up b f z------ Basic movement---- | Move left.  Returns 'Nothing' iff already at leftmost sibling.-left  :: Zipper a -> Maybe (Zipper a)-left (Zipper _ CtxtNull) = Nothing-left (Zipper _ (CtxtCons (LeftUnit _) _ _)) = Nothing-left (Zipper h (CtxtCons (LeftCons l h') r c)) =-  Just (Zipper h' (CtxtCons l (RightCons h r) c))---- | Move right.  Returns 'Nothing' iff already at rightmost sibling.-right :: Zipper a -> Maybe (Zipper a)-right (Zipper _ CtxtNull) = Nothing-right (Zipper _ (CtxtCons _ RightNull _)) = Nothing-right (Zipper h (CtxtCons l (RightCons h' r) c)) =-  Just (Zipper h' (CtxtCons (LeftCons l h) r c))---- | Move down.  Moves to rightmost immediate child.  Returns 'Nothing' iff at a leaf and thus no children exist.-down  :: Zipper a -> Maybe (Zipper a)-down (Zipper hole ctxt) =-  case toLeft hole of-    LeftUnit _ -> Nothing-    LeftCons l hole' ->-      Just (Zipper hole' (CtxtCons l RightNull ctxt))---- | Move up.  Returns 'Nothing' iff already at root and thus no parent exists.-up    :: Zipper a -> Maybe (Zipper a)-up (Zipper _ CtxtNull) = Nothing-up (Zipper hole (CtxtCons l r ctxt)) =-  Just (Zipper (combine l hole r) ctxt)-------- Movement--- | Move to the leftmost sibling.-leftmost :: Zipper a -> Zipper a-leftmost z = leftQ z leftmost z-
− tests/examples/ghc710/read018.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE DatatypeContexts #-}--- !!! Checking that empty contexts are permitted.-module ShouldCompile where--data () => Foo a = Foo a--newtype () => Bar = Bar Int--f :: () => Int -> Int-f = (+1)---class () => Fob a where--instance () => Fob Int where-instance () => Fob Float-
− tests/examples/ghc80/A.hs 
@@ -1,4 +0,0 @@-module A where--class A a where-  has :: a
− tests/examples/ghc80/AddParams2.hs 
@@ -1,9 +0,0 @@-module AddParams2 where--collapse rightInner rightOuter = right-  where-    right           = (rightInner, rightOuter)-    righ2           = (rightInner, (rightOuter baz bar))--baz = undefined-bar = undefined
− tests/examples/ghc80/Associated.hs 
@@ -1,9 +0,0 @@-module Associated(A(..)) where--import AssociatedInternal (A(..))--foo = MkA 5-baz = NoA--qux (MkA x) = x-qux NoA = 0
− tests/examples/ghc80/AssociatedInternal.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module AssociatedInternal (A(NewA,MkA, NoA)) where--newtype A = NewA (Maybe Int)--pattern MkA n = NewA (Just n)--pattern NoA = NewA Nothing
− tests/examples/ghc80/B.hs 
@@ -1,4 +0,0 @@-module B where--class B a where-  has :: a
− tests/examples/ghc80/Base.hs 
@@ -1,6 +0,0 @@-module Base (AClass(..), BClass()) where--import Extends (BClass ())--class AClass a where-  has :: a
− tests/examples/ghc80/Bundle.hs 
@@ -1,9 +0,0 @@-module Bundle(A(..)) where--import BundleInternal (A(..))--foo = MkA 5-baz = NoA--qux (MkA x) = x-qux NoA = 0
− tests/examples/ghc80/Bundle1.hs 
@@ -1,9 +0,0 @@-module Associated1(A(..)) where--import BundleInternal1 (A(..))--foo = MkA 5-baz = NoA--qux (MkA x) = x-qux NoA = 0
− tests/examples/ghc80/BundleExport.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module BundleExport(P(.., A), Q(B)) where--data P = P--data Q = Q--pattern A = P-pattern B = Q
− tests/examples/ghc80/BundleInternal.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module BundleInternal (A(NewA,MkA, NoA)) where--newtype A = NewA (Maybe Int)--pattern MkA n = NewA (Just n)--pattern NoA = NewA Nothing
− tests/examples/ghc80/BundleInternal1.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module BundleInternal1 (A(NewA,MkA, NoA)) where--newtype A = NewA (Maybe Int)--pattern MkA n = NewA (Just n)--pattern NoA = NewA Nothing
− tests/examples/ghc80/C.hs 
@@ -1,3 +0,0 @@-module C (oops) where--import {-# SOURCE #-} B
− tests/examples/ghc80/CheckUtils.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE RankNTypes #-}---- This program must be called with GHC's libdir and the file to be checked as--- the command line arguments.-module CheckUtils where--import Data.Data-import Data.List-import System.IO-import GHC-import BasicTypes-import DynFlags-import MonadUtils-import Outputable-import ApiAnnotation-import Bag (filterBag,isEmptyBag)-import System.Directory (removeFile)-import System.Environment( getArgs )-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Dynamic ( fromDynamic,Dynamic )--_main::IO()-_main = do-        [libdir,fileName] <- getArgs-        testOneFile libdir fileName--testOneFile libdir fileName = do-       ((anns,cs),p) <- runGhc (Just libdir) $ do-                        dflags <- getSessionDynFlags-                        setSessionDynFlags dflags-                        let mn =mkModuleName fileName-                        addTarget Target { targetId = TargetModule mn-                                         , targetAllowObjCode = True-                                         , targetContents = Nothing }-                        load LoadAllTargets-                        modSum <- getModSummary mn-                        p <- parseModule modSum-                        return (pm_annotations p,p)--       let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)--           problems = filter (\(s,a) -> not (Set.member s spans))-                             $ getAnnSrcSpans (anns,cs)--           exploded = [((kw,ss),[anchor])-                      | ((anchor,kw),sss) <- Map.toList anns,ss <- sss]--           exploded' = Map.toList $ Map.fromListWith (++) exploded--           problems' = filter (\(_,anchors)-                                -> not (any (\a -> Set.member a spans) anchors))-                              exploded'--       putStrLn "---Problems---------------------"-       putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])-       putStrLn "---Problems'--------------------"-       putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems'])-       putStrLn "--------------------------------"-       putStrLn (intercalate "\n" [showAnns anns])--    where-      getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]-      getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns--      getAllSrcSpans :: (Data t) => t -> [SrcSpan]-      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast-        where-          getSrcSpan :: SrcSpan -> [SrcSpan]-          getSrcSpan ss = [ss]---showAnns anns = "[\n" ++ (intercalate "\n"-   $ map (\((s,k),v)-              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))-   $ Map.toList anns)-    ++ "]\n"--pp a = showPpr unsafeGlobalDynFlags a----- ------------------------------------------------------------------------- Copied from syb for the test----- | Generic queries of type \"r\",---   i.e., take any \"a\" and return an \"r\"----type GenericQ r = forall a. Data a => a -> r----- | Make a generic query;---   start from a type-specific case;---   return a constant otherwise----mkQ :: ( Typeable a-       , Typeable b-       )-    => r-    -> (b -> r)-    -> a-    -> r-(r `mkQ` br) a = case cast a of-                        Just b  -> br b-                        Nothing -> r------ | Summarise all nodes in top-down, left-to-right order-everything :: (r -> r -> r) -> GenericQ r -> GenericQ r---- Apply f to x to summarise top-level node;--- use gmapQ to recurse into immediate subterms;--- use ordinary foldl to reduce list of intermediate results--everything k f x = foldl k (f x) (gmapQ (everything k f) x)
− tests/examples/ghc80/Class.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Servant.Auth.Server.Internal.Class where--import Servant.Auth-import Data.Monoid-import Servant hiding (BasicAuth)--import Servant.Auth.Server.Internal.Types-import Servant.Auth.Server.Internal.ConfigTypes-import Servant.Auth.Server.Internal.BasicAuth-import Servant.Auth.Server.Internal.Cookie-import Servant.Auth.Server.Internal.JWT---- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all--- elements of @ctx@ to be the in the Context and whose authentication check--- returns an @AuthCheck v@.-class IsAuth a v  where-  type family AuthArgs a :: [*]-  runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)-
− tests/examples/ghc80/ClosedFam1a.hs 
@@ -1,3 +0,0 @@-module ClosedFam1a where--import {-# SOURCE #-} ClosedFam1
− tests/examples/ghc80/ClosedFam2a.hs 
@@ -1,2 +0,0 @@-module ClosedFam2a where-import {-# SOURCE #-} ClosedFam2
− tests/examples/ghc80/ClosedFam3a.hs 
@@ -1,3 +0,0 @@-module ClosedFam3a where--import {-# SOURCE #-} ClosedFam3
− tests/examples/ghc80/CmmSwitchTest.hs 
@@ -1,505 +0,0 @@-{-# LANGUAGE MagicHash #-}-import Control.Monad (unless, forM_)-import GHC.Exts-{-# NOINLINE aa #-}-aa :: Int# -> Int#-aa 1# = 42#-aa 2# = 43#-aa 3# = 43#-aa 4# = 44#-aa 5# = 44#-aa 6# = 45#-aa 7# = 45#-aa 8# = 46#-aa 9# = 46#-aa 10# = 47#-aa _ = 1337#--{-# NOINLINE ab #-}-ab :: Int# -> Int#-ab 0# = 42#-ab 1# = 42#-ab 2# = 43#-ab 3# = 43#-ab 4# = 44#-ab 5# = 44#-ab 6# = 45#-ab 7# = 45#-ab 8# = 46#-ab 9# = 46#-ab 10# = 47#-ab _ = 1337#--{-# NOINLINE ac #-}-ac :: Int# -> Int#-ac 1# = 42#-ac 2# = 43#-ac 3# = 43#-ac _ = 1337#--{-# NOINLINE ad #-}-ad :: Int# -> Int#-ad 1# = 42#-ad 2# = 43#-ad 3# = 43#-ad 4# = 44#-ad _ = 1337#--{-# NOINLINE ae #-}-ae :: Int# -> Int#-ae 1# = 42#-ae 2# = 43#-ae 3# = 43#-ae 4# = 44#-ae 5# = 44#-ae _ = 1337#--{-# NOINLINE af #-}-af :: Int# -> Int#-af -1# = 41#-af 0# = 42#-af 1# = 42#-af 2# = 43#-af 3# = 43#-af 4# = 44#-af 5# = 44#-af 6# = 45#-af 7# = 45#-af 8# = 46#-af 9# = 46#-af 10# = 47#-af _ = 1337#--{-# NOINLINE ag #-}-ag :: Int# -> Int#-ag -10# = 37#-ag -9# = 37#-ag -8# = 38#-ag -7# = 38#-ag -6# = 39#-ag -5# = 39#-ag -4# = 40#-ag -3# = 40#-ag -2# = 41#-ag -1# = 41#-ag 0# = 42#-ag 1# = 42#-ag 2# = 43#-ag 3# = 43#-ag 4# = 44#-ag 5# = 44#-ag 6# = 45#-ag 7# = 45#-ag 8# = 46#-ag 9# = 46#-ag 10# = 47#-ag _ = 1337#--{-# NOINLINE ah #-}-ah :: Int# -> Int#-ah -20# = 32#-ah -19# = 32#-ah -18# = 33#-ah -17# = 33#-ah -16# = 34#-ah -15# = 34#-ah -14# = 35#-ah -13# = 35#-ah -12# = 36#-ah -11# = 36#-ah -10# = 37#-ah 0# = 42#-ah 1# = 42#-ah 2# = 43#-ah 3# = 43#-ah 4# = 44#-ah 5# = 44#-ah 6# = 45#-ah 7# = 45#-ah 8# = 46#-ah 9# = 46#-ah 10# = 47#-ah _ = 1337#--{-# NOINLINE ai #-}-ai :: Int# -> Int#-ai -20# = 32#-ai -19# = 32#-ai -18# = 33#-ai -17# = 33#-ai -16# = 34#-ai -15# = 34#-ai -14# = 35#-ai -13# = 35#-ai -12# = 36#-ai -11# = 36#-ai -10# = 37#-ai 1# = 42#-ai 2# = 43#-ai 3# = 43#-ai 4# = 44#-ai 5# = 44#-ai 6# = 45#-ai 7# = 45#-ai 8# = 46#-ai 9# = 46#-ai 10# = 47#-ai _ = 1337#--{-# NOINLINE aj #-}-aj :: Int# -> Int#-aj -9223372036854775808# = -4611686018427387862#-aj 0# = 42#-aj 9223372036854775807# = 4611686018427387945#-aj _ = 1337#--{-# NOINLINE ak #-}-ak :: Int# -> Int#-ak 9223372036854775797# = 4611686018427387940#-ak 9223372036854775798# = 4611686018427387941#-ak 9223372036854775799# = 4611686018427387941#-ak 9223372036854775800# = 4611686018427387942#-ak 9223372036854775801# = 4611686018427387942#-ak 9223372036854775802# = 4611686018427387943#-ak 9223372036854775803# = 4611686018427387943#-ak 9223372036854775804# = 4611686018427387944#-ak 9223372036854775805# = 4611686018427387944#-ak 9223372036854775806# = 4611686018427387945#-ak 9223372036854775807# = 4611686018427387945#-ak _ = 1337#--{-# NOINLINE al #-}-al :: Int# -> Int#-al -9223372036854775808# = -4611686018427387862#-al -9223372036854775807# = -4611686018427387862#-al -9223372036854775806# = -4611686018427387861#-al -9223372036854775805# = -4611686018427387861#-al -9223372036854775804# = -4611686018427387860#-al -9223372036854775803# = -4611686018427387860#-al -9223372036854775802# = -4611686018427387859#-al -9223372036854775801# = -4611686018427387859#-al -9223372036854775800# = -4611686018427387858#-al -9223372036854775799# = -4611686018427387858#-al -9223372036854775798# = -4611686018427387857#-al 9223372036854775797# = 4611686018427387940#-al 9223372036854775798# = 4611686018427387941#-al 9223372036854775799# = 4611686018427387941#-al 9223372036854775800# = 4611686018427387942#-al 9223372036854775801# = 4611686018427387942#-al 9223372036854775802# = 4611686018427387943#-al 9223372036854775803# = 4611686018427387943#-al 9223372036854775804# = 4611686018427387944#-al 9223372036854775805# = 4611686018427387944#-al 9223372036854775806# = 4611686018427387945#-al 9223372036854775807# = 4611686018427387945#-al _ = 1337#--{-# NOINLINE am #-}-am :: Word# -> Word#-am 0## = 42##-am 1## = 42##-am 2## = 43##-am 3## = 43##-am 4## = 44##-am 5## = 44##-am 6## = 45##-am 7## = 45##-am 8## = 46##-am 9## = 46##-am 10## = 47##-am _ = 1337##--{-# NOINLINE an #-}-an :: Word# -> Word#-an 1## = 42##-an 2## = 43##-an 3## = 43##-an 4## = 44##-an 5## = 44##-an 6## = 45##-an 7## = 45##-an 8## = 46##-an 9## = 46##-an 10## = 47##-an _ = 1337##--{-# NOINLINE ao #-}-ao :: Word# -> Word#-ao 0## = 42##-ao _ = 1337##--{-# NOINLINE ap #-}-ap :: Word# -> Word#-ap 0## = 42##-ap 1## = 42##-ap _ = 1337##--{-# NOINLINE aq #-}-aq :: Word# -> Word#-aq 0## = 42##-aq 1## = 42##-aq 2## = 43##-aq _ = 1337##--{-# NOINLINE ar #-}-ar :: Word# -> Word#-ar 0## = 42##-ar 1## = 42##-ar 2## = 43##-ar 3## = 43##-ar _ = 1337##--{-# NOINLINE as #-}-as :: Word# -> Word#-as 0## = 42##-as 1## = 42##-as 2## = 43##-as 3## = 43##-as 4## = 44##-as _ = 1337##--{-# NOINLINE at #-}-at :: Word# -> Word#-at 1## = 42##-at _ = 1337##--{-# NOINLINE au #-}-au :: Word# -> Word#-au 1## = 42##-au 2## = 43##-au _ = 1337##--{-# NOINLINE av #-}-av :: Word# -> Word#-av 1## = 42##-av 2## = 43##-av 3## = 43##-av _ = 1337##--{-# NOINLINE aw #-}-aw :: Word# -> Word#-aw 1## = 42##-aw 2## = 43##-aw 3## = 43##-aw 4## = 44##-aw _ = 1337##--{-# NOINLINE ax #-}-ax :: Word# -> Word#-ax 1## = 42##-ax 2## = 43##-ax 3## = 43##-ax 4## = 44##-ax 5## = 44##-ax _ = 1337##--{-# NOINLINE ay #-}-ay :: Word# -> Word#-ay 0## = 42##-ay 18446744073709551615## = 9223372036854775849##-ay _ = 1337##--{-# NOINLINE az #-}-az :: Word# -> Word#-az 18446744073709551605## = 9223372036854775844##-az 18446744073709551606## = 9223372036854775845##-az 18446744073709551607## = 9223372036854775845##-az 18446744073709551608## = 9223372036854775846##-az 18446744073709551609## = 9223372036854775846##-az 18446744073709551610## = 9223372036854775847##-az 18446744073709551611## = 9223372036854775847##-az 18446744073709551612## = 9223372036854775848##-az 18446744073709551613## = 9223372036854775848##-az 18446744073709551614## = 9223372036854775849##-az 18446744073709551615## = 9223372036854775849##-az _ = 1337##--{-# NOINLINE ba #-}-ba :: Word# -> Word#-ba 0## = 42##-ba 1## = 42##-ba 2## = 43##-ba 3## = 43##-ba 4## = 44##-ba 5## = 44##-ba 6## = 45##-ba 7## = 45##-ba 8## = 46##-ba 9## = 46##-ba 10## = 47##-ba 18446744073709551605## = 9223372036854775844##-ba 18446744073709551606## = 9223372036854775845##-ba 18446744073709551607## = 9223372036854775845##-ba 18446744073709551608## = 9223372036854775846##-ba 18446744073709551609## = 9223372036854775846##-ba 18446744073709551610## = 9223372036854775847##-ba 18446744073709551611## = 9223372036854775847##-ba 18446744073709551612## = 9223372036854775848##-ba 18446744073709551613## = 9223372036854775848##-ba 18446744073709551614## = 9223372036854775849##-ba 18446744073709551615## = 9223372036854775849##-ba _ = 1337##--aa_check :: IO ()-aa_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do-   let r = I# (aa i)-   unless (r == o) $ putStrLn $ "ERR: aa (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ab_check :: IO ()-ab_check = forM_ [(-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do-   let r = I# (ab i)-   unless (r == o) $ putStrLn $ "ERR: ab (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ac_check :: IO ()-ac_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(I# i,o) -> do-   let r = I# (ac i)-   unless (r == o) $ putStrLn $ "ERR: ac (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ad_check :: IO ()-ad_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(I# i,o) -> do-   let r = I# (ad i)-   unless (r == o) $ putStrLn $ "ERR: ad (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ae_check :: IO ()-ae_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(I# i,o) -> do-   let r = I# (ae i)-   unless (r == o) $ putStrLn $ "ERR: ae (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--af_check :: IO ()-af_check = forM_ [(-2,1337), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do-   let r = I# (af i)-   unless (r == o) $ putStrLn $ "ERR: af (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ag_check :: IO ()-ag_check = forM_ [(-11,1337), (-10,37), (-9,37), (-8,38), (-7,38), (-6,39), (-5,39), (-4,40), (-3,40), (-2,41), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do-   let r = I# (ag i)-   unless (r == o) $ putStrLn $ "ERR: ag (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ah_check :: IO ()-ah_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do-   let r = I# (ah i)-   unless (r == o) $ putStrLn $ "ERR: ah (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ai_check :: IO ()-ai_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do-   let r = I# (ai i)-   unless (r == o) $ putStrLn $ "ERR: ai (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--aj_check :: IO ()-aj_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,1337), (-1,1337), (0,42), (1,1337), (9223372036854775806,1337), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do-   let r = I# (aj i)-   unless (r == o) $ putStrLn $ "ERR: aj (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ak_check :: IO ()-ak_check = forM_ [(9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do-   let r = I# (ak i)-   unless (r == o) $ putStrLn $ "ERR: ak (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--al_check :: IO ()-al_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,-4611686018427387862), (-9223372036854775806,-4611686018427387861), (-9223372036854775805,-4611686018427387861), (-9223372036854775804,-4611686018427387860), (-9223372036854775803,-4611686018427387860), (-9223372036854775802,-4611686018427387859), (-9223372036854775801,-4611686018427387859), (-9223372036854775800,-4611686018427387858), (-9223372036854775799,-4611686018427387858), (-9223372036854775798,-4611686018427387857), (-9223372036854775797,1337), (9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do-   let r = I# (al i)-   unless (r == o) $ putStrLn $ "ERR: al (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--am_check :: IO ()-am_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do-   let r = W# (am i)-   unless (r == o) $ putStrLn $ "ERR: am (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--an_check :: IO ()-an_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do-   let r = W# (an i)-   unless (r == o) $ putStrLn $ "ERR: an (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ao_check :: IO ()-ao_check = forM_ [(0,42), (1,1337)] $ \(W# i,o) -> do-   let r = W# (ao i)-   unless (r == o) $ putStrLn $ "ERR: ao (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ap_check :: IO ()-ap_check = forM_ [(0,42), (1,42), (2,1337)] $ \(W# i,o) -> do-   let r = W# (ap i)-   unless (r == o) $ putStrLn $ "ERR: ap (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--aq_check :: IO ()-aq_check = forM_ [(0,42), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do-   let r = W# (aq i)-   unless (r == o) $ putStrLn $ "ERR: aq (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ar_check :: IO ()-ar_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do-   let r = W# (ar i)-   unless (r == o) $ putStrLn $ "ERR: ar (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--as_check :: IO ()-as_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do-   let r = W# (as i)-   unless (r == o) $ putStrLn $ "ERR: as (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--at_check :: IO ()-at_check = forM_ [(0,1337), (1,42), (2,1337)] $ \(W# i,o) -> do-   let r = W# (at i)-   unless (r == o) $ putStrLn $ "ERR: at (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--au_check :: IO ()-au_check = forM_ [(0,1337), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do-   let r = W# (au i)-   unless (r == o) $ putStrLn $ "ERR: au (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--av_check :: IO ()-av_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do-   let r = W# (av i)-   unless (r == o) $ putStrLn $ "ERR: av (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--aw_check :: IO ()-aw_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do-   let r = W# (aw i)-   unless (r == o) $ putStrLn $ "ERR: aw (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ax_check :: IO ()-ax_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(W# i,o) -> do-   let r = W# (ax i)-   unless (r == o) $ putStrLn $ "ERR: ax (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ay_check :: IO ()-ay_check = forM_ [(0,42), (1,1337), (18446744073709551614,1337), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do-   let r = W# (ay i)-   unless (r == o) $ putStrLn $ "ERR: ay (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--az_check :: IO ()-az_check = forM_ [(18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do-   let r = W# (az i)-   unless (r == o) $ putStrLn $ "ERR: az (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--ba_check :: IO ()-ba_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337), (18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do-   let r = W# (ba i)-   unless (r == o) $ putStrLn $ "ERR: ba (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"."--main = do-    aa_check-    ab_check-    ac_check-    ad_check-    ae_check-    af_check-    ag_check-    ah_check-    ai_check-    aj_check-    ak_check-    al_check-    am_check-    an_check-    ao_check-    ap_check-    aq_check-    ar_check-    as_check-    at_check-    au_check-    av_check-    aw_check-    ax_check-    ay_check-    az_check-    ba_check
− tests/examples/ghc80/CmmSwitchTestGen.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE TupleSections #-}---- Generates CmmSwitch.hs--import qualified Data.Set as S-import Data.Word-import Data.List--output :: Integer -> Integer-output n = n`div`2 + 42--def :: Integer-def = 1337--type Spec = (String, Bool, [Integer])--primtyp True = "Int#"-primtyp False = "Word#"--con True = "I#"-con False = "W#"--hash True = "#"-hash False = "##"--primLit s v = show v ++ hash s--genSwitch :: Spec -> String-genSwitch (name, signed, values) = unlines $-  [ "{-# NOINLINE " ++ name ++ " #-}" ] ++-  [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++-  [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v)-  | v <- values] ++-  [ name ++ " _ = " ++ primLit signed def ]--genCheck :: Spec -> String-genCheck (name, signed, values) = unlines $-  [ checkName name ++ " :: IO ()"-  , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do"-  , "   let r = " ++ con signed ++ " (" ++ name ++ " i)"-  , "   unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\""-  ]-  where-    f x | x `S.member` range = output x-        | otherwise          = def-    range = S.fromList values-    checkValues = S.toList $ S.fromList $-        [ v' | v <- values, v' <- [v-1,v,v+1],-               if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ]-    pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ]--checkName :: String -> String-checkName f = f ++ "_check"--genMain :: [Spec] -> String-genMain specs = unlines $ "main = do" : [ "    " ++ checkName n | (n,_,_) <- specs ]--genMod :: [Spec] -> String-genMod specs = unlines $-    "-- This file is generated from CmmSwitchGen!" :-    "{-# LANGUAGE MagicHash, NegativeLiterals #-}" :-    "import Control.Monad (unless, forM_)" :-    "import GHC.Exts" :-    map genSwitch specs ++-    map genCheck specs ++-    [ genMain specs ]--main = putStrLn $-    genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks---signedChecks :: [(Bool, [Integer])]-signedChecks = map (True,)-    [ [1..10]-    , [0..10]-    , [1..3]-    , [1..4]-    , [1..5]-    , [-1..10]-    , [-10..10]-    , [-20.. -10]++[0..10]-    , [-20.. -10]++[1..10]-    , [minS,0,maxS]-    , [maxS-10 .. maxS]-    , [minS..minS+10]++[maxS-10 .. maxS]-    ]--minU, maxU, minS, maxS :: Integer-minU = 0-maxU = fromIntegral (maxBound :: Word)-minS = fromIntegral (minBound :: Int)-maxS = fromIntegral (maxBound :: Int)---unsignedChecks :: [(Bool, [Integer])]-unsignedChecks = map (False,)-    [ [0..10]-    , [1..10]-    , [0]-    , [0..1]-    , [0..2]-    , [0..3]-    , [0..4]-    , [1]-    , [1..2]-    , [1..3]-    , [1..4]-    , [1..5]-    , [minU,maxU]-    , [maxU-10 .. maxU]-    , [minU..minU+10]++[maxU-10 .. maxU]-    ]--names :: [String]-names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']]
− tests/examples/ghc80/Collapse1.hs 
@@ -1,16 +0,0 @@-module LiftToTop3evel.Collapse1 where--collapse' _ _ [] = []-collapse' left space (t:ts) = new : collapse' right space rest-  where-    (_, leftInner)  = left-    rightInner      = leftInner   + symbolSize t-    right           = (rightInner, (rightOuter rightInner rights))-    (rights, rest)  = span space ts-    new             = (t, Bounds left right)--rightOuter rightInner rights      = rightInner  + symbolSize rights--data Bounds = Bounds (Int,Int) (Int,Int)-symbolSize t = 4-
− tests/examples/ghc80/Compare.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE Trustworthy,-    TypeOperators,-    PolyKinds, DataKinds,-    TypeFamilies,-    UndecidableInstances #-}---module Type.Compare where--import Data.Ord-import GHC.TypeLits--type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where-  LT $$ b = LT-  GT $$ b = GT-  EQ $$ b = b-infixl 0 $$---- | Compare two types of any (possibly different) kinds.--- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types.-type family Compare (a :: k) (b :: k') :: Ordering where--  Compare '() '() = EQ
− tests/examples/ghc80/CustomTypeErrors01.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE DataKinds, UndecidableInstances #-}-module T1 where-import GHC.TypeLits---data MyType = MyType--instance-  TypeError (Text "Values of type 'MyType' cannot be compared for equality.")-    => Eq MyType where (==) = undefined--err x = x == MyType--
− tests/examples/ghc80/CustomTypeErrors02.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE DataKinds, UndecidableInstances #-}-{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-}-module T2 where--import GHC.TypeLits--type family IntRep a where-  IntRep Int      = Integer-  IntRep Integer  = Integer-  IntRep Bool     = Integer-  IntRep a        = TypeError (Text "The type '" :<>: ShowType a :<>:-                               Text "' cannot be represented as an integer.")--convert :: Num (IntRep a) => a -> IntRep a-convert _ = 5--err = convert id--
− tests/examples/ghc80/CustomTypeErrors03.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE DataKinds #-}-module T3 where--import GHC.TypeLits--f :: TypeError (Text "This is a type error")-f = undefined
− tests/examples/ghc80/D.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module D where--import A-import C--type instance F a b = a--unsafeCoerce :: a -> b-unsafeCoerce x = oops x x
− tests/examples/ghc80/DataFamilyInstanceLHS.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-}-module DataFamilyInstanceLHS where--- Test case from #10586-data MyKind = A | B--data family Sing (a :: k)--data instance Sing (_ :: MyKind) where-    SingA :: Sing A-    SingB :: Sing B--foo :: Sing A-foo = SingA
− tests/examples/ghc80/DatatypeContexts.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE DatatypeContexts #-}-{-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE TypeFamilies     #-}--- I don't know how to silence the -XDatatypeContexts warnings otherwise...-{-# OPTIONS_GHC -w #-}--{-|-Module:      Derived.DatatypeContexts-Copyright:   (C) 2014-2016 Ryan Scott-License:     BSD-style (see the file LICENSE)-Maintainer:  Ryan Scott-Stability:   Provisional-Portability: GHC--Defines data types with DatatypeContexts (which are gross, but still possible).--}-module Derived.DatatypeContexts where---data family TyFamily x y z :: *--data instance Ord a => TyFamily a b c = TyFamily a b c-  deriving Show-
− tests/examples/ghc80/Decision.hs 
@@ -1,726 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}--module Airship.Internal.Decision-    ( flow-    , appendRequestPath-    ) where--import           Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123)-import           Airship.Headers (addResponseHeader)-import           Airship.Types ( Response(..)-                               , ResponseBody(..)-                               , Webmachine-                               , etagToByteString-                               , getResponseBody-                               , getResponseHeaders-                               , halt-                               , pathInfo-                               , putResponseBody-                               , request-                               , requestHeaders-                               , requestMethod-                               , requestTime )--import           Airship.Resource(Resource(..), PostResponse(..))-import           Airship.Internal.Parsers (parseEtagList)-#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative ((<$>))-#endif-import           Control.Monad (when)-import           Control.Monad.Trans (lift)-import           Control.Monad.Trans.State.Strict (StateT(..), evalStateT,-                                                   get, modify)-import           Control.Monad.Writer.Class (tell)--import           Blaze.ByteString.Builder (toByteString)-import           Data.Maybe (isJust)-import           Data.Text (Text)-import           Data.Time.Clock (UTCTime)-import           Data.ByteString                  (ByteString, intercalate)--import           Network.HTTP.Media-import qualified Network.HTTP.Types as HTTP----------------------------------------------------------------------------------- HTTP Headers--- These are headers not defined for us already in--- Network.HTTP.Types---------------------------------------------------------------------------------- TODO this exist in http-types-0.9, see CHANGES.txt-hAcceptCharset :: HTTP.HeaderName-hAcceptCharset = "Accept-Charset"--hAcceptEncoding :: HTTP.HeaderName-hAcceptEncoding = "Accept-Encoding"--hIfMatch :: HTTP.HeaderName-hIfMatch = "If-Match"--hIfUnmodifiedSince :: HTTP.HeaderName-hIfUnmodifiedSince = "If-Unmodified-Since"--hIfNoneMatch :: HTTP.HeaderName-hIfNoneMatch = "If-None-Match"----------------------------------------------------------------------------------- FlowState: StateT used for recording information as we walk the decision--- tree---------------------------------------------------------------------------------data FlowState m = FlowState-    { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) }--type FlowStateT m a = StateT (FlowState m) (Webmachine m) a--type Flow m = Resource m -> FlowStateT m Response--initFlowState :: FlowState m-initFlowState = FlowState Nothing--flow :: Monad m => Resource m -> Webmachine m Response-flow r = evalStateT (b13 r) initFlowState--trace :: Monad m => Text -> FlowStateT m ()-trace t = lift $ tell [t]---------------------------------------------------------------------------------- Header value data newtypes---------------------------------------------------------------------------------newtype IfMatch = IfMatch ByteString-newtype IfNoneMatch = IfNoneMatch ByteString----------------------------------------------------------------------------------- Decision Helpers---------------------------------------------------------------------------------negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m ()-negotiateContentTypesAccepted Resource{..} = do-    req <- lift request-    accepted <- lift contentTypesAccepted-    let reqHeaders = requestHeaders req-        result = do-            cType <- lookup HTTP.hContentType reqHeaders-            mapContentMedia accepted cType-    case result of-        (Just process) -> lift process-        Nothing -> lift $ halt HTTP.status415--appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString-appendRequestPath ts = do-    currentPath <- pathInfo <$> request-    return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts))--requestHeaderDate :: Monad m => HTTP.HeaderName ->-                                Webmachine m (Maybe UTCTime)-requestHeaderDate headerName = do-    req <- request-    let reqHeaders = requestHeaders req-        dateHeader = lookup headerName reqHeaders-        parsedDate = dateHeader >>= parseRfc1123Date-    return parsedDate--writeCacheTags :: Monad m => Resource m -> FlowStateT m ()-writeCacheTags Resource{..} = lift $ do-    etag <- generateETag-    case etag of-       Nothing -> return ()-       Just t  -> addResponseHeader ("ETag", etagToByteString t)-    modified <- lastModified-    case modified of-       Nothing -> return ()-       Just d  -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d)----------------------------------------------------------------------------------- Type definitions for all decision nodes---------------------------------------------------------------------------------b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow  m-c04, c03 :: Monad m => Flow  m-d05, d04 :: Monad m => Flow  m-e06, e05 :: Monad m => Flow  m-f07, f06 :: Monad m => Flow  m-g11, g09 :: Monad m => IfMatch -> Flow m-g08, g07 :: Monad m => Flow  m-h12, h11, h10, h07 :: Monad m => Flow  m-i13 :: Monad m => IfNoneMatch -> Flow m-i12, i07, i04 :: Monad m => Flow  m-j18 :: Monad m => Flow  m-k13 :: Monad m => IfNoneMatch -> Flow m-k07, k05 :: Monad m => Flow  m-l17, l15, l14, l13, l07, l05 :: Monad m => Flow  m-m20, m16, m07, m05 :: Monad m => Flow  m-n16, n11, n05 :: Monad m => Flow  m-o20, o18, o16, o14 :: Monad m => Flow  m-p11, p03 :: Monad m => Flow  m----------------------------------------------------------------------------------- B column---------------------------------------------------------------------------------b13 r@Resource{..} = do-    trace "b13"-    available <- lift serviceAvailable-    if available-        then b12 r-        else lift $ halt HTTP.status503--b12 r@Resource{..} = do-    trace "b12"-    -- known method-    req <- lift request-    let knownMethods = [ HTTP.methodGet-                       , HTTP.methodPost-                       , HTTP.methodHead-                       , HTTP.methodPut-                       , HTTP.methodDelete-                       , HTTP.methodTrace-                       , HTTP.methodConnect-                       , HTTP.methodOptions-                       , HTTP.methodPatch-                       ]-    if requestMethod req `elem` knownMethods-        then b11 r-        else lift $ halt HTTP.status501--b11 r@Resource{..} = do-    trace "b11"-    long <- lift uriTooLong-    if long-        then lift $ halt HTTP.status414-        else b10 r--b10 r@Resource{..} = do-    trace "b10"-    req <- lift request-    allowed <- lift allowedMethods-    if requestMethod req `elem` allowed-        then b09 r-        else do-            lift $ addResponseHeader ("Allow",  intercalate "," allowed)-            lift $ halt HTTP.status405--b09 r@Resource{..} = do-    trace "b09"-    malformed <- lift malformedRequest-    if malformed-        then lift $ halt HTTP.status400-        else b08 r--b08 r@Resource{..} = do-    trace "b08"-    authorized <- lift isAuthorized-    if authorized-        then b07 r-        else lift $ halt HTTP.status401--b07 r@Resource{..} = do-    trace "b07"-    forbid <- lift forbidden-    if forbid-        then lift $ halt HTTP.status403-        else b06 r--b06 r@Resource{..} = do-    trace "b06"-    validC <- lift validContentHeaders-    if validC-        then b05 r-        else lift $ halt HTTP.status501--b05 r@Resource{..} = do-    trace "b05"-    known <- lift knownContentType-    if known-        then b04 r-        else lift $ halt HTTP.status415--b04 r@Resource{..} = do-    trace "b04"-    large <- lift entityTooLarge-    if large-        then lift $ halt HTTP.status413-        else b03 r--b03 r@Resource{..} = do-    trace "b03"-    req <- lift request-    allowed <- lift allowedMethods-    if requestMethod req == HTTP.methodOptions-        then do-            lift $ addResponseHeader ("Allow",  intercalate "," allowed)-            lift $ halt HTTP.status204-        else c03 r----------------------------------------------------------------------------------- C column---------------------------------------------------------------------------------c04 r@Resource{..} = do-    trace "c04"-    req <- lift request-    provided <- lift contentTypesProvided-    let reqHeaders = requestHeaders req-        result = do-            acceptStr <- lookup HTTP.hAccept reqHeaders-            (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr-            Just (acceptTyp, resource)-            where-                -- this is so that in addition to getting back the resource-                -- that we match, we also return the content-type provided-                -- by that resource.-                provided' = map dupContentType provided-                dupContentType (a, b) = (a, (a, b))--    case result of-      Nothing -> lift $ halt HTTP.status406-      Just res -> do-        modify (\fs -> fs { _contentType = Just res })-        d04 r--c03 r@Resource{..} = do-    trace "c03"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup HTTP.hAccept reqHeaders of-        (Just _h) ->-            c04 r-        Nothing ->-            d04 r----------------------------------------------------------------------------------- D column---------------------------------------------------------------------------------d05 r@Resource{..} = do-    trace "d05"-    langAvailable <- lift languageAvailable-    if langAvailable-        then e05 r-        else lift $ halt HTTP.status406--d04 r@Resource{..} = do-    trace "d04"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup HTTP.hAcceptLanguage reqHeaders of-        (Just _h) ->-            d05 r-        Nothing ->-            e05 r----------------------------------------------------------------------------------- E column---------------------------------------------------------------------------------e06 r@Resource{..} = do-    trace "e06"-    -- TODO: charset negotiation-    f06 r--e05 r@Resource{..} = do-    trace "e05"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup hAcceptCharset reqHeaders of-        (Just _h) ->-            e06 r-        Nothing ->-            f06 r----------------------------------------------------------------------------------- F column---------------------------------------------------------------------------------f07 r@Resource{..} = do-    trace "f07"-    -- TODO: encoding negotiation-    g07 r--f06 r@Resource{..} = do-    trace "f06"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup hAcceptEncoding reqHeaders of-        (Just _h) ->-            f07 r-        Nothing ->-            g07 r----------------------------------------------------------------------------------- G column---------------------------------------------------------------------------------g11 (IfMatch ifMatch) r@Resource{..} = do-    trace "g11"-    let etags = parseEtagList ifMatch-    if null etags-        then lift $ halt HTTP.status412-        else h10 r--g09 ifMatch r@Resource{..} = do-    trace "g09"-    case ifMatch of-        -- TODO: should we be stripping whitespace here?-        (IfMatch "*") ->-            h10 r-        _ ->-            g11 ifMatch r--g08 r@Resource{..} = do-    trace "g08"-    req <- lift request-    let reqHeaders = requestHeaders req-    case IfMatch <$> lookup hIfMatch reqHeaders of-        (Just h) ->-            g09 h r-        Nothing ->-            h10 r--g07 r@Resource{..} = do-    trace "g07"-    -- TODO: set Vary headers-    exists <- lift resourceExists-    if exists-        then g08 r-        else h07 r----------------------------------------------------------------------------------- H column---------------------------------------------------------------------------------h12 r@Resource{..} = do-    trace "h12"-    modified <- lift lastModified-    parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince-    let maybeGreater = do-            lastM <- modified-            headerDate <- parsedDate-            return (lastM > headerDate)-    if maybeGreater == Just True-        then lift $ halt HTTP.status412-        else i12 r--h11 r@Resource{..} = do-    trace "h11"-    parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince-    if isJust parsedDate-        then h12 r-        else i12 r--h10 r@Resource{..} = do-    trace "h10"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup hIfUnmodifiedSince reqHeaders of-        (Just _h) ->-            h11 r-        Nothing ->-            i12 r--h07 r@Resource {..} = do-    trace "h07"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup hIfMatch reqHeaders of-        -- TODO: should we be stripping whitespace here?-        (Just "*") ->-            lift $ halt HTTP.status412-        _ ->-            i07 r----------------------------------------------------------------------------------- I column---------------------------------------------------------------------------------i13 ifNoneMatch r@Resource{..} = do-    trace "i13"-    case ifNoneMatch of-        -- TODO: should we be stripping whitespace here?-        (IfNoneMatch "*") ->-            j18 r-        _ ->-            k13 ifNoneMatch r--i12 r@Resource{..} = do-    trace "i12"-    req <- lift request-    let reqHeaders = requestHeaders req-    case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of-        (Just h) ->-            i13 h r-        Nothing ->-            l13 r--i07 r = do-    trace "i07"-    req <- lift request-    if requestMethod req == HTTP.methodPut-        then i04 r-        else k07 r--i04 r@Resource{..} = do-    trace "i04"-    moved <- lift movedPermanently-    case moved of-        (Just loc) -> do-            lift $ addResponseHeader ("Location", loc)-            lift $ halt HTTP.status301-        Nothing ->-            p03 r----------------------------------------------------------------------------------- J column---------------------------------------------------------------------------------j18 _ = do-    trace "j18"-    req <- lift request-    let getOrHead = [ HTTP.methodGet-                    , HTTP.methodHead-                    ]-    if requestMethod req `elem` getOrHead-        then lift $ halt HTTP.status304-        else lift $ halt HTTP.status412----------------------------------------------------------------------------------- K column---------------------------------------------------------------------------------k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do-    trace "k13"-    let etags = parseEtagList ifNoneMatch-    if null etags-        then l13 r-        else j18 r--k07 r@Resource{..} = do-    trace "k07"-    prevExisted <- lift previouslyExisted-    if prevExisted-        then k05 r-        else l07 r--k05 r@Resource{..} = do-    trace "k05"-    moved <- lift movedPermanently-    case moved of-        (Just loc) -> do-            lift $ addResponseHeader ("Location", loc)-            lift $ halt HTTP.status301-        Nothing ->-            l05 r----------------------------------------------------------------------------------- L column---------------------------------------------------------------------------------l17 r@Resource{..} = do-    trace "l17"-    parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince-    modified <- lift lastModified-    let maybeGreater = do-            lastM <- modified-            ifModifiedSince <- parsedDate-            return (lastM > ifModifiedSince)-    if maybeGreater == Just True-        then m16 r-        else lift $ halt HTTP.status304--l15 r@Resource{..} = do-    trace "l15"-    parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince-    now <- lift requestTime-    let maybeGreater = (> now) <$> parsedDate-    if maybeGreater == Just True-        then m16 r-        else l17 r--l14 r@Resource{..} = do-    trace "l14"-    req <- lift request-    let reqHeaders = requestHeaders req-        dateHeader = lookup HTTP.hIfModifiedSince reqHeaders-        validDate = isJust (dateHeader >>= parseRfc1123Date)-    if validDate-        then l15 r-        else m16 r--l13 r@Resource{..} = do-    trace "l13"-    req <- lift request-    let reqHeaders = requestHeaders req-    case lookup HTTP.hIfModifiedSince reqHeaders of-        (Just _h) ->-            l14 r-        Nothing ->-            m16 r--l07 r = do-    trace "l07"-    req <- lift request-    if requestMethod req == HTTP.methodPost-        then m07 r-        else lift $ halt HTTP.status404--l05 r@Resource{..} = do-    trace "l05"-    moved <- lift movedTemporarily-    case moved of-        (Just loc) -> do-            lift $ addResponseHeader ("Location", loc)-            lift $ halt HTTP.status307-        Nothing ->-            m05 r----------------------------------------------------------------------------------- M column---------------------------------------------------------------------------------m20 r@Resource{..} = do-    trace "m20"-    deleteAccepted <- lift deleteResource-    if deleteAccepted-        then do-            completed <- lift deleteCompleted-            if completed-                then o20 r-                else lift $ halt HTTP.status202-        else lift $ halt HTTP.status500--m16 r = do-    trace "m16"-    req <- lift request-    if requestMethod req == HTTP.methodDelete-        then m20 r-        else n16 r--m07 r@Resource{..} = do-    trace "m07"-    allowMissing <- lift allowMissingPost-    if allowMissing-        then n11 r-        else lift $ halt HTTP.status404--m05 r = do-    trace "m05"-    req <- lift request-    if requestMethod req == HTTP.methodPost-        then n05 r-        else lift $ halt HTTP.status410----------------------------------------------------------------------------------- N column---------------------------------------------------------------------------------n16 r = do-    trace "n16"-    req <- lift request-    if requestMethod req == HTTP.methodPost-        then n11 r-        else o16 r--n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r--create :: Monad m => [Text] -> Resource m -> FlowStateT m ()-create ts r = do-    loc <- lift (appendRequestPath ts)-    lift (addResponseHeader ("Location", loc))-    negotiateContentTypesAccepted r--processPostAction :: Monad m => PostResponse m -> Flow  m-processPostAction (PostCreate ts) r = do-    create ts r-    p11 r-processPostAction (PostCreateRedirect ts) r = do-    create ts r-    lift $ halt HTTP.status303-processPostAction (PostProcess p) r =-    lift p >> p11 r-processPostAction (PostProcessRedirect ts) _r = do-    locBs <- lift ts-    lift $ addResponseHeader ("Location", locBs)-    lift $ halt HTTP.status303--n05 r@Resource{..} = do-    trace "n05"-    allow <- lift allowMissingPost-    if allow-        then n11 r-        else lift $ halt HTTP.status410----------------------------------------------------------------------------------- O column---------------------------------------------------------------------------------o20 r = do-    trace "o20"-    body <- lift getResponseBody-    -- ResponseBody is a little tough to make an instance of 'Eq',-    -- so we just use a pattern match-    case body of-        Empty   -> lift $ halt HTTP.status204-        _       -> o18 r--o18 r@Resource{..} = do-    trace "o18"-    multiple <- lift multipleChoices-    if multiple-        then lift $ halt HTTP.status300-        else do-            -- TODO: set etag, expiration, etc. headers-            req <- lift request-            let getOrHead = [ HTTP.methodGet-                            , HTTP.methodHead-                            ]-            when (requestMethod req `elem` getOrHead) $ do-                m <- _contentType <$> get-                (cType, body) <- case m of-                    Nothing -> do-                        provided <- lift contentTypesProvided-                        return (head provided)-                    Just (cType, body) ->-                        return (cType, body)-                b <- lift body-                lift $ putResponseBody b-                lift $ addResponseHeader ("Content-Type", renderHeader cType)-            writeCacheTags r-            lift $ halt HTTP.status200--o16 r = do-    trace "o16"-    req <- lift request-    if requestMethod req == HTTP.methodPut-        then o14 r-        else o18 r--o14 r@Resource{..} = do-    trace "o14"-    conflict <- lift isConflict-    if conflict-        then lift $ halt HTTP.status409-        else negotiateContentTypesAccepted r >> p11 r----------------------------------------------------------------------------------- P column---------------------------------------------------------------------------------p11 r = do-    trace "p11"-    headers <- lift getResponseHeaders-    case lookup HTTP.hLocation headers of-        (Just _) ->-            lift $ halt HTTP.status201-        _ ->-            o20 r--p03 r@Resource{..} = do-    trace "p03"-    conflict <- lift isConflict-    if conflict-        then lift $ halt HTTP.status409-        else negotiateContentTypesAccepted r >> p11 r
− tests/examples/ghc80/Defer03.hs 
@@ -1,7 +0,0 @@-module Main where--a :: Int-a = 'p'--main :: IO ()-main = print "No errors!"
− tests/examples/ghc80/Dep1.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE TypeInType #-}--module Dep1 where--import Data.Kind--data Proxy k (a :: k) = P--x :: Proxy * Int-x = P--y :: Proxy Bool True-y = P
− tests/examples/ghc80/Dep2.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE PolyKinds, GADTs #-}--module Dep2 where--data G (a :: k) where-  G1 :: G Int-  G2 :: G Maybe
− tests/examples/ghc80/DepFail1.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE TypeInType #-}--module DepFail1 where--data Proxy k (a :: k) = P--z :: Proxy Bool-z = P--a :: Proxy Int Bool-a = P
− tests/examples/ghc80/DeprM.hs 
@@ -1,4 +0,0 @@-module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where--f :: Int-f = 42
− tests/examples/ghc80/DeprU.hs 
@@ -1,6 +0,0 @@-module A where--import DeprM -- here should be emitted deprecation warning--g :: Int-g = f
− tests/examples/ghc80/Deprecation.hs 
@@ -1,16 +0,0 @@--module Deprecation-{-# Deprecated ["This is a module \"deprecation\"",-             "multi-line",-             "with unicode: Frère" ] #-}-   ( foo )- where--{-# DEPRECATEd   foo-         ["This is a multi-line",-          "deprecation message",-          "for foo"] #-}-foo :: Int-foo = 4--{-# DEPRECATED withBool        "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
− tests/examples/ghc80/DsStrict.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE Strict #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-module Main where--import Debug.Trace--f0 a = "fun"-f0' ~a = "fun2"--f1 ~n =-  case n of-    a -> "case"-f1' ~n =-  case n of-    ~a -> "case2"--f2 = \a -> "lamda"-f2' = \ ~a -> "lambda2"--newtype Age = MkAge Int--f4, f4' :: Age -> String-f4 (MkAge a) = "newtype"-f4' ~(MkAge a) = "newtype2"--main :: IO ()-main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs-  where fs =-          [("fun",f0 )-          ,("fun lazy",f0')-          ,("case",f1)-          ,("case lazy",f1')-          ,("lambda",f2)-          ,("lambda lazy",f2')-          ,("newtype",(\ ~i -> f4 (MkAge i)))-          ,("newtype lazy",(\ ~i -> f4' (MkAge i)))]-        v n = trace ("evaluated in " ++ n) 1
− tests/examples/ghc80/DsStrictData.hs 
@@ -1,48 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-}---- | Tests the StrictData LANGUAGE pragma.-module Main where--import qualified Control.Exception as E-import System.IO.Unsafe (unsafePerformIO)--data Strict a = S a-data Strict2 b = S2 !b-data Strict3 c where-  S3 :: c -> Strict3 c--data UStrict = US {-# UNPACK #-} Int--data Lazy d = L ~d-data Lazy2 e where-  L2 :: ~e -> Lazy2 e--main :: IO ()-main =-  do print (isBottom (S bottom))-     print (isBottom (S2 bottom))-     print (isBottom (US bottom))-     print (isBottom (S3 bottom))-     putStrLn ""-     print (not (isBottom (L bottom)))-     print (not (isBottom (L2 bottom)))-     print (not (isBottom (Just bottom))) -- sanity check----------------------------------------------------------------------------- Support for testing for bottom--bottom :: a-bottom = error "_|_"--isBottom :: a -> Bool-isBottom f = unsafePerformIO $-  (E.evaluate f >> return False) `E.catches`-    [ E.Handler (\(_ :: E.ArrayException)   -> return True)-    , E.Handler (\(_ :: E.ErrorCall)        -> return True)-    , E.Handler (\(_ :: E.NoMethodError)    -> return True)-    , E.Handler (\(_ :: E.NonTermination)   -> return True)-    , E.Handler (\(_ :: E.PatternMatchFail) -> return True)-    , E.Handler (\(_ :: E.RecConError)      -> return True)-    , E.Handler (\(_ :: E.RecSelError)      -> return True)-    , E.Handler (\(_ :: E.RecUpdError)      -> return True)-    ]
− tests/examples/ghc80/DsStrictFail.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE Strict #-}-module Main where--main = let False = True-       in return ()
− tests/examples/ghc80/DsStrictLet.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE Strict #-}-module Main where--import Debug.Trace--main = let False = trace "no binders" False -- evaluated--           a :: a -> a-           a = trace "polymorphic" id -- evaluated--           f :: Eq a => a -> a -> Bool-           f = trace "overloaded" (==) -- not evaluated--           xs :: [Int]-           xs = (trace "recursive" (:) 1 xs) -- evaluated-       in return ()
− tests/examples/ghc80/DsStrictWarn.hs 
@@ -1,7 +0,0 @@-{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}-{-# LANGUAGE Strict #-}-module DsStrictWarn where---- should warn about non-exhaustive pattern match-w :: String -> String-w x = let (_:_) = x in "1"
− tests/examples/ghc80/Eq.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies,-             RankNTypes, FlexibleContexts, TemplateHaskell,-             UndecidableInstances, GADTs, DefaultSignatures #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Singletons.Prelude.Eq--- Copyright   :  (C) 2013 Richard Eisenberg--- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)--- Stability   :  experimental--- Portability :  non-portable------ Defines the SEq singleton version of the Eq type class.-----------------------------------------------------------------------------------module Data.Singletons.Prelude.Eq (-  PEq(..), SEq(..),-  (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$)-  ) where--import Data.Singletons.Prelude.Bool-import Data.Singletons-import Data.Singletons.Single-import Data.Singletons.Prelude.Instances-import Data.Singletons.Util-import Data.Singletons.Promote-import Data.Type.Equality---- NB: These must be defined by hand because of the custom handling of the--- default for (:==) to use Data.Type.Equality.==---- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)',--- then it defaults to a use of '(==)', from @Data.Type.Equality@.-class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where-  type (:==) (x :: a) (y :: a) :: Bool-  type (:/=) (x :: a) (y :: a) :: Bool--  type (x :: a) :== (y :: a) = x == y-  type (x :: a) :/= (y :: a) = Not (x :== y)--infix 4 :==-infix 4 :/=--$(genDefunSymbols [''(:==), ''(:/=)])---- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required--- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'.-class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where-  -- | Boolean equality on singletons-  (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b)-  infix 4 %:==--  -- | Boolean disequality on singletons-  (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b)-  default (%:/=) :: forall (a :: k) (b :: k).-                    ((a :/= b) ~ Not (a :== b))-                 => Sing a -> Sing b -> Sing (a :/= b)-  a %:/= b = sNot (a %:== b)-  infix 4 %:/=--$(singEqInstances basicTypes)
− tests/examples/ghc80/ExpandSynsFail1.hs 
@@ -1,4 +0,0 @@-type Foo = Int-type Bar = Bool--main = print $ (1 :: Foo) == (False :: Bar)
− tests/examples/ghc80/ExpandSynsFail2.hs 
@@ -1,19 +0,0 @@--- In case of types with nested type synonyms, all synonyms should be expanded--{-# LANGUAGE RankNTypes #-}--import Control.Monad.ST--type Foo = Int-type Bar = Bool--type MyFooST s = ST s Foo-type MyBarST s = ST s Bar--fooGen :: forall s . MyFooST s-fooGen = undefined--barGen :: forall s . MyBarST s-barGen = undefined--main = print (runST fooGen == runST barGen)
− tests/examples/ghc80/ExpandSynsFail3.hs 
@@ -1,23 +0,0 @@--- We test two things here:------ 1. We expand only as much as necessary. In this case, we shouldn't expand T.--- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion---    e.g. we don't expand both of them to T1, instead we expand T5 to T3.--module Main where--type T5 = T4-type T4 = T3-type T3 = T2-type T2 = T1-type T1 = Int--type T a = Int -> Bool -> a -> String--f :: T (T3, T5, Int) -> Int-f = undefined--a :: Int-a = f (undefined :: T (T5, T3, Bool))--main = print a
− tests/examples/ghc80/ExpandSynsFail4.hs 
@@ -1,11 +0,0 @@--- Synonyms shouldn't be expanded since type error is visible without--- expansions. Error message should not have `Type synonyms expanded: ...` part.--module Main where--type T a = [a]--f :: T Int -> String-f = undefined--main = putStrLn $ f (undefined :: T Bool)
− tests/examples/ghc80/ExportSyntax.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}--module ExportSyntax ( A(.., NoA), Q(F,..), G(T,..,U)) where--data A = A | B--pattern NoA = B--data Q a = Q a--pattern F a = Q a--data G = G | H--pattern T = G--pattern U = H
− tests/examples/ghc80/ExportSyntaxImport.hs 
@@ -1,7 +0,0 @@-module ExportSyntaxImport where--import ExportSyntax--foo = NoA--baz = A
− tests/examples/ghc80/ExprSigLocal.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}--module ExprSigLocal where---- We expect this to compile fine,--- reporting that '_' stands 'a'--y :: forall b. b->b-y  = ((\x -> x) :: forall a. a -> _)--g :: forall a. a -> _-g x = x
− tests/examples/ghc80/Extends.hs 
@@ -1,4 +0,0 @@-module Extends where--class BClass b where-  has :: b
− tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs 
@@ -1,3 +0,0 @@-module ExtraConstraintsWildcardInExpressionSignature where--foo x y = ((==) :: _ => _) x y
− tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module ExtraConstraintsWildcardInPatternSignature where--foo (x :: _ => _) y = x == y
− tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ScopedTypeVariables #-}-module ExtraConstraintsWildcardInPatternSplice where--foo $( [p| (x :: _) |] ) = x
− tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module ExtraConstraintsWildcardInTypeSplice where--import Language.Haskell.TH--metaType :: TypeQ-metaType = [t| _ => _ |]
− tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module ExtraConstraintsWildcardInTypeSplice2 where--import Language.Haskell.TH.Lib (wildCardT)--show' :: $(wildCardT) => a -> String-show' x = show x
− tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module ExtraConstraintsWildcardInTypeSpliceUsed where--import ExtraConstraintsWildcardInTypeSplice---- An extra-constraints wild card is not supported in type splices-eq :: $(metaType)-eq x y = x == y
− tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-module ExtraConstraintsWildcardTwice where--foo :: ((_), _) => a -> a-foo = undefined
− tests/examples/ghc80/F.hs 
@@ -1,20 +0,0 @@--- | Thompson's group F.------ See eg. <https://en.wikipedia.org/wiki/Thompson_groups>------ Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\";--- see <http://www.math.u-psud.fr/~breuilla/Belk.pdf>-----{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-}-module Math.Combinat.Groups.Thompson.F where---- | Remove the carets with the given indices--- (throws an error if there is no caret at the given index)-removeCarets :: [Int] -> T -> T-removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where--  (_,rem,final) =  go 0 idxs tree where--  go :: Int -> [Int] -> T -> (Int,[Int],T)-  go !x []         t  = (x + treeWidth t , [] , t)
− tests/examples/ghc80/FDsFromGivens2.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, GADTs #-}--module FDsFromGivens2 where--class C a b | a -> b where-   cop :: a -> b -> ()--data KCC where-  KCC :: C Char Char => () -> KCC--f :: C Char [a] => a -> a-f = undefined--bar (KCC _) = f
− tests/examples/ghc80/Families.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures,-    TypeOperators, UndecidableInstances #-}--{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-}---- | A prelude for type-level programming with type families--module Prelude.Type.Families where---- >>> T :: T ((I 4) `Minus` (I 7))--- -3-type family (a :: k) `Minus` (b :: k) :: k-type instance a `Minus` b = a + Negate b-
− tests/examples/ghc80/FooBar.hs 
@@ -1,4 +0,0 @@-module FooBar where--import Foo-import Bar
− tests/examples/ghc80/ForFree.hs 
@@ -1,23 +0,0 @@--{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}--- {-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--module Control.ForFree where {---- | Free monad from a functor-;-  data Free f x = Pure x | Free (f (Free f x));--  deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a);-  deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a);-  deriving instance (Read (f (Free f a)), Read a) => Read (Free f a);-  deriving instance (Show (f (Free f a)), Show a) => Show (Free f a);-}
− tests/examples/ghc80/FromGrin2.hs 
@@ -1,6 +0,0 @@---- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs--- orig line 588-convertExp :: Exp -> C (Statement,Expression)-convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do-    return (mempty,e)
− tests/examples/ghc80/FrontendPlugin.hs 
@@ -1,52 +0,0 @@-module FrontendPlugin where--import GhcPlugins-import qualified GHC-import GHC              ( Ghc, LoadHowMuch(..) )--import DriverPipeline hiding ( hsc_env )-import DriverPhases-import System.Exit-import Control.Monad-import Data.List--frontendPlugin :: FrontendPlugin-frontendPlugin = defaultFrontendPlugin {-        frontend = doMake-    }---- Copypasted from ghc/Main.hs-doMake :: [String] -> [(String,Maybe Phase)] -> Ghc ()-doMake opts srcs  = do-    liftIO $ print opts-    let (hs_srcs, non_hs_srcs) = partition haskellish srcs--        haskellish (f,Nothing) =-          looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f-        haskellish (_,Just phase) =-          phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm-                          , StopLn]--    hsc_env <- GHC.getSession--    -- if we have no haskell sources from which to do a dependency-    -- analysis, then just do one-shot compilation and/or linking.-    -- This means that "ghc Foo.o Bar.o -o baz" links the program as-    -- we expect.-    if (null hs_srcs)-       then liftIO (oneShot hsc_env StopLn srcs)-       else do--    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)-                 non_hs_srcs-    dflags <- GHC.getSessionDynFlags-    let dflags' = dflags { ldInputs = map (FileOption "") o_files-                                      ++ ldInputs dflags }-    _ <- GHC.setSessionDynFlags dflags'--    targets <- mapM (uncurry GHC.guessTarget) hs_srcs-    GHC.setTargets targets-    ok_flag <- GHC.load LoadAllTargets--    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))-    return ()
− tests/examples/ghc80/GA1r.hs 
@@ -1,5 +0,0 @@-module GA1r where-import Text.ParserCombinators.Parsec--parseStr :: CharParser () String-parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"'
− tests/examples/ghc80/GADTContext.hs 
@@ -1,37 +0,0 @@-{-# 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
− tests/examples/ghc80/Generate.hs 
@@ -1,7 +0,0 @@-import Control.Monad (forM_)--main :: IO ()-main = forM_ [0..0xffff] $ \i -> do-   putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits"-   putStrLn $ ".asciz \"Section " ++ show i ++ "\""-   putStrLn ""
− tests/examples/ghc80/Generic.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}-module Env.Generic-  ( Record(..)-  , type (?)(..)-  ) where--import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$))-import Options.Generic (Generic, ParseRecord, type (<?>)(..))
− tests/examples/ghc80/IPLocation.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE ImplicitParams, RankNTypes #-}-{-# OPTIONS_GHC -dcore-lint #-}-module Main where--import GHC.Exception-import GHC.Types--f0 = putStrLn $ showCallStack ?loc-     -- should just show the location of ?loc--f1 :: (?loc :: CallStack) => IO ()-f1 = putStrLn $ showCallStack ?loc-     -- should show the location of ?loc *and* f1's call-site--f2 :: (?loc :: CallStack) => IO ()-f2 = do putStrLn $ showCallStack ?loc-        putStrLn $ showCallStack ?loc-     -- each ?loc should refer to a different location, but they should-     -- share f2's call-site--f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO ()-f3 x = x ()-       -- the call-site for the functional argument should be added to the-       -- stack..--f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO ()-f4 x = x ()-       -- as should the call-site for f4 itself--f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO ()-f5 x = x ()-       -- we only push new call-sites onto CallStacks with the name IP name--f6 :: (?loc :: CallStack) => Int -> IO ()-f6 0 = putStrLn $ showCallStack ?loc-f6 n = f6 (n-1)-       -- recursive functions add a SrcLoc for each recursive call--main = do f0-          f1-          f2-          f3 (\ () -> putStrLn $ showCallStack ?loc)-          f4 (\ () -> putStrLn $ showCallStack ?loc)-          f5 (\ () -> putStrLn $ showCallStack ?loc3)-          f6 5
− tests/examples/ghc80/Improvement.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-module Foo where--type family F a-type instance F Int = Bool--class C a b where--instance (b~Int) => C Bool b--blug :: C (F a) a => a -> F a-blug = error "Urk"--foo :: Bool-foo = blug undefined--- [W] C (F a0) a0, F a0 ~ Bool-
− tests/examples/ghc80/KindEqualities.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-}-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}--module KindEqualities where--data TyRep1 :: * -> * where-  TyInt1 :: TyRep1 Int-  TyBool1 :: TyRep1 Bool--zero1 :: forall a. TyRep1 a -> a-zero1 TyInt1 = 0-zero1 TyBool1 = False--data Proxy (a :: k) = P--data TyRep :: k -> * where-  TyInt :: TyRep Int-  TyBool :: TyRep Bool-  TyMaybe :: TyRep Maybe-  TyApp :: TyRep a -> TyRep b -> TyRep (a b)--zero :: forall (a :: *). TyRep a -> a-zero TyInt = 0-zero TyBool = False-zero (TyApp TyMaybe _) = Nothing
− tests/examples/ghc80/KindLevels.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds, PolyKinds #-}--module KindLevels where--data A-data B :: A -> *-data C :: B a -> *-data D :: C b -> *-data E :: D c -> *
− tests/examples/ghc80/ListComprehensions.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE ParallelListComp,-             TransformListComp,-             RecordWildCards #-}---             MonadComprehensions,--module ListComprehensions where----import GHC.Exts-import qualified Data.Map as M-import Data.Ord (comparing)-import Data.List (sortBy)---- Let’s look at a simple, normal list comprehension to start:--parallelListComp :: [Int]-parallelListComp = [ x + y * z-                   | x <- [0..10]-                   | y <- [10..20]-                   | z <- [20..30]-                   ]--oldest :: [Int] -> [String]-oldest tbl = [ "str"-             | n <- tbl-             , then id-             ]
− tests/examples/ghc80/LiteralsTest2.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE MagicHash #-}-module LiteralsTest2 where--x,y :: Int-x = 0003-y = 0x04--s :: String-s = "\x20"--c :: Char-c = '\x20'--d :: Double-d = 0.00--blah = x-  where-    charH = '\x41'#-    intH = 0004#-    wordH = 005##-    floatH = 3.20#-    doubleH = 04.16##-    x = 1
− tests/examples/ghc80/Main.hs 
@@ -1,14 +0,0 @@--- Copyright (C) 2015, Luke Iannini--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ForeignFunctionInterface #-}--module Main where-import Printf ( pr )--foreign import ccall "talkToCxx" talkToCxx :: IO ()--main :: IO ()-main = do-  putStrLn ( $(pr "Hello From Template Haskell!") )-  talkToCxx
− tests/examples/ghc80/Manipulate.hs 
@@ -1,39 +0,0 @@-{- |-Module      :  Control.Comonad.Sheet.Manipulate-Description :  Generic functions for manipulating multi-dimensional comonadic spreadsheets.-Copyright   :  Copyright (c) 2014 Kenneth Foner--Maintainer  :  kenneth.foner@gmail.com-Stability   :  experimental-Portability :  non-portable--This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These-constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite-slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert').--}--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}--module Control.Comonad.Sheet.Manipulate where----- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@.-instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where-   type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a)-   asDimensionalAs = asNestedAs---- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures.-instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where-   type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a)-   x `asDimensionalAs` (Indexed i t)       = x `asNestedAs` t---instance DepIndex (a,b) TH_0 where-    type (a,b) `DepIndexResult` TH_0 = a-    (a,b) # TH_0 = a
− tests/examples/ghc80/Match.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TypeOperators       #-}-{-# OPTIONS_HADDOCK hide #-}---- Discriminate binary functions that commute, and if so return the operands in--- a stable ordering such that matching recognises expressions modulo--- commutativity.----commutes-    :: forall acc env aenv a r.-       HashAcc acc-    -> PrimFun (a -> r)-    -> PreOpenExp acc env aenv a-    -> Maybe (PreOpenExp acc env aenv a)-commutes h f x = case f of-  PrimAdd _     -> Just (swizzle x)-  PrimMul _     -> Just (swizzle x)-  PrimBAnd _    -> Just (swizzle x)-  PrimBOr _     -> Just (swizzle x)-  PrimBXor _    -> Just (swizzle x)-  PrimEq _      -> Just (swizzle x)-  PrimNEq _     -> Just (swizzle x)-  PrimMax _     -> Just (swizzle x)-  PrimMin _     -> Just (swizzle x)-  PrimLAnd      -> Just (swizzle x)-  PrimLOr       -> Just (swizzle x)-  _             -> Nothing-  where-    swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a')-    swizzle exp-      | Tuple (NilTup `SnocTup` a `SnocTup` b)  <- exp-      , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a)-      ---      | otherwise                               = exp
− tests/examples/ghc80/MonadFailErrors.hs 
@@ -1,95 +0,0 @@--- Test purpose:--- Break properly if MonadFail is live--{-# LANGUAGE MonadFailDesugaring #-}--module MonadFailWarnings where--import Control.Monad.Fail-import Control.Monad.ST-import Data.Functor.Identity----general :: Monad m => m a-general = do-    Just x <- undefined-    undefined----general' :: MonadFail m => m a-general' = do-    Just x <- undefined-    undefined----identity :: Identity a-identity = do-    Just x <- undefined-    undefined----io :: IO a-io = do-    Just x <- undefined-    undefined----st :: ST s a-st = do-    Just x <- undefined-    undefined----reader :: r -> a-reader = do-    Just x <- undefined-    undefined----newtype Newtype a = Newtype a-newtypeMatch :: Identity a-newtypeMatch = do-    Newtype x <- undefined-    undefined----data Data a = Data a-singleConMatch :: Identity a-singleConMatch = do-    Data x <- undefined-    undefined----data Maybe' a = Nothing' | Just' a-instance Functor Maybe' where fmap = undefined-instance Applicative Maybe' where pure = undefined; (<*>) = undefined-instance Monad Maybe' where (>>=) = undefined-instance MonadFail Maybe' where fail = undefined-customFailable :: Maybe' a-customFailable = do-    Just x <- undefined-    undefined---wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a-wildcardx = do-    x <- undefined-    undefined-explicitlyIrrefutable = do-    ~(x:y) <- undefined-    undefined-wildcard_ = do-    _ <- undefined-    undefined-tuple = do-    (a,b) <- undefined-    undefined
− tests/examples/ghc80/MonadFailWarnings.hs 
@@ -1,107 +0,0 @@--- Test purpose:--- Ensure that MonadFail warnings are issued correctly if the warning flag--- is enabled--{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-}--module MonadFailWarnings where--import Control.Monad.Fail-import Control.Monad.ST-import Data.Functor.Identity------ should warn, because the do-block gets a general Monad constraint,--- but should have MonadFail-general :: Monad m => m a-general = do-    Just x <- undefined-    undefined------ should NOT warn, because the constraint is correct-general' :: MonadFail m => m a-general' = do-    Just x <- undefined-    undefined------ should warn, because Identity isn't MonadFail-identity :: Identity a-identity = do-    Just x <- undefined-    undefined------ should NOT warn, because IO is MonadFail-io :: IO a-io = do-    Just x <- undefined-    undefined------ should warn, because (ST s) is not MonadFail-st :: ST s a-st = do-    Just x <- undefined-    undefined------ should warn, because (r ->) is not MonadFail-reader :: r -> a-reader = do-    Just x <- undefined-    undefined------ should NOT warn, because matching against newtype-newtype Newtype a = Newtype a-newtypeMatch :: Identity a-newtypeMatch = do-    Newtype x <- undefined-    undefined------ should NOT warn, because Data has only one constructor-data Data a = Data a-singleConMatch :: Identity a-singleConMatch = do-    Data x <- undefined-    undefined------ should NOT warn, because Maybe' has a MonadFail instance-data Maybe' a = Nothing' | Just' a-instance Functor Maybe' where fmap = undefined-instance Applicative Maybe' where pure = undefined; (<*>) = undefined-instance Monad Maybe' where (>>=) = undefined-instance MonadFail Maybe' where fail = undefined-customFailable :: Maybe' a-customFailable = do-    Just x <- undefined-    undefined----- should NOT warn, because patterns always match-wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a-wildcardx = do-    x <- undefined-    undefined-explicitlyIrrefutable = do-    ~(x:y) <- undefined-    undefined-wildcard_ = do-    _ <- undefined-    undefined-tuple = do-    (a,b) <- undefined-    undefined
− tests/examples/ghc80/MonadFailWarningsDisabled.hs 
@@ -1,94 +0,0 @@--- Test purpose:--- Make sure that not enabling MonadFail warnings makes code compile just--- as it did in < 8.0--module MonadFailWarnings where--import Control.Monad.Fail-import Control.Monad.ST-import Data.Functor.Identity----general :: Monad m => m a-general = do-    Just x <- undefined-    undefined----general' :: MonadFail m => m a-general' = do-    Just x <- undefined-    undefined----identity :: Identity a-identity = do-    Just x <- undefined-    undefined----io :: IO a-io = do-    Just x <- undefined-    undefined----st :: ST s a-st = do-    Just x <- undefined-    undefined----reader :: r -> a-reader = do-    Just x <- undefined-    undefined----newtype Newtype a = Newtype a-newtypeMatch :: Identity a-newtypeMatch = do-    Newtype x <- undefined-    undefined----data Data a = Data a-singleConMatch :: Identity a-singleConMatch = do-    Data x <- undefined-    undefined----data Maybe' a = Nothing' | Just' a-instance Functor Maybe' where fmap = undefined-instance Applicative Maybe' where pure = undefined; (<*>) = undefined-instance Monad Maybe' where (>>=) = undefined-instance MonadFail Maybe' where fail = undefined-customFailable :: Maybe' a-customFailable = do-    Just x <- undefined-    undefined---wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a-wildcardx = do-    x <- undefined-    undefined-explicitlyIrrefutable = do-    ~(x:y) <- undefined-    undefined-wildcard_ = do-    _ <- undefined-    undefined-tuple = do-    (a,b) <- undefined-    undefined
− tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs 
@@ -1,14 +0,0 @@--- Test purpose:--- RebindableSyntax does not play that well with MonadFail, so here we ensure--- that when both settings are enabled we get the proper warning.--{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-}-{-# LANGUAGE RebindableSyntax #-}--module MonadFailWarningsWithRebindableSyntax where--import Prelude--test1 f g = do-    Just x <- f-    g
− tests/examples/ghc80/MonadT.hs 
@@ -1,48 +0,0 @@-{-# OPTIONS -XRank2Types #-}--module Control.Monatron.MonadT (-  MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap,-  module Control.Monad-) where--import Control.Monad---------------------------------------------------------------- Class of monad transformers with--- a lifting of first-order operations-------------------------------------------------------------class MonadT t where-    lift    :: Monad m  => m a -> t m a-    treturn :: Monad m => a -> t m a-    treturn =  lift. return-    tbind   :: Monad m => t m a -> (a -> t m b) -> t m b--newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b}--functor :: Functor f => FunctorD f-functor = FunctorD fmap--class MonadT t => FMonadT t where-    tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b--tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a-tmap = tmap' functor functor id--mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b-mtmap fd f = tmap' fd fd f id--class FMonadT t => MMonadT t where-    flift      :: Functor f => f a -> t f a --should coincide with lift!-    monoidalT  :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a--------------------------------------------- Functor Composition-------------------------------------------newtype (FComp f g) a = Comp {deComp :: (f (g a)) }--instance (Functor f, Functor g) => Functor (FComp f g) where-    fmap f (Comp fga) = Comp (fmap (fmap f) fga)-
− tests/examples/ghc80/MultiLineWarningPragma.hs 
@@ -1,18 +0,0 @@--{-# WARNING Logic-          , mkSolver-          , mkSimpleSolver-          , mkSolverForLogic-          , solverSetParams-          , solverPush-          , solverPop-          , solverReset-          , solverGetNumScopes-          , solverAssertCnstr-          , solverAssertAndTrack-          , solverCheck-          , solverCheckAndGetModel-          , solverGetReasonUnknown-          "New Z3 API support is still incomplete and fragile: \-          \you may experience segmentation faults!"-  #-}
− tests/examples/ghc80/MultiQuote.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes#-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE EmptyCase #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | Internal API for the store package. The functions here which are--- not re-exported by "Data.Store" are less likely to have stable APIs.------ This module also defines most of the included 'Store' instances, for--- types from the base package and other commonly used packages--- (bytestring, containers, text, time, etc).-module Data.Store.Internal where----------------------------------------------------------------------------- Instances generated by TH--$($(derive [d|-    -- TODO-    -- instance Deriving (Store ())-    instance Deriving (Store All)-    instance Deriving (Store Any)-    instance Deriving (Store Void)-    instance Deriving (Store Bool)-    |]))-
− tests/examples/ghc80/MultiWayIf.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module MultiWayIf where--foo = if | test1 -> e1-         | test2 witharg -> e2-         | otherwise -> def--bar = if { | test1 -> if { | test2 -> e1-                           | test3 -> e2 }-           | test4 -> e3-         }---- taken from GHC's test suite-x  = 10-x1 = if | x < 10 -> "< 10" | otherwise -> ""-x2 = if | x < 10 -> "< 10"-        | otherwise -> ""-x3 = if | x < 10 -> "< 10"-        | otherwise -> ""-x4 = if | True -> "yes"-x5 = if | True -> if | False -> 1 | True -> 2--x6 = if | x < 10 -> if | True -> "yes"-                       | False -> "no"-        | otherwise -> "maybe"--x7 = (if | True -> 0)---- issue #98-spam = if | () <- () -> ()
− tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-}-module NamedWildcardInDataFamilyInstanceLHS where--data MyKind = A | B--data family Sing (a :: k)--data instance Sing (_a :: MyKind) where-    SingA :: Sing A-    SingB :: Sing B
− tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE NamedWildCards #-}-module NamedWildcardInTypeFamilyInstanceLHS where--type family F a where-  F _t = Int
− tests/examples/ghc80/NamedWildcardInTypeSplice.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NamedWildCards #-}-module NamedWildcardInTypeSplice where--import Language.Haskell.TH--metaType :: TypeQ-metaType = [t| _a -> _a |]
− tests/examples/ghc80/OutOfHeap.hs 
@@ -1,10 +0,0 @@-import qualified Data.Array.Unboxed as UA-import Data.Word--main :: IO ()-main = print (UA.listArray (1, 2^(20::Int)) (repeat 0)-              :: UA.UArray Int Word64)-       -- this unboxed array should at least take:-       --   2^20 * 64 bits-       -- = 8 * (2^20 bytes)-       -- = 8 MiB (in heap)
− tests/examples/ghc80/OverloadedRecFldsFail04_A.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}--module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where--data U = MkU { x :: Bool, y :: Bool }-data V = MkV { x :: Int }-data Unused = MkUnused { unused :: Bool }--u = MkU False True
− tests/examples/ghc80/OverloadedRecFldsFail06_A.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# OPTIONS_GHC -fwarn-unused-binds #-}--module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where--data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool }-  deriving Show-data V = MkV { x :: Int } | MkV2 { y :: Bool }-data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool }--u = MkU False True--z MkU2{used_locally=used_locally} = used_locally--getX MkU{x=x} = x-getY MkV2{y=y} = y
− tests/examples/ghc80/OverloadedRecFldsFail10_A.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module OverloadedRecFldsFail10_A where--data family F a-data instance F Int = MkFInt { foo :: Int }
− tests/examples/ghc80/OverloadedRecFldsFail10_B.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module OverloadedRecFldsFail10_B (F(..)) where--import OverloadedRecFldsFail10_A hiding (foo)--data instance F Bool = MkFBool { foo :: Int }
− tests/examples/ghc80/OverloadedRecFldsFail10_C.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}-module OverloadedRecFldsFail10_C (F(..)) where--import OverloadedRecFldsFail10_A--data instance F Char = MkFChar { foo :: Char }
− tests/examples/ghc80/OverloadedRecFldsFail11_A.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-module OverloadedRecFldsFail11_A where--{-# WARNING foo "Warning on a record field" #-}-data S = MkS { foo :: Bool }-data T = MkT { foo :: Int }
− tests/examples/ghc80/OverloadedRecFldsFail12_A.hs 
@@ -1,5 +0,0 @@-module OverloadedRecFldsFail12_A where--{-# WARNING foo "Deprecated foo" #-}-{-# WARNING bar "Deprecated bar" #-}-data T = MkT { foo :: Int, bar :: Int }
− tests/examples/ghc80/OverloadedRecFldsRun02_A.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}--module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where--data U = MkU { x :: Bool, y :: Bool }-data V = MkV { x :: Int }-data Unused = MkUnused { unused :: Bool }--u = MkU False True
− tests/examples/ghc80/P.hs 
@@ -1,12 +0,0 @@-module P where--import qualified Map-import qualified Set--foo = do-    let x = Map.insert 0 "foo"-          . Map.insert (6 :: Int) "foo"-          $ Map.empty-    print (Map.lookup 1 x)-    print (Set.size (Map.keysSet x))-    return x
− tests/examples/ghc80/PSQ.hs 
@@ -1,4 +0,0 @@--data TourView a = Null-                | Single {-# UNPACK #-} !(Elem a)-                | (PSQ a) `Play` (PSQ a)
− tests/examples/ghc80/ParenFunBind.hs 
@@ -1,5 +0,0 @@-module ParenFunBind where--(foo x)   y  = x + y-((bar x)) y  = x + y-((baz x)) (y) = x + y
− tests/examples/ghc80/ParenTypeSynonym.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-module ParenTypeSynonym where--type Is = (~)
− tests/examples/ghc80/PartialClassMethodSignature2.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-module PartialClassMethodSignature2 where--class Foo a where-  foo :: (Eq a, _) => a -> a
− tests/examples/ghc80/PluralS.hs 
@@ -1,27 +0,0 @@--- Test purpose:------ Ensure the plural "s" in warnings is only shown if there are more than--- one entries--{-# OPTIONS_GHC -Wredundant-constraints #-}-{-# OPTIONS_GHC -Wtype-defaults #-}--module PluralS () where------ Defaulting type classes--defaultingNum = 123 `seq` ()--defaultingNumAndShow = show 123------ Redundant constraints--redundantNum :: (Num a, Num a) => a-redundantNum = 123--redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a-redundantMultiple = 123
− tests/examples/ghc80/PolyInstances.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables,-             UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}--module PolyInstances where--import GHC.Exts-import Data.Proxy--class C (a :: k)--instance (C a, C b) => C (a b)--data Dict :: Constraint -> *--instance C Dict--foo :: C p => proxy p -> ()-foo = undefined--bar :: forall (p :: Constraint) proxy. C p => proxy p -> ()-bar _ = foo (Proxy :: Proxy (Dict p))
− tests/examples/ghc80/PopCnt.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-}-module Main where--import GHC.Exts--foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int#--main = print (I# (popcnt32 0xffff#))-
− tests/examples/ghc80/Ppr017.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ExplicitNamespaces #-}-module Imports( f, type (+), pattern Single ) where--import GHC.TypeLits--pattern Single x = [x]--f = undefined
− tests/examples/ghc80/Primop.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE GHCForeignImportPrim, MagicHash,-             UnliftedFFITypes, UnboxedTuples #-}--import GHC.Exts--foreign import prim "dummy"-   dummy :: Word# -> Word#--foreign import prim "dummy2"-   dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #)
− tests/examples/ghc80/Printf.hs 
@@ -1,34 +0,0 @@--- Copyright (C) 2015, Luke Iannini--{-# LANGUAGE TemplateHaskell #-}-module Printf where---- Skeletal printf from the paper:--- http://research.microsoft.com/pubs/67015/meta-haskell.pdf--- It needs to be in a separate module to the one where--- you intend to use it.---- Import some Template Haskell syntax-import Language.Haskell.TH---- Describe a format string-data Format = D | S | L String---- Parse a format string.  This is left largely to you--- as we are here interested in building our first ever--- Template Haskell program and not in building printf.-parse :: String -> [Format]-parse s   = [ L s ]---- Generate Haskell source code from a parsed representation--- of the format string.  This code will be spliced into--- the module which calls "pr", at compile time.-gen :: [Format] -> Q Exp-gen [D]   = [| \n -> show n |]-gen [S]   = [| \s -> s |]-gen [L s] = stringE s---- Here we generate the Haskell code for the splice--- from an input format string.-pr :: String -> Q Exp-pr s = gen (parse s)
− tests/examples/ghc80/PromotedClass.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE TypeInType, GADTs #-}--module PromotedClass where--import Data.Proxy--data X a where-  MkX :: Show a => a -> X a--foo :: Proxy ('MkX 'True)-foo = Proxy
− tests/examples/ghc80/Q.hs 
@@ -1,7 +0,0 @@-module Q where--import qualified Map-import Map(Map)--mymember :: Int -> Map Int a -> Bool-mymember k m = Map.member k m || Map.member (k + 1) m
− tests/examples/ghc80/QQ.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module QQ where--import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.TH--pq = QuasiQuoter { quoteDec = \_ -> return [sig],-                   quoteType = \_ -> undefined,-                   quoteExp = \_ -> undefined,-                   quotePat = \_ -> undefined }--sig = SigD (mkName "f") (ArrowT `AppT` int `AppT` int)-int = ConT (mkName "Int")
− tests/examples/ghc80/Query.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE CPP #-}--module AWS.Lib.Query where--requestQuery = do-    if st < 400-#ifdef DEBUG-        do  e-#else-        then return body-        else fail "not reached"-#endif-
− tests/examples/ghc80/RandomPGC.hs 
@@ -1,597 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  System.Random--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file LICENSE in the 'random' repository)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ This library deals with the common task of pseudo-random number--- generation. The library makes it possible to generate repeatable--- results, by starting with a specified initial random number generator,--- or to get different results on each run by using the system-initialised--- generator or by supplying a seed from some other source.------ The library is split into two layers:------ * A core /random number generator/ provides a supply of bits.---   The class 'RandomGen' provides a common interface to such generators.---   The library provides one instance of 'RandomGen', the abstract---   data type 'StdGen'.  Programmers may, of course, supply their own---   instances of 'RandomGen'.------ * The class 'Random' provides a way to extract values of a particular---   type from a random number generator.  For example, the 'Float'---   instance of 'Random' allows one to generate random values of type---   'Float'.------ This implementation uses the Portable Combined Generator of L'Ecuyer--- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by--- Lennart Augustsson.  It has a period of roughly 2.30584e18.-----------------------------------------------------------------------------------#include "MachDeps.h"--module RandomPGC-        (--        -- $intro--        -- * Random number generators--#ifdef ENABLE_SPLITTABLEGEN-          RandomGen(next, genRange)-        , SplittableGen(split)-#else-          RandomGen(next, genRange, split)-#endif-        -- ** Standard random number generators-        , StdGen-        , mkStdGen--        -- ** The global random number generator--        -- $globalrng--        , getStdRandom-        , getStdGen-        , setStdGen-        , newStdGen--        -- * Random values of various types-        , Random ( random,   randomR,-                   randoms,  randomRs,-                   randomIO, randomRIO )--        -- * References-        -- $references--        ) where--import Prelude--import Data.Bits-import Data.Int-import Data.Word-import Foreign.C.Types--#ifdef __NHC__-import CPUTime          ( getCPUTime )-import Foreign.Ptr      ( Ptr, nullPtr )-import Foreign.C        ( CTime, CUInt )-#else-import System.CPUTime   ( getCPUTime )-import Data.Time        ( getCurrentTime, UTCTime(..) )-import Data.Ratio       ( numerator, denominator )-#endif-import Data.Char        ( isSpace, chr, ord )-import System.IO.Unsafe ( unsafePerformIO )-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )-import Data.IORef       ( atomicModifyIORef' )-import Numeric          ( readDec )--#ifdef __GLASGOW_HASKELL__-import GHC.Exts         ( build )-#else--- | A dummy variant of build without fusion.-{-# INLINE build #-}-build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]-build g = g (:) []-#endif---- The standard nhc98 implementation of Time.ClockTime does not match--- the extended one expected in this module, so we lash-up a quick--- replacement here.-#ifdef __NHC__-foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime-getTime :: IO (Integer, Integer)-getTime = do CTime t <- readtime nullPtr;  return (toInteger t, 0)-#else-getTime :: IO (Integer, Integer)-getTime = do-  utc <- getCurrentTime-  let daytime = toRational $ utctDayTime utc-  return $ quotRem (numerator daytime) (denominator daytime)-#endif---- | The class 'RandomGen' provides a common interface to random number--- generators.----#ifdef ENABLE_SPLITTABLEGEN--- Minimal complete definition: 'next'.-#else--- Minimal complete definition: 'next' and 'split'.-#endif--class RandomGen g where--   -- |The 'next' operation returns an 'Int' that is uniformly distributed-   -- in the range returned by 'genRange' (including both end points),-   -- and a new generator.-   next     :: g -> (Int, g)--   -- |The 'genRange' operation yields the range of values returned by-   -- the generator.-   ---   -- It is required that:-   ---   -- * If @(a,b) = 'genRange' g@, then @a < b@.-   ---   -- * 'genRange' always returns a pair of defined 'Int's.-   ---   -- The second condition ensures that 'genRange' cannot examine its-   -- argument, and hence the value it returns can be determined only by the-   -- instance of 'RandomGen'.  That in turn allows an implementation to make-   -- a single call to 'genRange' to establish a generator's range, without-   -- being concerned that the generator returned by (say) 'next' might have-   -- a different range to the generator passed to 'next'.-   ---   -- The default definition spans the full range of 'Int'.-   genRange :: g -> (Int,Int)--   -- default method-   genRange _ = (minBound, maxBound)--#ifdef ENABLE_SPLITTABLEGEN--- | The class 'SplittableGen' proivides a way to specify a random number---   generator that can be split into two new generators.-class SplittableGen g where-#endif-   -- |The 'split' operation allows one to obtain two distinct random number-   -- generators. This is very useful in functional programs (for example, when-   -- passing a random number generator down to recursive calls), but very-   -- little work has been done on statistically robust implementations of-   -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"]-   -- are the only examples we know of).-   split    :: g -> (g, g)--{- |-The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits.--The result of repeatedly using 'next' should be at least as statistically-robust as the /Minimal Standard Random Number Generator/ described by-["System.Random\#Park", "System.Random\#Carta"].-Until more is known about implementations of 'split', all we require is-that 'split' deliver generators that are (a) not identical and-(b) independently robust in the sense just given.--The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the-state of a random number generator.-It is required that @'read' ('show' g) == g@.--In addition, 'reads' may be used to map an arbitrary string (not necessarily one-produced by 'show') onto a value of type 'StdGen'. In general, the 'Read'-instance of 'StdGen' has the following properties:--* It guarantees to succeed on any string.--* It guarantees to consume only a finite portion of the string.--* Different argument strings are likely to result in different results.---}--data StdGen- = StdGen !Int32 !Int32--instance RandomGen StdGen where-  next  = stdNext-  genRange _ = stdRange--#ifdef ENABLE_SPLITTABLEGEN-instance SplittableGen StdGen where-#endif-  split = stdSplit--instance Show StdGen where-  showsPrec p (StdGen s1 s2) =-     showsPrec p s1 .-     showChar ' ' .-     showsPrec p s2--instance Read StdGen where-  readsPrec _p = \ r ->-     case try_read r of-       r'@[_] -> r'-       _   -> [stdFromString r] -- because it shouldn't ever fail.-    where-      try_read r = do-         (s1, r1) <- readDec (dropWhile isSpace r)-         (s2, r2) <- readDec (dropWhile isSpace r1)-         return (StdGen s1 s2, r2)--{-- If we cannot unravel the StdGen from a string, create- one based on the string given.--}-stdFromString         :: String -> (StdGen, String)-stdFromString s        = (mkStdGen num, rest)-        where (cs, rest) = splitAt 6 s-              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)---{- |-The function 'mkStdGen' provides an alternative way of producing an initial-generator, by mapping an 'Int' into a generator. Again, distinct arguments-should be likely to produce distinct generators.--}-mkStdGen :: Int -> StdGen -- why not Integer ?-mkStdGen s = mkStdGen32 $ fromIntegral s--{--From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be-initialized to values in the range [1, 2147483562] and [1, 2147483398]-respectively."--}-mkStdGen32 :: Int32 -> StdGen-mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1)-      where-        -- We want a non-negative number, but we can't just take the abs-        -- of sMaybeNegative as -minBound == minBound.-        s       = sMaybeNegative .&. maxBound-        (q, s1) = s `divMod` 2147483562-        s2      = q `mod` 2147483398--createStdGen :: Integer -> StdGen-createStdGen s = mkStdGen32 $ fromIntegral s--{- |-With a source of random number supply in hand, the 'Random' class allows the-programmer to extract random values of a variety of types.--Minimal complete definition: 'randomR' and 'random'.---}--class Random a where-  -- | Takes a range /(lo,hi)/ and a random number generator-  -- /g/, and returns a random value uniformly distributed in the closed-  -- interval /[lo,hi]/, together with a new generator. It is unspecified-  -- what happens if /lo>hi/. For continuous types there is no requirement-  -- that the values /lo/ and /hi/ are ever produced, but they may be,-  -- depending on the implementation and the interval.-  randomR :: RandomGen g => (a,a) -> g -> (a,g)--  -- | The same as 'randomR', but using a default range determined by the type:-  ---  -- * For bounded types (instances of 'Bounded', such as 'Char'),-  --   the range is normally the whole type.-  ---  -- * For fractional types, the range is normally the semi-closed interval-  -- @[0,1)@.-  ---  -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.-  random  :: RandomGen g => g -> (a, g)--  -- | Plural variant of 'randomR', producing an infinite list of-  -- random values instead of returning a new generator.-  {-# INLINE randomRs #-}-  randomRs :: RandomGen g => (a,a) -> g -> [a]-  randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g)--  -- | Plural variant of 'random', producing an infinite list of-  -- random values instead of returning a new generator.-  {-# INLINE randoms #-}-  randoms  :: RandomGen g => g -> [a]-  randoms  g      = build (\cons _nil -> buildRandoms cons random g)--  -- | A variant of 'randomR' that uses the global random number generator-  -- (see "System.Random#globalrng").-  randomRIO :: (a,a) -> IO a-  randomRIO range  = getStdRandom (randomR range)--  -- | A variant of 'random' that uses the global random number generator-  -- (see "System.Random#globalrng").-  randomIO  :: IO a-  randomIO         = getStdRandom random---- | Produce an infinite list-equivalent of random values.-{-# INLINE buildRandoms #-}-buildRandoms :: RandomGen g-             => (a -> as -> as)  -- ^ E.g. '(:)' but subject to fusion-             -> (g -> (a,g))     -- ^ E.g. 'random'-             -> g                -- ^ A 'RandomGen' instance-             -> as-buildRandoms cons rand = go-  where-    -- The seq fixes part of #4218 and also makes fused Core simpler.-    go g = x `seq` (x `cons` go g') where (x,g') = rand g---instance Random Integer where-  randomR ival g = randomIvalInteger ival g-  random g       = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g--instance Random Int        where randomR = randomIvalIntegral; random = randomBounded-instance Random Int8       where randomR = randomIvalIntegral; random = randomBounded-instance Random Int16      where randomR = randomIvalIntegral; random = randomBounded-instance Random Int32      where randomR = randomIvalIntegral; random = randomBounded-instance Random Int64      where randomR = randomIvalIntegral; random = randomBounded--#ifndef __NHC__--- Word is a type synonym in nhc98.-instance Random Word       where randomR = randomIvalIntegral; random = randomBounded-#endif-instance Random Word8      where randomR = randomIvalIntegral; random = randomBounded-instance Random Word16     where randomR = randomIvalIntegral; random = randomBounded-instance Random Word32     where randomR = randomIvalIntegral; random = randomBounded-instance Random Word64     where randomR = randomIvalIntegral; random = randomBounded--instance Random CChar      where randomR = randomIvalIntegral; random = randomBounded-instance Random CSChar     where randomR = randomIvalIntegral; random = randomBounded-instance Random CUChar     where randomR = randomIvalIntegral; random = randomBounded-instance Random CShort     where randomR = randomIvalIntegral; random = randomBounded-instance Random CUShort    where randomR = randomIvalIntegral; random = randomBounded-instance Random CInt       where randomR = randomIvalIntegral; random = randomBounded-instance Random CUInt      where randomR = randomIvalIntegral; random = randomBounded-instance Random CLong      where randomR = randomIvalIntegral; random = randomBounded-instance Random CULong     where randomR = randomIvalIntegral; random = randomBounded-instance Random CPtrdiff   where randomR = randomIvalIntegral; random = randomBounded-instance Random CSize      where randomR = randomIvalIntegral; random = randomBounded-instance Random CWchar     where randomR = randomIvalIntegral; random = randomBounded-instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded-instance Random CLLong     where randomR = randomIvalIntegral; random = randomBounded-instance Random CULLong    where randomR = randomIvalIntegral; random = randomBounded-instance Random CIntPtr    where randomR = randomIvalIntegral; random = randomBounded-instance Random CUIntPtr   where randomR = randomIvalIntegral; random = randomBounded-instance Random CIntMax    where randomR = randomIvalIntegral; random = randomBounded-instance Random CUIntMax   where randomR = randomIvalIntegral; random = randomBounded--instance Random Char where-  randomR (a,b) g =-       case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of-         (x,g') -> (chr x, g')-  random g        = randomR (minBound,maxBound) g--instance Random Bool where-  randomR (a,b) g =-      case (randomIvalInteger (bool2Int a, bool2Int b) g) of-        (x, g') -> (int2Bool x, g')-       where-         bool2Int :: Bool -> Integer-         bool2Int False = 0-         bool2Int True  = 1--         int2Bool :: Int -> Bool-         int2Bool 0     = False-         int2Bool _     = True--  random g        = randomR (minBound,maxBound) g--{-# INLINE randomRFloating #-}-randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g)-randomRFloating (l,h) g-    | l>h       = randomRFloating (h,l) g-    | otherwise = let (coef,g') = random g in-                  (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g')  -- avoid overflow--instance Random Double where-  randomR = randomRFloating-  random rng     =-    case random rng of-      (x,rng') ->-          -- We use 53 bits of randomness corresponding to the 53 bit significand:-          ((fromIntegral (mask53 .&. (x::Int64)) :: Double)-           /  fromIntegral twoto53, rng')-   where-    twoto53 = (2::Int64) ^ (53::Int64)-    mask53 = twoto53 - 1--instance Random Float where-  randomR = randomRFloating-  random rng =-    -- TODO: Faster to just use 'next' IF it generates enough bits of randomness.-    case random rng of-      (x,rng') ->-          -- We use 24 bits of randomness corresponding to the 24 bit significand:-          ((fromIntegral (mask24 .&. (x::Int32)) :: Float)-           /  fromIntegral twoto24, rng')-         -- Note, encodeFloat is another option, but I'm not seeing slightly-         --  worse performance with the following [2011.06.25]:---         (encodeFloat rand (-24), rng')-   where-     mask24 = twoto24 - 1-     twoto24 = (2::Int32) ^ (24::Int32)---- CFloat/CDouble are basically the same as a Float/Double:-instance Random CFloat where-  randomR = randomRFloating-  random rng = case random rng of-                 (x,rng') -> (realToFrac (x::Float), rng')--instance Random CDouble where-  randomR = randomRFloating-  -- A MYSTERY:-  -- Presently, this is showing better performance than the Double instance:-  -- (And yet, if the Double instance uses randomFrac then its performance is much worse!)-  random  = randomFrac-  -- random rng = case random rng of-  --             (x,rng') -> (realToFrac (x::Double), rng')--mkStdRNG :: Integer -> IO StdGen-mkStdRNG o = do-    ct          <- getCPUTime-    (sec, psec) <- getTime-    return (createStdGen (sec * 12345 + psec + ct + o))--randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g)-randomBounded = randomR (minBound, maxBound)---- The two integer functions below take an [inclusive,inclusive] range.-randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)-randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h)--{-# SPECIALIZE randomIvalInteger :: (Num a) =>-    (Integer, Integer) -> StdGen -> (a, StdGen) #-}--randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)-randomIvalInteger (l,h) rng- | l > h     = randomIvalInteger (h,l) rng- | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')-     where-       (genlo, genhi) = genRange rng-       b = fromIntegral genhi - fromIntegral genlo + 1--       -- Probabilities of the most likely and least likely result-       -- will differ at most by a factor of (1 +- 1/q).  Assuming the RandomGen-       -- is uniform, of course--       -- On average, log q / log b more random values will be generated-       -- than the minimum-       q = 1000-       k = h - l + 1-       magtgt = k * q--       -- generate random values until we exceed the target magnitude-       f mag v g | mag >= magtgt = (v, g)-                 | otherwise = v' `seq`f (mag*b) v' g' where-                        (x,g') = next g-                        v' = (v * b + (fromIntegral x - fromIntegral genlo))----- The continuous functions on the other hand take an [inclusive,exclusive) range.-randomFrac :: (RandomGen g, Fractional a) => g -> (a, g)-randomFrac = randomIvalDouble (0::Double,1) realToFrac--randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)-randomIvalDouble (l,h) fromDouble rng-  | l > h     = randomIvalDouble (h,l) fromDouble rng-  | otherwise =-       case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of-         (x, rng') ->-            let-             scaled_x =-                fromDouble (0.5*l + 0.5*h) +                   -- previously (l+h)/2, overflowed-                fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) *  -- avoid overflow-                fromIntegral (x::Int32)-            in-            (scaled_x, rng')--int32Count :: Integer-int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1  -- GHC ticket #3982--stdRange :: (Int,Int)-stdRange = (1, 2147483562)--stdNext :: StdGen -> (Int, StdGen)--- Returns values in the range stdRange-stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'')-        where   z'   = if z < 1 then z + 2147483562 else z-                z    = s1'' - s2''--                k    = s1 `quot` 53668-                s1'  = 40014 * (s1 - k * 53668) - k * 12211-                s1'' = if s1' < 0 then s1' + 2147483563 else s1'--                k'   = s2 `quot` 52774-                s2'  = 40692 * (s2 - k' * 52774) - k' * 3791-                s2'' = if s2' < 0 then s2' + 2147483399 else s2'--stdSplit            :: StdGen -> (StdGen, StdGen)-stdSplit std@(StdGen s1 s2)-                     = (left, right)-                       where-                        -- no statistical foundation for this!-                        left    = StdGen new_s1 t2-                        right   = StdGen t1 new_s2--                        new_s1 | s1 == 2147483562 = 1-                               | otherwise        = s1 + 1--                        new_s2 | s2 == 1          = 2147483398-                               | otherwise        = s2 - 1--                        StdGen t1 t2 = snd (next std)---- The global random number generator--{- $globalrng #globalrng#--There is a single, implicit, global random number generator of type-'StdGen', held in some global variable maintained by the 'IO' monad. It is-initialised automatically in some system-dependent fashion, for example, by-using the time of day, or Linux's kernel random number generator. To get-deterministic behaviour, use 'setStdGen'.--}---- |Sets the global random number generator.-setStdGen :: StdGen -> IO ()-setStdGen sgen = writeIORef theStdGen sgen---- |Gets the global random number generator.-getStdGen :: IO StdGen-getStdGen  = readIORef theStdGen--theStdGen :: IORef StdGen-theStdGen  = unsafePerformIO $ do-   rng <- mkStdRNG 0-   newIORef rng---- |Applies 'split' to the current global random generator,--- updates it with one of the results, and returns the other.-newStdGen :: IO StdGen-newStdGen = atomicModifyIORef' theStdGen split--{- |Uses the supplied function to get a value from the current global-random generator, and updates the global generator with the new generator-returned by the function. For example, @rollDice@ gets a random integer-between 1 and 6:-->  rollDice :: IO Int->  rollDice = getStdRandom (randomR (1,6))---}--getStdRandom :: (StdGen -> (a,StdGen)) -> IO a-getStdRandom f = atomicModifyIORef' theStdGen (swap . f)-  where swap (v,g) = (g,v)--{- $references--1. FW #Burton# Burton and RL Page, /Distributed random number generation/,-Journal of Functional Programming, 2(2):203-212, April 1992.--2. SK #Park# Park, and KW Miller, /Random number generators --good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201.--3. DG #Carta# Carta, /Two fast implementations of the minimal standard-random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88.--4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/,-Department of Mathematics, University of Salzburg,-<http://random.mat.sbg.ac.at/~peter/pads98.ps>, 1998.--5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random-number generators/, Comm ACM, 31(6), Jun 1988, pp742-749.--The Web site <http://random.mat.sbg.ac.at/> is a great source of information.---}
− tests/examples/ghc80/RepArrow.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module RepArrow where--import Data.Ord ( Down )  -- convenient "Id" newtype, without its constructor-import Data.Coerce--foo :: Coercible (Down (Int -> Int)) (Int -> Int) => Down (Int -> Int) -> Int -> Int-foo = coerce
− tests/examples/ghc80/Roles12a.hs 
@@ -1,2 +0,0 @@-module Roles12a where-import {-# SOURCE #-} Roles12
− tests/examples/ghc80/RuleDefiningPlugin.hs 
@@ -1,8 +0,0 @@-module RuleDefiningPlugin where--import GhcPlugins--{-# RULES "unsound" forall x. show x = "SHOWED" #-}--plugin :: Plugin-plugin = defaultPlugin
− tests/examples/ghc80/RulePragma.hs 
@@ -1,7 +0,0 @@-module Data.Text.Internal.Fusion.Common where--{-#-  RULES "STREAM map/map fusion" forall f g s.-     map f (map g s) = map (\x -> f (g x)) s- #-}-
− tests/examples/ghc80/SH_Overlap1.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE FlexibleInstances #-}---- | Compilation should fail as we have overlapping instances that don't obey--- our heuristics.-module SH_Overlap1 where--import safe SH_Overlap1_A--instance-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap10.hs 
@@ -1,17 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since--- overlapped instance declares itself overlappable.-module SH_Overlap10 where--import SH_Overlap10_A--instance-  {-# OVERLAPS #-}-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap10_A.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap10_A (-    C(..)-  ) where--import SH_Overlap10_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap10_B.hs 
@@ -1,8 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-module SH_Overlap10_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap11.hs 
@@ -1,18 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred--- unsafe due to overlapping instances at call site `f`.------ Testing that we are given correct reason.-module SH_Overlap11 where--import SH_Overlap11_A--instance-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap11_A.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap11_A (-    C(..)-  ) where--import SH_Overlap11_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap11_B.hs 
@@ -1,8 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-module SH_Overlap11_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap1_A.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap1_A (-    C(..)-  ) where--import SH_Overlap1_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap1_B.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE Safe #-}-module SH_Overlap1_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap2.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'.------ Question: Should the OI-check be enforced? Y, see reasoning in--- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should--- be tied to Safe Haskell mode only, and not to safe imports.-module SH_Overlap2 where--import SH_Overlap2_A--instance-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap2_A.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap2_A (-    C(..)-  ) where--import SH_Overlap2_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap2_B.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE Safe #-}-module SH_Overlap2_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap3.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is--- marked `Unsafe`. Compilation should succeed (symetry with inferring safety).-module SH_Overlap3 where--import SH_Overlap3_A--instance-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap3_A.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap3_A (-    C(..)-  ) where--import SH_Overlap3_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap3_B.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE Safe #-}-module SH_Overlap3_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap4.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`.------ Question: Should compilation now fail? N. At first it seems a nice idea to--- tie the overlap check to safe imports. However, instances are a global--- entity and can be imported by multiple import paths. How should safe imports--- interact with this? Especially when considering transitive situations...------ Simplest is to just enforce the overlap check in Safe and Trustworthy--- modules, but not in Unsafe ones.-module SH_Overlap4 where--import safe SH_Overlap4_A--instance-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap4_A.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap4_A (-    C(..)-  ) where--import SH_Overlap4_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap4_B.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE Safe #-}-module SH_Overlap4_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap5.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Compilation should fail as we have overlapping instances that don't obey--- our heuristics.-module SH_Overlap5 where--import safe SH_Overlap5_A--instance-  C [a] where-    f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap5_A.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap5_A (-    C(..)-  ) where--import SH_Overlap5_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap5_B.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE Safe #-}-module SH_Overlap5_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap6.hs 
@@ -1,15 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not--- explicitly marked. Compilation should still fail.-module SH_Overlap6 where--import safe SH_Overlap6_A--instance C [a] where-  f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap6_A.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap6_A (-    C(..)-  ) where--import SH_Overlap6_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap6_B.hs 
@@ -1,8 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-module SH_Overlap6_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap7.hs 
@@ -1,15 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred--- unsafe due to overlapping instances at call site `f`.-module SH_Overlap7 where--import SH_Overlap7_A--instance C [a] where-  f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap7_A.hs 
@@ -1,14 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}-module SH_Overlap7_A (-    C(..)-  ) where--import SH_Overlap7_B--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap7_B.hs 
@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -fwarn-unsafe #-}-{-# LANGUAGE Safe #-}-module SH_Overlap7_B (-    C(..)-  ) where--class C a where-  f :: a -> String-
− tests/examples/ghc80/SH_Overlap8.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}---- | Overlapping instances, but with a single parameter type-class and no--- orphans. So `SH_Overlap8` decided to explictly depend on `SH_Overlap8_A`--- since that's where the type-class `C` with function `f` is defined.------ Question: Safe or Unsafe? Safe-module SH_Overlap8 where--import safe SH_Overlap8_A--instance C [a] where-  f _ = "[a]"--test :: String-test = f ([1,2,3,4] :: [Int])-
− tests/examples/ghc80/SH_Overlap8_A.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-module SH_Overlap8_A (-    C(..)-  ) where--class C a where-  f :: a -> String--instance-  {-# OVERLAPS #-}-  C [Int] where-    f _ = "[Int]"-
− tests/examples/ghc80/SH_Overlap9.hs

file too large to diff

− tests/examples/ghc80/SH_Overlap9_A.hs

file too large to diff

− tests/examples/ghc80/SH_Overlap9_B.hs

file too large to diff

− tests/examples/ghc80/SayAnnNames.hs

file too large to diff

− tests/examples/ghc80/SelfDep.hs

file too large to diff

− tests/examples/ghc80/SemicolonIf.hs

file too large to diff

− tests/examples/ghc80/SemigroupWarnings.hs

file too large to diff

− tests/examples/ghc80/Setup.hs

file too large to diff

− tests/examples/ghc80/ShouldFail.hs

file too large to diff

− tests/examples/ghc80/SigTvKinds.hs

file too large to diff

− tests/examples/ghc80/SigTvKinds2.hs

file too large to diff

− tests/examples/ghc80/SpecializePhaseControl.hs

file too large to diff

− tests/examples/ghc80/Splices.hs

file too large to diff

− tests/examples/ghc80/SplicesUsed.hs

file too large to diff

− tests/examples/ghc80/StackOverflow.hs

file too large to diff

− tests/examples/ghc80/Structure8.hs

file too large to diff

− tests/examples/ghc80/Structure8a.hs

file too large to diff

− tests/examples/ghc80/T10009.hs

file too large to diff

− tests/examples/ghc80/T10030.hs

file too large to diff

− tests/examples/ghc80/T10041.hs

file too large to diff

− tests/examples/ghc80/T10045.hs

file too large to diff

− tests/examples/ghc80/T10047.hs

file too large to diff

− tests/examples/ghc80/T10052-input.hs

file too large to diff

− tests/examples/ghc80/T10052.hs

file too large to diff

− tests/examples/ghc80/T10083.hs

file too large to diff

− tests/examples/ghc80/T10083a.hs

file too large to diff

− tests/examples/ghc80/T10100.hs

file too large to diff

− tests/examples/ghc80/T10104.hs

file too large to diff

− tests/examples/ghc80/T10109.hs

file too large to diff

− tests/examples/ghc80/T10110A.hs

file too large to diff

− tests/examples/ghc80/T10110B.hs

file too large to diff

− tests/examples/ghc80/T10110C.hs

file too large to diff

− tests/examples/ghc80/T10112.hs

file too large to diff

− tests/examples/ghc80/T10134.hs

file too large to diff

− tests/examples/ghc80/T10139.hs

file too large to diff

− tests/examples/ghc80/T10141.hs

file too large to diff

− tests/examples/ghc80/T10148.hs

file too large to diff

− tests/examples/ghc80/T10156.hs

file too large to diff

− tests/examples/ghc80/T10180.hs

file too large to diff

− tests/examples/ghc80/T10181.hs

file too large to diff

− tests/examples/ghc80/T10182.hs

file too large to diff

− tests/examples/ghc80/T10182a.hs

file too large to diff

− tests/examples/ghc80/T10184.hs

file too large to diff

− tests/examples/ghc80/T10185.hs

file too large to diff

− tests/examples/ghc80/T10188.hs

file too large to diff

− tests/examples/ghc80/T10194.hs

file too large to diff

− tests/examples/ghc80/T10195.hs

file too large to diff

− tests/examples/ghc80/T10196.hs

file too large to diff

− tests/examples/ghc80/T10215.hs

file too large to diff

− tests/examples/ghc80/T10218.hs

file too large to diff

− tests/examples/ghc80/T10220B.hs

file too large to diff

− tests/examples/ghc80/T10226.hs

file too large to diff

− tests/examples/ghc80/T10233.hs

file too large to diff

− tests/examples/ghc80/T10233a.hs

file too large to diff

− tests/examples/ghc80/T10245.hs

file too large to diff

− tests/examples/ghc80/T10246.hs

file too large to diff

− tests/examples/ghc80/T10251.hs

file too large to diff

− tests/examples/ghc80/T10263.hs

file too large to diff

− tests/examples/ghc80/T10267.hs

file too large to diff

− tests/examples/ghc80/T10267a.hs

file too large to diff

− tests/examples/ghc80/T10279.hs

file too large to diff

− tests/examples/ghc80/T10283.hs

file too large to diff

− tests/examples/ghc80/T10284.hs

file too large to diff

− tests/examples/ghc80/T10285.hs

file too large to diff

− tests/examples/ghc80/T10285a.hs

file too large to diff

− tests/examples/ghc80/T10294.hs

file too large to diff

− tests/examples/ghc80/T10294a.hs

file too large to diff

− tests/examples/ghc80/T10306.hs

file too large to diff

− tests/examples/ghc80/T10318.hs

file too large to diff

− tests/examples/ghc80/T10322A.hs

file too large to diff

− tests/examples/ghc80/T10322B.hs

file too large to diff

− tests/examples/ghc80/T10322C.hs

file too large to diff

− tests/examples/ghc80/T10335.hs

file too large to diff

− tests/examples/ghc80/T10340.hs

file too large to diff

− tests/examples/ghc80/T10348.hs

file too large to diff

− tests/examples/ghc80/T10351.hs

file too large to diff

− tests/examples/ghc80/T10359.hs

file too large to diff

− tests/examples/ghc80/T10361a.hs

file too large to diff

− tests/examples/ghc80/T10361b.hs

file too large to diff

− tests/examples/ghc80/T10370.hs

file too large to diff

− tests/examples/ghc80/T10384.hs

file too large to diff

− tests/examples/ghc80/T10390.hs

file too large to diff

− tests/examples/ghc80/T10398.hs

file too large to diff

− tests/examples/ghc80/T10403.hs

file too large to diff

− tests/examples/ghc80/T10414.hs

file too large to diff

− tests/examples/ghc80/T10420.hs

file too large to diff

− tests/examples/ghc80/T10420a.hs

file too large to diff

− tests/examples/ghc80/T10423.hs

file too large to diff

− tests/examples/ghc80/T10428.hs

file too large to diff

− tests/examples/ghc80/T10438.hs

file too large to diff

− tests/examples/ghc80/T10447.hs

file too large to diff

− tests/examples/ghc80/T10451.hs

file too large to diff

− tests/examples/ghc80/T10460.hs

file too large to diff

− tests/examples/ghc80/T10461.hs

file too large to diff

− tests/examples/ghc80/T10463.hs

file too large to diff

− tests/examples/ghc80/T10481.hs

file too large to diff

− tests/examples/ghc80/T10482.hs

file too large to diff

− tests/examples/ghc80/T10482a.hs

file too large to diff

− tests/examples/ghc80/T10487.hs

file too large to diff

− tests/examples/ghc80/T10487_M.hs

file too large to diff

− tests/examples/ghc80/T10489.hs

file too large to diff

− tests/examples/ghc80/T10493.hs

file too large to diff

− tests/examples/ghc80/T10494.hs

file too large to diff

− tests/examples/ghc80/T10495.hs

file too large to diff

− tests/examples/ghc80/T10503.hs

file too large to diff

− tests/examples/ghc80/T10507.hs

file too large to diff

− tests/examples/ghc80/T10508_api.hs

file too large to diff

− tests/examples/ghc80/T10516.hs

file too large to diff

− tests/examples/ghc80/T10519.hs

file too large to diff

− tests/examples/ghc80/T10521.hs

file too large to diff

− tests/examples/ghc80/T10521b.hs

file too large to diff

− tests/examples/ghc80/T10524.hs

file too large to diff

− tests/examples/ghc80/T10534.hs

file too large to diff

− tests/examples/ghc80/T10534a.hs

file too large to diff

− tests/examples/ghc80/T10549.hs

file too large to diff

− tests/examples/ghc80/T10549a.hs

file too large to diff

− tests/examples/ghc80/T10561.hs

file too large to diff

− tests/examples/ghc80/T10562.hs

file too large to diff

− tests/examples/ghc80/T10564.hs

file too large to diff

− tests/examples/ghc80/T10570.hs

file too large to diff

− tests/examples/ghc80/T10590.hs

file too large to diff

− tests/examples/ghc80/T10596.hs

file too large to diff

− tests/examples/ghc80/T10602.hs

file too large to diff

− tests/examples/ghc80/T10602b.hs

file too large to diff

− tests/examples/ghc80/T10615.hs

file too large to diff

− tests/examples/ghc80/T10618.hs

file too large to diff

− tests/examples/ghc80/T10620.hs

file too large to diff

− tests/examples/ghc80/T10627.hs

file too large to diff

− tests/examples/ghc80/T10632.hs

file too large to diff

− tests/examples/ghc80/T10634.hs

file too large to diff

− tests/examples/ghc80/T10637.hs

file too large to diff

− tests/examples/ghc80/T10638.hs

file too large to diff

− tests/examples/ghc80/T10642.hs

file too large to diff

− tests/examples/ghc80/T10662.hs

file too large to diff

− tests/examples/ghc80/T10667.hs

file too large to diff

− tests/examples/ghc80/T10668.hs

file too large to diff

− tests/examples/ghc80/T10670.hs

file too large to diff

− tests/examples/ghc80/T10670a.hs

file too large to diff

− tests/examples/ghc80/T10678.hs

file too large to diff

− tests/examples/ghc80/T10689.hs

file too large to diff

− tests/examples/ghc80/T10694.hs

file too large to diff

− tests/examples/ghc80/T10698.hs

file too large to diff

− tests/examples/ghc80/T10704.hs

file too large to diff

− tests/examples/ghc80/T10704a.hs

file too large to diff

− tests/examples/ghc80/T10713.hs

file too large to diff

− tests/examples/ghc80/T10734.hs

file too large to diff

− tests/examples/ghc80/T10742.hs

file too large to diff

− tests/examples/ghc80/T10744.hs

file too large to diff

− tests/examples/ghc80/T10747.hs

file too large to diff

− tests/examples/ghc80/T10753.hs

file too large to diff

− tests/examples/ghc80/T10767.hs

file too large to diff

− tests/examples/ghc80/T10781.hs

file too large to diff

− tests/examples/ghc80/T10796a.hs

file too large to diff

− tests/examples/ghc80/T10796b.hs

file too large to diff

− tests/examples/ghc80/T10806.hs

file too large to diff

− tests/examples/ghc80/T10815.hs

file too large to diff

− tests/examples/ghc80/T10819.hs

file too large to diff

− tests/examples/ghc80/T10819_Lib.hs

file too large to diff

− tests/examples/ghc80/T10820.hs

file too large to diff

− tests/examples/ghc80/T10826.hs

file too large to diff

− tests/examples/ghc80/T10830.hs

file too large to diff

− tests/examples/ghc80/T10836.hs

file too large to diff

− tests/examples/ghc80/T10845.hs

file too large to diff

− tests/examples/ghc80/T10846.hs

file too large to diff

− tests/examples/ghc80/T10870.hs

file too large to diff

− tests/examples/ghc80/T10890.hs

file too large to diff

− tests/examples/ghc80/T10890_1.hs

file too large to diff

− tests/examples/ghc80/T10890_2.hs

file too large to diff

− tests/examples/ghc80/T10890_2A.hs

file too large to diff

− tests/examples/ghc80/T10890_2B.hs

file too large to diff

− tests/examples/ghc80/T10891.hs

file too large to diff

− tests/examples/ghc80/T10895.hs

file too large to diff

− tests/examples/ghc80/T10897a.hs

file too large to diff

− tests/examples/ghc80/T10897b.hs

file too large to diff

− tests/examples/ghc80/T10904.hs

file too large to diff

− tests/examples/ghc80/T10908.hs

file too large to diff

− tests/examples/ghc80/T10929.hs

file too large to diff

− tests/examples/ghc80/T10931.hs

file too large to diff

− tests/examples/ghc80/T10935.hs

file too large to diff

− tests/examples/ghc80/T10942.hs

file too large to diff

− tests/examples/ghc80/T10942_A.hs

file too large to diff

− tests/examples/ghc80/T10945.hs

file too large to diff

− tests/examples/ghc80/T10946.hs

file too large to diff

− tests/examples/ghc80/T10955dyn.hs

file too large to diff

− tests/examples/ghc80/T10962.hs

file too large to diff

− tests/examples/ghc80/T10970a.hs

file too large to diff

− tests/examples/ghc80/T10971a.hs

file too large to diff

− tests/examples/ghc80/T10971b.hs

file too large to diff

− tests/examples/ghc80/T10971c.hs

file too large to diff

− tests/examples/ghc80/T10971d.hs

file too large to diff

− tests/examples/ghc80/T10997.hs

file too large to diff

− tests/examples/ghc80/T10997_1.hs

file too large to diff

− tests/examples/ghc80/T10997_1a.hs

file too large to diff

− tests/examples/ghc80/T10997a.hs

file too large to diff

− tests/examples/ghc80/T10999.hs

file too large to diff

− tests/examples/ghc80/T11010.hs

file too large to diff

− tests/examples/ghc80/T11016.hs

file too large to diff

− tests/examples/ghc80/T11039.hs

file too large to diff

− tests/examples/ghc80/T11053.hs

file too large to diff

− tests/examples/ghc80/T11067.hs

file too large to diff

− tests/examples/ghc80/T11071.hs

file too large to diff

− tests/examples/ghc80/T11071a.hs

file too large to diff

− tests/examples/ghc80/T11076.hs

file too large to diff

− tests/examples/ghc80/T11076A.hs

file too large to diff

− tests/examples/ghc80/T11077.hs

file too large to diff

− tests/examples/ghc80/T11103.hs

file too large to diff

− tests/examples/ghc80/T11112.hs

file too large to diff

− tests/examples/ghc80/T11128.hs

file too large to diff

− tests/examples/ghc80/T11136.hs

file too large to diff

− tests/examples/ghc80/T11148.hs

file too large to diff

− tests/examples/ghc80/T11155.hs

file too large to diff

− tests/examples/ghc80/T11164.hs

file too large to diff

− tests/examples/ghc80/T11164a.hs

file too large to diff

− tests/examples/ghc80/T11164b.hs

file too large to diff

− tests/examples/ghc80/T11167.hs

file too large to diff

− tests/examples/ghc80/T11167_ambig.hs

file too large to diff

− tests/examples/ghc80/T11167_ambiguous_fixity.hs

file too large to diff

− tests/examples/ghc80/T11167_ambiguous_fixity_A.hs

file too large to diff

− tests/examples/ghc80/T11167_ambiguous_fixity_B.hs

file too large to diff

− tests/examples/ghc80/T11173.hs

file too large to diff

− tests/examples/ghc80/T11173a.hs

file too large to diff

− tests/examples/ghc80/T11182.hs

file too large to diff

− tests/examples/ghc80/T11187.hs

file too large to diff

− tests/examples/ghc80/T11192.hs

file too large to diff

− tests/examples/ghc80/T11193.hs

file too large to diff

− tests/examples/ghc80/T11208.hs

file too large to diff

− tests/examples/ghc80/T11216.hs

file too large to diff

− tests/examples/ghc80/T11224.hs

file too large to diff

− tests/examples/ghc80/T11232.hs

file too large to diff

− tests/examples/ghc80/T11237.hs

file too large to diff

− tests/examples/ghc80/T1133Aa.hs

file too large to diff

− tests/examples/ghc80/T1133a.hs

file too large to diff

− tests/examples/ghc80/T11381.hs

file too large to diff

− tests/examples/ghc80/T11959.hs

file too large to diff

− tests/examples/ghc80/T17a.hs

file too large to diff

− tests/examples/ghc80/T17b.hs

file too large to diff

− tests/examples/ghc80/T17c.hs

file too large to diff

− tests/examples/ghc80/T17d.hs

file too large to diff

− tests/examples/ghc80/T17e.hs

file too large to diff

− tests/examples/ghc80/T1830_1.hs

file too large to diff

− tests/examples/ghc80/T1830_2.hs

file too large to diff

− tests/examples/ghc80/T1830_3.hs

file too large to diff

− tests/examples/ghc80/T1830_3a.hs

file too large to diff

− tests/examples/ghc80/T2006.hs

file too large to diff

− tests/examples/ghc80/T2204.hs

file too large to diff

− tests/examples/ghc80/T2632.hs

file too large to diff

− tests/examples/ghc80/T2931.hs

file too large to diff

− tests/examples/ghc80/T2991.hs

file too large to diff

− tests/examples/ghc80/T3078.hs

file too large to diff

− tests/examples/ghc80/T322.hs

file too large to diff

− tests/examples/ghc80/T3468a.hs

file too large to diff

− tests/examples/ghc80/T3572.hs

file too large to diff

− tests/examples/ghc80/T365.hs

file too large to diff

− tests/examples/ghc80/T366.hs

file too large to diff

− tests/examples/ghc80/T3927.hs

file too large to diff

− tests/examples/ghc80/T3927a.hs

file too large to diff

− tests/examples/ghc80/T4056.hs

file too large to diff

− tests/examples/ghc80/T4139.hs

file too large to diff

− tests/examples/ghc80/T4169.hs

file too large to diff

− tests/examples/ghc80/T4170.hs

file too large to diff

− tests/examples/ghc80/T5001b.hs

file too large to diff

− tests/examples/ghc80/T5333.hs

file too large to diff

− tests/examples/ghc80/T5721.hs

file too large to diff

− tests/examples/ghc80/T5821.hs

file too large to diff

− tests/examples/ghc80/T5884Other.hs

file too large to diff

− tests/examples/ghc80/T5908.hs

file too large to diff

− tests/examples/ghc80/T6018.hs

file too large to diff

− tests/examples/ghc80/T6018Afail.hs

file too large to diff

− tests/examples/ghc80/T6018Bfail.hs

file too large to diff

− tests/examples/ghc80/T6018Cfail.hs

file too large to diff

− tests/examples/ghc80/T6018Dfail.hs

file too large to diff

− tests/examples/ghc80/T6018a.hs

file too large to diff

− tests/examples/ghc80/T6018fail.hs

file too large to diff

− tests/examples/ghc80/T6018failclosed.hs

file too large to diff

− tests/examples/ghc80/T6018failclosed2.hs

file too large to diff

− tests/examples/ghc80/T6018rnfail.hs

file too large to diff

− tests/examples/ghc80/T6018th.hs

file too large to diff

− tests/examples/ghc80/T6062.hs

file too large to diff

− tests/examples/ghc80/T6124.hs

file too large to diff

− tests/examples/ghc80/T7411.hs

file too large to diff

− tests/examples/ghc80/T7669a.hs

file too large to diff

− tests/examples/ghc80/T7672.hs

file too large to diff

− tests/examples/ghc80/T7672a.hs

file too large to diff

− tests/examples/ghc80/T7765.hs

file too large to diff

− tests/examples/ghc80/T7788.hs

file too large to diff

− tests/examples/ghc80/T8030.hs

file too large to diff

− tests/examples/ghc80/T8034.hs

file too large to diff

− tests/examples/ghc80/T8101b.hs

file too large to diff

− tests/examples/ghc80/T8131b.hs

file too large to diff

− tests/examples/ghc80/T8274.hs

file too large to diff

− tests/examples/ghc80/T8455.hs

file too large to diff

− tests/examples/ghc80/T8550.hs

file too large to diff

− tests/examples/ghc80/T8555.hs

file too large to diff

− tests/examples/ghc80/T8633.hs

file too large to diff

− tests/examples/ghc80/T8743a.hs

file too large to diff

− tests/examples/ghc80/T8759a.hs

file too large to diff

− tests/examples/ghc80/T8799.hs

file too large to diff

− tests/examples/ghc80/T8970.hs

file too large to diff

− tests/examples/ghc80/T9015.hs

file too large to diff

− tests/examples/ghc80/T9017.hs

file too large to diff

− tests/examples/ghc80/T9177a.hs

file too large to diff

− tests/examples/ghc80/T9204a.hs

file too large to diff

− tests/examples/ghc80/T9204b.hs

file too large to diff

− tests/examples/ghc80/T9204b2.hs

file too large to diff

− tests/examples/ghc80/T9233.hs

file too large to diff

− tests/examples/ghc80/T9233a.hs

file too large to diff

− tests/examples/ghc80/T9238.hs

file too large to diff

− tests/examples/ghc80/T9260.hs

file too large to diff

− tests/examples/ghc80/T9430.hs

file too large to diff

− tests/examples/ghc80/T9554.hs

file too large to diff

− tests/examples/ghc80/T9600-1.hs

file too large to diff

− tests/examples/ghc80/T9600.hs

file too large to diff

− tests/examples/ghc80/T9824.hs

file too large to diff

− tests/examples/ghc80/T9839_02.hs

file too large to diff

− tests/examples/ghc80/T9839_03.hs

file too large to diff

− tests/examples/ghc80/T9839_04.hs

file too large to diff

− tests/examples/ghc80/T9839_05.hs

file too large to diff

− tests/examples/ghc80/T9839_06.hs

file too large to diff

− tests/examples/ghc80/T9840.hs

file too large to diff

− tests/examples/ghc80/T9840a.hs

file too large to diff

− tests/examples/ghc80/T9858a.hs

file too large to diff

− tests/examples/ghc80/T9858b.hs

file too large to diff

− tests/examples/ghc80/T9858c.hs

file too large to diff

− tests/examples/ghc80/T9858d.hs

file too large to diff

− tests/examples/ghc80/T9858e.hs

file too large to diff

− tests/examples/ghc80/T9867.hs

file too large to diff

− tests/examples/ghc80/T9878b.hs

file too large to diff

− tests/examples/ghc80/T9938.hs

file too large to diff

− tests/examples/ghc80/T9938B.hs

file too large to diff

− tests/examples/ghc80/T9939.hs

file too large to diff

− tests/examples/ghc80/T9951.hs

file too large to diff

− tests/examples/ghc80/T9951b.hs

file too large to diff

− tests/examples/ghc80/T9964.hs

file too large to diff

− tests/examples/ghc80/T9968.hs

file too large to diff

− tests/examples/ghc80/T9968a.hs

file too large to diff

− tests/examples/ghc80/T9973.hs

file too large to diff

− tests/examples/ghc80/T9975a.hs

file too large to diff

− tests/examples/ghc80/T9975b.hs

file too large to diff

− tests/examples/ghc80/TH_abstractFamily.hs

file too large to diff

− tests/examples/ghc80/TH_bracket1.hs

file too large to diff

− tests/examples/ghc80/TH_bracket2.hs

file too large to diff

− tests/examples/ghc80/TH_bracket3.hs

file too large to diff

− tests/examples/ghc80/TH_finalizer.hs

file too large to diff

− tests/examples/ghc80/TH_localname.hs

file too large to diff

− tests/examples/ghc80/TH_namePackage.hs

file too large to diff

− tests/examples/ghc80/TH_nameSpace.hs

file too large to diff

− tests/examples/ghc80/TH_ppr1.hs

file too large to diff

− tests/examples/ghc80/TH_reifyType1.hs

file too large to diff

− tests/examples/ghc80/TH_reifyType2.hs

file too large to diff

− tests/examples/ghc80/TH_repE1.hs

file too large to diff

− tests/examples/ghc80/TH_repE3.hs

file too large to diff

− tests/examples/ghc80/TH_scope.hs

file too large to diff

− tests/examples/ghc80/TH_spliceE5_prof_ext.hs

file too large to diff

− tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs

file too large to diff

− tests/examples/ghc80/TH_tf2.hs

file too large to diff

− tests/examples/ghc80/TcCustomSolverSuper.hs

file too large to diff

− tests/examples/ghc80/Templates.hs

file too large to diff

− tests/examples/ghc80/Test.hs

file too large to diff

− tests/examples/ghc80/Test10255.hs

file too large to diff

− tests/examples/ghc80/Test10268.hs

file too large to diff

− tests/examples/ghc80/Test10269.hs

file too large to diff

− tests/examples/ghc80/Test10276.hs

file too large to diff

− tests/examples/ghc80/Test10278.hs

file too large to diff

− tests/examples/ghc80/Test10280.hs

file too large to diff

− tests/examples/ghc80/Test10307.hs

file too large to diff

− tests/examples/ghc80/Test10309.hs

file too large to diff

− tests/examples/ghc80/Test10312.hs

file too large to diff

− tests/examples/ghc80/Test10313.hs

file too large to diff

− tests/examples/ghc80/Test10354.hs

file too large to diff

− tests/examples/ghc80/Test10357.hs

file too large to diff

− tests/examples/ghc80/Test10358.hs

file too large to diff

− tests/examples/ghc80/Test10396.hs

file too large to diff

− tests/examples/ghc80/Test10399.hs

file too large to diff

− tests/examples/ghc80/Test11018.hs

file too large to diff

− tests/examples/ghc80/TestBoolFormula.hs

file too large to diff

− tests/examples/ghc80/TestUtils.hs

file too large to diff

− tests/examples/ghc80/Trac10045.hs

file too large to diff

− tests/examples/ghc80/TransAssociated.hs

file too large to diff

− tests/examples/ghc80/TransBundle.hs

file too large to diff

− tests/examples/ghc80/TypeFamilyInstanceLHS.hs

file too large to diff

− tests/examples/ghc80/TypeLevelVec.hs

file too large to diff

− tests/examples/ghc80/TypeSkolEscape.hs

file too large to diff

− tests/examples/ghc80/TypedSplice.hs

file too large to diff

− tests/examples/ghc80/UnicodeRules.hs

file too large to diff

− tests/examples/ghc80/Vta1.hs

file too large to diff

− tests/examples/ghc80/Vta2.hs

file too large to diff

− tests/examples/ghc80/WCompatWarningsNotOn.hs

file too large to diff

− tests/examples/ghc80/WCompatWarningsOff.hs

file too large to diff

− tests/examples/ghc80/WCompatWarningsOn.hs

file too large to diff

− tests/examples/ghc80/WCompatWarningsOnOff.hs

file too large to diff

− tests/examples/ghc80/Zwaluw.hs

file too large to diff

− tests/examples/ghc80/ado001.hs

file too large to diff

− tests/examples/ghc80/ado002.hs

file too large to diff

− tests/examples/ghc80/ado003.hs

file too large to diff

− tests/examples/ghc80/ado004.hs

file too large to diff

− tests/examples/ghc80/ado005.hs

file too large to diff

− tests/examples/ghc80/ado006.hs

file too large to diff

− tests/examples/ghc80/ado007.hs

file too large to diff

− tests/examples/ghc80/boolFormula.hs

file too large to diff

− tests/examples/ghc80/determinism001.hs

file too large to diff

− tests/examples/ghc80/export-class.hs

file too large to diff

− tests/examples/ghc80/export-ps-rec-sel.hs

file too large to diff

− tests/examples/ghc80/export-record-selector.hs

file too large to diff

− tests/examples/ghc80/export-super-class-fail.hs

file too large to diff

− tests/examples/ghc80/export-super-class.hs

file too large to diff

− tests/examples/ghc80/export-syntax.hs

file too large to diff

− tests/examples/ghc80/export-type-synonym.hs

file too large to diff

− tests/examples/ghc80/export-type.hs

file too large to diff

− tests/examples/ghc80/frontend01.hs

file too large to diff

− tests/examples/ghc80/haddockA034.hs

file too large to diff

− tests/examples/ghc80/listcomps.hs

file too large to diff

− tests/examples/ghc80/mixed-pat-syn-record-sels.hs

file too large to diff

− tests/examples/ghc80/multi-export.hs

file too large to diff

− tests/examples/ghc80/overloadedlabelsfail01.hs

file too large to diff

− tests/examples/ghc80/overloadedlabelsrun01.hs

file too large to diff

− tests/examples/ghc80/overloadedlabelsrun02.hs

file too large to diff

− tests/examples/ghc80/overloadedlabelsrun03.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail01.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail02.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail03.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail04.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail05.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail06.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail07.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail08.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail09.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail10.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail11.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail12.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail13.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsfail14.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsrun01.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsrun02.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsrun03.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsrun04.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsrun05.hs

file too large to diff

− tests/examples/ghc80/overloadedrecfldsrun06.hs

file too large to diff

− tests/examples/ghc80/performGC.hs

file too large to diff

− tests/examples/ghc80/plugins07.hs

file too large to diff

− tests/examples/ghc80/pmc001.hs

file too large to diff

− tests/examples/ghc80/pmc002.hs

file too large to diff

− tests/examples/ghc80/pmc003.hs

file too large to diff

− tests/examples/ghc80/pmc004.hs

file too large to diff

− tests/examples/ghc80/pmc005.hs

file too large to diff

− tests/examples/ghc80/pmc006.hs

file too large to diff

− tests/examples/ghc80/pmc007.hs

file too large to diff

− tests/examples/ghc80/poly-export-fail2.hs

file too large to diff

− tests/examples/ghc80/poly-export.hs

file too large to diff

− tests/examples/ghc80/poly-export2.hs

file too large to diff

− tests/examples/ghc80/poly-export3.hs

file too large to diff

− tests/examples/ghc80/records-check-sels.hs

file too large to diff

− tests/examples/ghc80/records-compile.hs

file too large to diff

− tests/examples/ghc80/records-exquant.hs

file too large to diff

− tests/examples/ghc80/records-mixing-fields.hs

file too large to diff

− tests/examples/ghc80/records-no-uni-update.hs

file too large to diff

− tests/examples/ghc80/records-no-uni-update2.hs

file too large to diff

− tests/examples/ghc80/records-poly-update.hs

file too large to diff

− tests/examples/ghc80/records-poly.hs

file too large to diff

− tests/examples/ghc80/records-prov-req.hs

file too large to diff

− tests/examples/ghc80/records-req-only.hs

file too large to diff

− tests/examples/ghc80/records-req.hs

file too large to diff

− tests/examples/ghc80/records-run.hs

file too large to diff

− tests/examples/ghc80/spec-inline-determ.hs

file too large to diff

− tests/examples/ghc80/stringSource.hs

file too large to diff

− tests/examples/ghc80/t10255.hs

file too large to diff

− tests/examples/ghc80/t10268.hs

file too large to diff

− tests/examples/ghc80/t10269.hs

file too large to diff

− tests/examples/ghc80/t10278.hs

file too large to diff

− tests/examples/ghc80/t10280.hs

file too large to diff

− tests/examples/ghc80/t10307.hs

file too large to diff

− tests/examples/ghc80/t10309.hs

file too large to diff

− tests/examples/ghc80/t10312.hs

file too large to diff

− tests/examples/ghc80/t10354.hs

file too large to diff

− tests/examples/ghc80/t10357.hs

file too large to diff

− tests/examples/ghc80/t10358.hs

file too large to diff

− tests/examples/ghc80/t10396.hs

file too large to diff

− tests/examples/ghc80/t10399.hs

file too large to diff

− tests/examples/ghc80/tc265.hs

file too large to diff

− tests/examples/ghc80/tcfail223.hs

file too large to diff

− tests/examples/ghc80/update-existential.hs

file too large to diff

− tests/examples/ghc82/Completesig03A.hs

file too large to diff

− tests/examples/ghc82/Lib.hs

file too large to diff

− tests/examples/ghc82/List2.hs

file too large to diff

− tests/examples/ghc82/Ppr048.hs

file too large to diff

− tests/examples/ghc82/T11727.hs

file too large to diff

− tests/examples/ghc82/T13050.hs

file too large to diff

− tests/examples/ghc82/T13594.hs

file too large to diff

− tests/examples/ghc82/brackets.hs

file too large to diff

− tests/examples/ghc82/completesig01.hs

file too large to diff

− tests/examples/ghc84/Functors.hs

file too large to diff

− tests/examples/ghc84/Main.hs

file too large to diff

− tests/examples/ghc84/T13747.hs

file too large to diff

− tests/examples/ghc84/Types.hs

file too large to diff

− tests/examples/ghc84/arrowfail003.hs

file too large to diff

− tests/examples/ghc86/Arith.hs

file too large to diff

− tests/examples/ghc86/BadTelescope.hs

file too large to diff

− tests/examples/ghc86/BadTelescope2.hs

file too large to diff

− tests/examples/ghc86/BadTelescope3.hs

file too large to diff

− tests/examples/ghc86/BadTelescope4.hs

file too large to diff

− tests/examples/ghc86/Boot1.hs

file too large to diff

− tests/examples/ghc86/Dep3.hs

file too large to diff

− tests/examples/ghc86/GADT.hs

file too large to diff

− tests/examples/ghc86/HashTab.hs

file too large to diff

− tests/examples/ghc86/KindEqualities2.hs

file too large to diff

− tests/examples/ghc86/LiftedConstructors.hs

file too large to diff

− tests/examples/ghc86/Parser.hs

file too large to diff

− tests/examples/ghc86/RAE_T32a.hs

file too large to diff

− tests/examples/ghc86/RAE_T32b.hs

file too large to diff

− tests/examples/ghc86/Rae31.hs

file too large to diff

− tests/examples/ghc86/RaeBlogPost.hs

file too large to diff

− tests/examples/ghc86/RenamingStar.hs

file too large to diff

− tests/examples/ghc86/ST.hs

file too large to diff

− tests/examples/ghc86/SlidingTypeSyn.hs

file too large to diff

− tests/examples/ghc86/T10134a.hs

file too large to diff

− tests/examples/ghc86/T10279.hs

file too large to diff

− tests/examples/ghc86/T10321.hs

file too large to diff

− tests/examples/ghc86/T10638.hs

file too large to diff

− tests/examples/ghc86/T10689a.hs

file too large to diff

− tests/examples/ghc86/T10819.hs

file too large to diff

− tests/examples/ghc86/T10891.hs

file too large to diff

− tests/examples/ghc86/T10934.hs

file too large to diff

− tests/examples/ghc86/T11142.hs

file too large to diff

− tests/examples/ghc86/T11484.hs

file too large to diff

− tests/examples/ghc86/T12478_5.hs

file too large to diff

− tests/examples/ghc86/T14164.hs

file too large to diff

− tests/examples/ghc86/T14650.hs

file too large to diff

− tests/examples/ghc86/T2632.hs

file too large to diff

− tests/examples/ghc86/T3263-2.hs

file too large to diff

− tests/examples/ghc86/T3391.hs

file too large to diff

− tests/examples/ghc86/T3572.hs

file too large to diff

− tests/examples/ghc86/T3927b.hs

file too large to diff

− tests/examples/ghc86/T4056.hs

file too large to diff

− tests/examples/ghc86/T4169.hs

file too large to diff

− tests/examples/ghc86/T4170.hs

file too large to diff

− tests/examples/ghc86/T5217.hs

file too large to diff

− tests/examples/ghc86/T6018th.hs

file too large to diff

− tests/examples/ghc86/T6062.hs

file too large to diff

− tests/examples/ghc86/T8455.hs

file too large to diff

− tests/examples/ghc86/T8759a.hs

file too large to diff

− tests/examples/ghc86/T8807.hs

file too large to diff

− tests/examples/ghc86/T9367.hs

file too large to diff

− tests/examples/ghc86/T9632.hs

file too large to diff

− tests/examples/ghc86/T9662.hs

file too large to diff

− tests/examples/ghc86/T9824.hs

file too large to diff

− tests/examples/ghc86/TH_abstractFamily.hs

file too large to diff

− tests/examples/ghc86/TH_bracket1.hs

file too large to diff

− tests/examples/ghc86/TH_bracket2.hs

file too large to diff

− tests/examples/ghc86/TH_bracket3.hs

file too large to diff

− tests/examples/ghc86/TH_class1.hs

file too large to diff

− tests/examples/ghc86/TH_dataD1.hs

file too large to diff

− tests/examples/ghc86/TH_localname.hs

file too large to diff

− tests/examples/ghc86/TH_lookupName.hs

file too large to diff

− tests/examples/ghc86/TH_ppr1.hs

file too large to diff

− tests/examples/ghc86/TH_raiseErr1.hs

file too large to diff

− tests/examples/ghc86/TH_recover.hs

file too large to diff

− tests/examples/ghc86/TH_reifyDecl1.hs

file too large to diff

− tests/examples/ghc86/TH_reifyDecl2.hs

file too large to diff

− tests/examples/ghc86/TH_reifyInstances.hs

file too large to diff

− tests/examples/ghc86/TH_reifyMkName.hs

file too large to diff

− tests/examples/ghc86/TH_repE1.hs

file too large to diff

− tests/examples/ghc86/TH_repE2.hs

file too large to diff

− tests/examples/ghc86/TH_repE3.hs

file too large to diff

− tests/examples/ghc86/TH_repGuard.hs

file too large to diff

− tests/examples/ghc86/TH_repGuardOutput.hs

file too large to diff

− tests/examples/ghc86/TH_repPatSig.hs

file too large to diff

− tests/examples/ghc86/TH_repPatSigTVar.hs

file too large to diff

− tests/examples/ghc86/TH_repPrim.hs

file too large to diff

− tests/examples/ghc86/TH_repPrim2.hs

file too large to diff

− tests/examples/ghc86/TH_repPrimOutput.hs

file too large to diff

− tests/examples/ghc86/TH_repPrimOutput2.hs

file too large to diff

− tests/examples/ghc86/TH_scope.hs

file too large to diff

− tests/examples/ghc86/TH_sections.hs

file too large to diff

− tests/examples/ghc86/TH_spliceD2.hs

file too large to diff

− tests/examples/ghc86/TH_spliceDecl1.hs

file too large to diff

− tests/examples/ghc86/TH_spliceDecl2.hs

file too large to diff

− tests/examples/ghc86/TH_spliceDecl3.hs

file too large to diff

− tests/examples/ghc86/TH_spliceE1.hs

file too large to diff

− tests/examples/ghc86/TH_spliceE3.hs

file too large to diff

− tests/examples/ghc86/TH_spliceE4.hs

file too large to diff

− tests/examples/ghc86/TH_spliceE5_Lib.hs

file too large to diff

− tests/examples/ghc86/TH_spliceE5_prof_Lib.hs

file too large to diff

− tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs

file too large to diff

− tests/examples/ghc86/TH_spliceExpr1.hs

file too large to diff

− tests/examples/ghc86/TH_tf1.hs

file too large to diff

− tests/examples/ghc86/TH_tf3.hs

file too large to diff

− tests/examples/ghc86/TH_unresolvedInfix.hs

file too large to diff

− tests/examples/ghc86/TH_unresolvedInfix2.hs

file too large to diff

− tests/examples/ghc86/TensorTests.hs

file too large to diff

− tests/examples/ghc86/Test.hs

file too large to diff

− tests/examples/ghc86/Test12417.hs

file too large to diff

− tests/examples/ghc86/TupleN.hs

file too large to diff

− tests/examples/ghc86/UnicodeSyntax.hs

file too large to diff

− tests/examples/ghc86/Webhook.hs

file too large to diff

− tests/examples/ghc86/deriving-via-compile.hs

file too large to diff

− tests/examples/ghc86/determ004.hs

file too large to diff

− tests/examples/ghc86/dynamic-paper.hs

file too large to diff

− tests/examples/ghc86/dynbrk005.hs

file too large to diff

− tests/examples/ghc86/ffi1.hs

file too large to diff

− tests/examples/ghc86/ghci006.hs

file too large to diff

− tests/examples/ghc86/haddockA026.hs

file too large to diff

− tests/examples/ghc86/haddockA027.hs

file too large to diff

− tests/examples/ghc86/haddockA031.hs

file too large to diff

− tests/examples/ghc86/haddockC026.hs

file too large to diff

− tests/examples/ghc86/haddockC027.hs

file too large to diff

− tests/examples/ghc86/haddockC031.hs

file too large to diff

− tests/examples/ghc86/mdo.hs

file too large to diff

− tests/examples/ghc86/mkGADTVars.hs

file too large to diff

− tests/examples/ghc86/overloadedrecflds_generics.hs

file too large to diff

+ tests/examples/ghc910/AnnotationNoListTuplePuns.hs view

file too large to diff

+ tests/examples/ghc910/ByHand.hs view

file too large to diff

+ tests/examples/ghc910/Cfipu.hs view

file too large to diff

+ tests/examples/ghc910/Class.hs view

file too large to diff

+ tests/examples/ghc910/ConPat.hs view

file too large to diff

+ tests/examples/ghc910/ConstructorArgs.hs view

file too large to diff

+ tests/examples/ghc910/Disambiguate.hs view

file too large to diff

+ tests/examples/ghc910/Domino.hs view

file too large to diff

+ tests/examples/ghc910/ErrorSpec.hs view

file too large to diff

+ tests/examples/ghc910/Expression.hs view

file too large to diff

+ tests/examples/ghc910/Generate.hs view

file too large to diff

+ tests/examples/ghc910/GenerateBug.hs view

file too large to diff

+ tests/examples/ghc910/Generic.hs view

file too large to diff

+ tests/examples/ghc910/Lexing.hs view

file too large to diff

+ tests/examples/ghc910/LinearLet.hs view

file too large to diff

+ tests/examples/ghc910/Manager.hs view

file too large to diff

+ tests/examples/ghc910/MonoBacktrackPrio.hs view

file too large to diff

+ tests/examples/ghc910/Normalform.hs view

file too large to diff

+ tests/examples/ghc910/Operator1.hs view

file too large to diff

+ tests/examples/ghc910/P_IO_data.hs view

file too large to diff

+ tests/examples/ghc910/PostProcess.hs view

file too large to diff

+ tests/examples/ghc910/PrettyPrinter.hs view

file too large to diff

+ tests/examples/ghc910/ProjectionLike.hs view

file too large to diff

+ tests/examples/ghc910/ScriptSyntax.hs view

file too large to diff

+ tests/examples/ghc910/Sum.hs view

file too large to diff

+ tests/examples/ghc910/T14032a.hs view

file too large to diff

+ tests/examples/ghc910/T17594a.hs view

file too large to diff

+ tests/examples/ghc910/T23927.hs view

file too large to diff

+ tests/examples/ghc910/T8761.hs view

file too large to diff

+ tests/examples/ghc910/Test138.hs view

file too large to diff

+ tests/examples/ghc910/type-operators1-four-out.hs view

file too large to diff

+ tests/examples/ghc912/Fff.hs view

file too large to diff

+ tests/examples/ghc912/Module.hs view

file too large to diff

+ tests/examples/ghc912/Operator.hs view

file too large to diff

+ tests/examples/ghc912/T23501a.hs view

file too large to diff

+ tests/examples/ghc914/A.8.hs view

file too large to diff

+ tests/examples/ghc914/SI01.hs view

file too large to diff

+ tests/examples/ghc914/SI26.hs view

file too large to diff

− tests/examples/pre-ghc86/BadTelescope.hs

file too large to diff

− tests/examples/pre-ghc86/BadTelescope2.hs

file too large to diff

− tests/examples/pre-ghc86/BadTelescope3.hs

file too large to diff

− tests/examples/pre-ghc86/BadTelescope4.hs

file too large to diff

− tests/examples/pre-ghc86/Dep3.hs

file too large to diff

− tests/examples/pre-ghc86/KindEqualities2.hs

file too large to diff

− tests/examples/pre-ghc86/LiftedConstructors.hs

file too large to diff

− tests/examples/pre-ghc86/RAE_T32a.hs

file too large to diff

− tests/examples/pre-ghc86/RAE_T32b.hs

file too large to diff

− tests/examples/pre-ghc86/Rae31.hs

file too large to diff

− tests/examples/pre-ghc86/RaeBlogPost.hs

file too large to diff

− tests/examples/pre-ghc86/RenamingStar.hs

file too large to diff

− tests/examples/pre-ghc86/SlidingTypeSyn.hs

file too large to diff

− tests/examples/pre-ghc86/T10134a.hs

file too large to diff

− tests/examples/pre-ghc86/T10321.hs

file too large to diff

− tests/examples/pre-ghc86/T10689a.hs

file too large to diff

− tests/examples/pre-ghc86/T10934.hs

file too large to diff

− tests/examples/pre-ghc86/T11142.hs

file too large to diff

− tests/examples/pre-ghc86/T3927b.hs

file too large to diff

− tests/examples/pre-ghc86/T9632.hs

file too large to diff

− tests/examples/pre-ghc86/TensorTests.hs

file too large to diff

− tests/examples/pre-ghc86/UnicodeSyntax.hs

file too large to diff

− tests/examples/pre-ghc86/Vect.hs

file too large to diff

− tests/examples/pre-ghc86/Webhook.hs

file too large to diff

− tests/examples/pre-ghc86/determ004.hs

file too large to diff

− tests/examples/pre-ghc86/dynamic-paper.hs

file too large to diff

− tests/examples/pre-ghc86/mkGADTVars.hs

file too large to diff

− tests/examples/pre-ghc86/overloadedrecflds_generics.hs

file too large to diff

+ tests/examples/pre-ghc910/A.32.hs view

file too large to diff

+ tests/examples/pre-ghc910/A.hs view

file too large to diff

+ tests/examples/pre-ghc910/AddAndOr3.hs view

file too large to diff

+ tests/examples/pre-ghc910/AddParams2.hs view

file too large to diff

+ tests/examples/pre-ghc910/AdhocRule.hs view

file too large to diff

+ tests/examples/pre-ghc910/AltsSemis.hs view

file too large to diff

+ tests/examples/pre-ghc910/Ann01.hs view

file too large to diff

+ tests/examples/pre-ghc910/AnnPackageName.hs view

file too large to diff

+ tests/examples/pre-ghc910/Annotations.hs view

file too large to diff

+ tests/examples/pre-ghc910/Arith.hs view

file too large to diff

+ tests/examples/pre-ghc910/Arity2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Arrow.hs view

file too large to diff

+ tests/examples/pre-ghc910/ArrowLambdaCase.hs view

file too large to diff

+ tests/examples/pre-ghc910/Arrows.hs view

file too large to diff

+ tests/examples/pre-ghc910/Associated.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Associated.hs view

file too large to diff

+ tests/examples/pre-ghc910/Associated1.hs view

file too large to diff

+ tests/examples/pre-ghc910/AssociatedInternal.hs view

file too large to diff

+ tests/examples/pre-ghc910/AssociatedType.hs view

file too large to diff

+ tests/examples/pre-ghc910/Async.hs view

file too large to diff

+ tests/examples/pre-ghc910/B.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/B.hs view

file too large to diff

+ tests/examples/pre-ghc910/BCase.hs view

file too large to diff

+ tests/examples/pre-ghc910/BIf.hs view

file too large to diff

+ tests/examples/pre-ghc910/Backquote.hs view

file too large to diff

+ tests/examples/pre-ghc910/BadTelescope.hs view

file too large to diff

+ tests/examples/pre-ghc910/BadTelescope2.hs view

file too large to diff

+ tests/examples/pre-ghc910/BadTelescope3.hs view

file too large to diff

+ tests/examples/pre-ghc910/BadTelescope4.hs view

file too large to diff

+ tests/examples/pre-ghc910/BalanceComments1.hs view

file too large to diff

+ tests/examples/pre-ghc910/BangPatterns.hs view

file too large to diff

+ tests/examples/pre-ghc910/Base.hs view

file too large to diff

+ tests/examples/pre-ghc910/BaseDescriptor.hs view

file too large to diff

+ tests/examples/pre-ghc910/BaseDescriptor2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Binary.hs view

file too large to diff

+ tests/examples/pre-ghc910/BlockComment.hs view

file too large to diff

+ tests/examples/pre-ghc910/Boot1.hs view

file too large to diff

+ tests/examples/pre-ghc910/BootImport.hs view

file too large to diff

+ tests/examples/pre-ghc910/BootImport.hs-boot view

file too large to diff

+ tests/examples/pre-ghc910/BracesSemiDataDecl.hs view

file too large to diff

+ tests/examples/pre-ghc910/Branches.hs view

file too large to diff

+ tests/examples/pre-ghc910/Bundle.hs view

file too large to diff

+ tests/examples/pre-ghc910/Bundle1.hs view

file too large to diff

+ tests/examples/pre-ghc910/BundleExport.hs view

file too large to diff

+ tests/examples/pre-ghc910/BundleInternal.hs view

file too large to diff

+ tests/examples/pre-ghc910/BundleInternal1.hs view

file too large to diff

+ tests/examples/pre-ghc910/C.hs view

file too large to diff

+ tests/examples/pre-ghc910/CExpected.hs view

file too large to diff

+ tests/examples/pre-ghc910/CExpected1.hs view

file too large to diff

+ tests/examples/pre-ghc910/CSETest.hs view

file too large to diff

+ tests/examples/pre-ghc910/Case.hs view

file too large to diff

+ tests/examples/pre-ghc910/Cg008.hs view

file too large to diff

+ tests/examples/pre-ghc910/Character.hs view

file too large to diff

+ tests/examples/pre-ghc910/CheckUtils.hs view

file too large to diff

+ tests/examples/pre-ghc910/Checkpoint.hs view

file too large to diff

+ tests/examples/pre-ghc910/Class.hs view

file too large to diff

+ tests/examples/pre-ghc910/ClassParens.hs view

file too large to diff

+ tests/examples/pre-ghc910/ClosedFam1a.hs view

file too large to diff

+ tests/examples/pre-ghc910/ClosedFam2a.hs view

file too large to diff

+ tests/examples/pre-ghc910/ClosedFam3a.hs view

file too large to diff

+ tests/examples/pre-ghc910/CmmSwitchTest.hs view

file too large to diff

+ tests/examples/pre-ghc910/CmmSwitchTestGen.hs view

file too large to diff

+ tests/examples/pre-ghc910/Collapse1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Commands.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentOrder.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentPlacement.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentPlacement2.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentPlacement3.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentPlacement4.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentPlacement5.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommentPlacement6.hs view

file too large to diff

+ tests/examples/pre-ghc910/CommonUI.hs view

file too large to diff

+ tests/examples/pre-ghc910/Compare.hs view

file too large to diff

+ tests/examples/pre-ghc910/Completesig03A.hs view

file too large to diff

+ tests/examples/pre-ghc910/ConDeclEmptyCtx.hs view

file too large to diff

+ tests/examples/pre-ghc910/ConPat.hs view

file too large to diff

+ tests/examples/pre-ghc910/ConstructorComment.hs view

file too large to diff

+ tests/examples/pre-ghc910/ContinuationIO.hs view

file too large to diff

+ tests/examples/pre-ghc910/Control.hs view

file too large to diff

+ tests/examples/pre-ghc910/CoreIr.hs view

file too large to diff

+ tests/examples/pre-ghc910/CorePragma.hs view

file too large to diff

+ tests/examples/pre-ghc910/Cpp.hs view

file too large to diff

+ tests/examples/pre-ghc910/CustomTypeErrors01.hs view

file too large to diff

+ tests/examples/pre-ghc910/CustomTypeErrors02.hs view

file too large to diff

+ tests/examples/pre-ghc910/CustomTypeErrors03.hs view

file too large to diff

+ tests/examples/pre-ghc910/D.hs view

file too large to diff

+ tests/examples/pre-ghc910/DataDecl.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/DataDecl.hs view

file too large to diff

+ tests/examples/pre-ghc910/DataFamilies.hs view

file too large to diff

+ tests/examples/pre-ghc910/DataFamilyInstanceLHS.hs view

file too large to diff

+ tests/examples/pre-ghc910/DatatypeContexts.hs view

file too large to diff

+ tests/examples/pre-ghc910/Dead1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Decision.hs view

file too large to diff

+ tests/examples/pre-ghc910/Default.hs view

file too large to diff

+ tests/examples/pre-ghc910/DefaultTypeInstance.hs view

file too large to diff

+ tests/examples/pre-ghc910/Defer03.hs view

file too large to diff

+ tests/examples/pre-ghc910/Dep1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Dep2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Dep3.hs view

file too large to diff

+ tests/examples/pre-ghc910/DepFail1.hs view

file too large to diff

+ tests/examples/pre-ghc910/DependentStmt.hs view

file too large to diff

+ tests/examples/pre-ghc910/DeprM.hs view

file too large to diff

+ tests/examples/pre-ghc910/DeprU.hs view

file too large to diff

+ tests/examples/pre-ghc910/Deprecation.hs view

file too large to diff

+ tests/examples/pre-ghc910/Deriving.hs view

file too large to diff

+ tests/examples/pre-ghc910/DerivingOC.hs view

file too large to diff

+ tests/examples/pre-ghc910/DoParens.hs view

file too large to diff

+ tests/examples/pre-ghc910/DoPatBind.hs view

file too large to diff

+ tests/examples/pre-ghc910/DocDecls.hs view

file too large to diff

+ tests/examples/pre-ghc910/Dollar2.hs view

file too large to diff

+ tests/examples/pre-ghc910/DollarDefault.hs view

file too large to diff

+ tests/examples/pre-ghc910/DollarTest.hs view

file too large to diff

+ tests/examples/pre-ghc910/DoubleForall.hs view

file too large to diff

+ tests/examples/pre-ghc910/DroppedComma.hs view

file too large to diff

+ tests/examples/pre-ghc910/DroppedDoSpace.hs view

file too large to diff

+ tests/examples/pre-ghc910/DroppedDoSpace2.hs view

file too large to diff

+ tests/examples/pre-ghc910/DsStrict.hs view

file too large to diff

+ tests/examples/pre-ghc910/DsStrictData.hs view

file too large to diff

+ tests/examples/pre-ghc910/DsStrictFail.hs view

file too large to diff

+ tests/examples/pre-ghc910/DsStrictLet.hs view

file too large to diff

+ tests/examples/pre-ghc910/DsStrictWarn.hs view

file too large to diff

+ tests/examples/pre-ghc910/DumpParsedAst.hs view

file too large to diff

+ tests/examples/pre-ghc910/EmptyCase008.hs view

file too large to diff

+ tests/examples/pre-ghc910/EmptyMostly.hs view

file too large to diff

+ tests/examples/pre-ghc910/EmptyMostly2.hs view

file too large to diff

+ tests/examples/pre-ghc910/EmptyMostlyInst.hs view

file too large to diff

+ tests/examples/pre-ghc910/EmptyMostlyNoSemis.hs view

file too large to diff

+ tests/examples/pre-ghc910/EmptyMostlyTrailing.hs view

file too large to diff

+ tests/examples/pre-ghc910/Eq.hs view

file too large to diff

+ tests/examples/pre-ghc910/Existential.hs view

file too large to diff

+ tests/examples/pre-ghc910/Exp.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExpandSynsFail1.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExpandSynsFail2.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExpandSynsFail3.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExpandSynsFail4.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExperimIOP.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExplicitForAllRules1.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExplicitNamespaces.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExplicitSpecificity4.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExplicitSpecificityA1.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExportSyntax.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExportSyntaxImport.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExportWarnings_aux.hs view

file too large to diff

+ tests/examples/pre-ghc910/Expr.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExprPragmas.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExprSigLocal.hs view

file too large to diff

+ tests/examples/pre-ghc910/Extends.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraints1.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardInExpressionSignature.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSignature.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSplice.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice2.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSpliceUsed.hs view

file too large to diff

+ tests/examples/pre-ghc910/ExtraConstraintsWildcardTwice.hs view

file too large to diff

+ tests/examples/pre-ghc910/F.hs view

file too large to diff

+ tests/examples/pre-ghc910/FDsFromGivens2.hs view

file too large to diff

+ tests/examples/pre-ghc910/FOL.hs view

file too large to diff

+ tests/examples/pre-ghc910/Families.hs view

file too large to diff

+ tests/examples/pre-ghc910/Field.hs view

file too large to diff

+ tests/examples/pre-ghc910/Field1.hs view

file too large to diff

+ tests/examples/pre-ghc910/FooBar.hs view

file too large to diff

+ tests/examples/pre-ghc910/FooExpected.hs view

file too large to diff

+ tests/examples/pre-ghc910/ForAll.hs view

file too large to diff

+ tests/examples/pre-ghc910/ForFree.hs view

file too large to diff

+ tests/examples/pre-ghc910/ForeignDecl.hs view

file too large to diff

+ tests/examples/pre-ghc910/ForeignDecl1.hs view

file too large to diff

+ tests/examples/pre-ghc910/FromGrin2.hs view

file too large to diff

+ tests/examples/pre-ghc910/FromManual.hs view

file too large to diff

+ tests/examples/pre-ghc910/FromUtils.hs view

file too large to diff

+ tests/examples/pre-ghc910/FrontendPlugin.hs view

file too large to diff

+ tests/examples/pre-ghc910/FunDeps.hs view

file too large to diff

+ tests/examples/pre-ghc910/FunctionalDeps.hs view

file too large to diff

+ tests/examples/pre-ghc910/Functors.hs view

file too large to diff

+ tests/examples/pre-ghc910/GA1r.hs view

file too large to diff

+ tests/examples/pre-ghc910/GADT.hs view

file too large to diff

+ tests/examples/pre-ghc910/GADTRecords.hs view

file too large to diff

+ tests/examples/pre-ghc910/GADTRecords2.hs view

file too large to diff

+ tests/examples/pre-ghc910/GHCOrig.hs view

file too large to diff

+ tests/examples/pre-ghc910/Generate.hs view

file too large to diff

+ tests/examples/pre-ghc910/Generic.hs view

file too large to diff

+ tests/examples/pre-ghc910/GenericDeriving.hs view

file too large to diff

+ tests/examples/pre-ghc910/Group.hs view

file too large to diff

+ tests/examples/pre-ghc910/Guards.hs view

file too large to diff

+ tests/examples/pre-ghc910/Haddock.hs view

file too large to diff

+ tests/examples/pre-ghc910/Haddock1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Haddock2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Haddock3.hs view

file too large to diff

+ tests/examples/pre-ghc910/HangingRecord.hs view

file too large to diff

+ tests/examples/pre-ghc910/HashQQ.hs view

file too large to diff

+ tests/examples/pre-ghc910/HashTab.hs view

file too large to diff

+ tests/examples/pre-ghc910/HsDo.hs view

file too large to diff

+ tests/examples/pre-ghc910/HsDocTy.hs view

file too large to diff

+ tests/examples/pre-ghc910/IPLocation.hs view

file too large to diff

+ tests/examples/pre-ghc910/IfThenElse1.hs view

file too large to diff

+ tests/examples/pre-ghc910/IfThenElse2.hs view

file too large to diff

+ tests/examples/pre-ghc910/IfThenElse3.hs view

file too large to diff

+ tests/examples/pre-ghc910/ImplicitParams.hs view

file too large to diff

+ tests/examples/pre-ghc910/ImplicitSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/ImplicitTypeSyn.hs view

file too large to diff

+ tests/examples/pre-ghc910/Import.hs view

file too large to diff

+ tests/examples/pre-ghc910/Imports.hs view

file too large to diff

+ tests/examples/pre-ghc910/ImportsSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/Improvement.hs view

file too large to diff

+ tests/examples/pre-ghc910/IndentedComments.hs view

file too large to diff

+ tests/examples/pre-ghc910/IndentedDo.hs view

file too large to diff

+ tests/examples/pre-ghc910/IndentedModule2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Infix.hs view

file too large to diff

+ tests/examples/pre-ghc910/InfixPatternSynonyms.hs view

file too large to diff

+ tests/examples/pre-ghc910/InlineSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/Internal.hs view

file too large to diff

+ tests/examples/pre-ghc910/Internals.hs view

file too large to diff

+ tests/examples/pre-ghc910/Issue91.hs view

file too large to diff

+ tests/examples/pre-ghc910/Jon.hs view

file too large to diff

+ tests/examples/pre-ghc910/KindEqualities.hs view

file too large to diff

+ tests/examples/pre-ghc910/KindEqualities2.hs view

file too large to diff

+ tests/examples/pre-ghc910/KindLevels.hs view

file too large to diff

+ tests/examples/pre-ghc910/LambdaCase.hs view

file too large to diff

+ tests/examples/pre-ghc910/LayoutLet.hs view

file too large to diff

+ tests/examples/pre-ghc910/LayoutWhere.hs view

file too large to diff

+ tests/examples/pre-ghc910/LetExpr.hs view

file too large to diff

+ tests/examples/pre-ghc910/LetExpr2.hs view

file too large to diff

+ tests/examples/pre-ghc910/LetExprSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/LetIn.hs view

file too large to diff

+ tests/examples/pre-ghc910/LetStmt.hs view

file too large to diff

+ tests/examples/pre-ghc910/LexerM2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Lib.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Lib.hs view

file too large to diff

+ tests/examples/pre-ghc910/LiftedConstructors.hs view

file too large to diff

+ tests/examples/pre-ghc910/LiftedInfixConstructor.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinePragma.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinePragmas.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear10.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear12.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear14.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear15.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear16.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear1Rule.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear3.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear4.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear6.hs view

file too large to diff

+ tests/examples/pre-ghc910/Linear8.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearArrow.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearConstructors.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearEmptyCase.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearGuards.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearTH1.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearTH2.hs view

file too large to diff

+ tests/examples/pre-ghc910/LinearTypeable.hs view

file too large to diff

+ tests/examples/pre-ghc910/List2.hs view

file too large to diff

+ tests/examples/pre-ghc910/ListComments.hs view

file too large to diff

+ tests/examples/pre-ghc910/ListComprehensions.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/ListComprehensions.hs view

file too large to diff

+ tests/examples/pre-ghc910/LiteralsTest2.hs view

file too large to diff

+ tests/examples/pre-ghc910/LocalDecls2Expected.hs view

file too large to diff

+ tests/examples/pre-ghc910/MachineTypes.hs view

file too large to diff

+ tests/examples/pre-ghc910/MagicHash.hs view

file too large to diff

+ tests/examples/pre-ghc910/Main.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Main.2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Main.hs view

file too large to diff

+ tests/examples/pre-ghc910/MangledSemiLet.hs view

file too large to diff

+ tests/examples/pre-ghc910/Manipulate.hs view

file too large to diff

+ tests/examples/pre-ghc910/Match.hs view

file too large to diff

+ tests/examples/pre-ghc910/MatchSemis.hs view

file too large to diff

+ tests/examples/pre-ghc910/Memoize.hs view

file too large to diff

+ tests/examples/pre-ghc910/Minimal.hs view

file too large to diff

+ tests/examples/pre-ghc910/Mixed.hs view

file too large to diff

+ tests/examples/pre-ghc910/ModuleComments.hs view

file too large to diff

+ tests/examples/pre-ghc910/ModuleComments1.hs view

file too large to diff

+ tests/examples/pre-ghc910/ModuleComments2.hs view

file too large to diff

+ tests/examples/pre-ghc910/ModuleComments3.hs view

file too large to diff

+ tests/examples/pre-ghc910/ModuleOnly.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonadComprehensions.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonadFailErrors.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonadFailWarnings.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonadFailWarningsDisabled.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonadFailWarningsWithRebindableSyntax.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonadT.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonoidsFD.hs view

file too large to diff

+ tests/examples/pre-ghc910/MonoidsFD1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Move1.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultConstructor.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiImplicitParams.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiLineCommentWithPragmas.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiLineWarningPragma.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiParamTypeClasses.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiQuote.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiWayIf.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/MultiWayIf.hs view

file too large to diff

+ tests/examples/pre-ghc910/NamedWildcardInDataFamilyInstanceLHS.hs view

file too large to diff

+ tests/examples/pre-ghc910/NamedWildcardInTypeFamilyInstanceLHS.hs view

file too large to diff

+ tests/examples/pre-ghc910/NamedWildcardInTypeSplice.hs view

file too large to diff

+ tests/examples/pre-ghc910/NestedDoLambda.hs view

file too large to diff

+ tests/examples/pre-ghc910/NestedLambda.hs view

file too large to diff

+ tests/examples/pre-ghc910/NullaryTypeClasses.hs view

file too large to diff

+ tests/examples/pre-ghc910/Obscure.hs view

file too large to diff

+ tests/examples/pre-ghc910/Observer.hs view

file too large to diff

+ tests/examples/pre-ghc910/Observer1.hs view

file too large to diff

+ tests/examples/pre-ghc910/OldList.hs view

file too large to diff

+ tests/examples/pre-ghc910/Op.hs view

file too large to diff

+ tests/examples/pre-ghc910/OptSig.hs view

file too large to diff

+ tests/examples/pre-ghc910/OptSig2.hs view

file too large to diff

+ tests/examples/pre-ghc910/OutOfHeap.hs view

file too large to diff

+ tests/examples/pre-ghc910/OveridingPrimitives.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail04_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail06_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail10_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail10_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail10_C.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail11_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsFail12_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedRecFldsRun02_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/OverloadedStrings.hs view

file too large to diff

+ tests/examples/pre-ghc910/P.hs view

file too large to diff

+ tests/examples/pre-ghc910/PArr.hs view

file too large to diff

+ tests/examples/pre-ghc910/PSQ.hs view

file too large to diff

+ tests/examples/pre-ghc910/ParenFunBind.hs view

file too large to diff

+ tests/examples/pre-ghc910/ParenTypeSynonym.hs view

file too large to diff

+ tests/examples/pre-ghc910/ParensAroundContext.hs view

file too large to diff

+ tests/examples/pre-ghc910/ParensGADT.hs view

file too large to diff

+ tests/examples/pre-ghc910/Parse.hs view

file too large to diff

+ tests/examples/pre-ghc910/Parser.hs view

file too large to diff

+ tests/examples/pre-ghc910/ParserArrowLambdaCase.hs view

file too large to diff

+ tests/examples/pre-ghc910/PartialClassMethodSignature2.hs view

file too large to diff

+ tests/examples/pre-ghc910/PatBind.hs view

file too large to diff

+ tests/examples/pre-ghc910/PatSigBind.hs view

file too large to diff

+ tests/examples/pre-ghc910/PatSynBind.hs view

file too large to diff

+ tests/examples/pre-ghc910/PatternGuards.hs view

file too large to diff

+ tests/examples/pre-ghc910/PluralS.hs view

file too large to diff

+ tests/examples/pre-ghc910/PolyInstances.hs view

file too large to diff

+ tests/examples/pre-ghc910/PopCnt.hs view

file too large to diff

+ tests/examples/pre-ghc910/PostgreSQL.hs view

file too large to diff

+ tests/examples/pre-ghc910/Ppr006a.hs view

file too large to diff

+ tests/examples/pre-ghc910/Ppr017.hs view

file too large to diff

+ tests/examples/pre-ghc910/Ppr048.hs view

file too large to diff

+ tests/examples/pre-ghc910/Pr110.hs view

file too large to diff

+ tests/examples/pre-ghc910/PragmaSpans.hs view

file too large to diff

+ tests/examples/pre-ghc910/Primop.hs view

file too large to diff

+ tests/examples/pre-ghc910/Printf.hs view

file too large to diff

+ tests/examples/pre-ghc910/ProcNotation.hs view

file too large to diff

+ tests/examples/pre-ghc910/Process.hs view

file too large to diff

+ tests/examples/pre-ghc910/Process1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Process2.hs view

file too large to diff

+ tests/examples/pre-ghc910/PromotedClass.hs view

file too large to diff

+ tests/examples/pre-ghc910/Pseudonym.hs view

file too large to diff

+ tests/examples/pre-ghc910/PuncFunctions.hs view

file too large to diff

+ tests/examples/pre-ghc910/Q.hs view

file too large to diff

+ tests/examples/pre-ghc910/QQ.hs view

file too large to diff

+ tests/examples/pre-ghc910/QuasiQuote.hs view

file too large to diff

+ tests/examples/pre-ghc910/QuasiQuote2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Query.hs view

file too large to diff

+ tests/examples/pre-ghc910/RAE_T32a.hs view

file too large to diff

+ tests/examples/pre-ghc910/RAE_T32b.hs view

file too large to diff

+ tests/examples/pre-ghc910/RList.hs view

file too large to diff

+ tests/examples/pre-ghc910/RSA.hs view

file too large to diff

+ tests/examples/pre-ghc910/Rae31.hs view

file too large to diff

+ tests/examples/pre-ghc910/RaeBlogPost.hs view

file too large to diff

+ tests/examples/pre-ghc910/RandomPGC1.hs view

file too large to diff

+ tests/examples/pre-ghc910/RankNTypes.hs view

file too large to diff

+ tests/examples/pre-ghc910/RdrNames.hs view

file too large to diff

+ tests/examples/pre-ghc910/RebindableSyntax.hs view

file too large to diff

+ tests/examples/pre-ghc910/RecordSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/RecordUpdate.hs view

file too large to diff

+ tests/examples/pre-ghc910/RecordWildcard.hs view

file too large to diff

+ tests/examples/pre-ghc910/Records.hs view

file too large to diff

+ tests/examples/pre-ghc910/Records2.hs view

file too large to diff

+ tests/examples/pre-ghc910/RecursiveDo.hs view

file too large to diff

+ tests/examples/pre-ghc910/RedundantDo.hs view

file too large to diff

+ tests/examples/pre-ghc910/Remorse.hs view

file too large to diff

+ tests/examples/pre-ghc910/RenamingStar.hs view

file too large to diff

+ tests/examples/pre-ghc910/RepArrow.hs view

file too large to diff

+ tests/examples/pre-ghc910/Retrie.hs view

file too large to diff

+ tests/examples/pre-ghc910/RmDecl4.hs view

file too large to diff

+ tests/examples/pre-ghc910/Roles.hs view

file too large to diff

+ tests/examples/pre-ghc910/Roles12a.hs view

file too large to diff

+ tests/examples/pre-ghc910/RuleDefiningPlugin.hs view

file too large to diff

+ tests/examples/pre-ghc910/RulePragma.hs view

file too large to diff

+ tests/examples/pre-ghc910/Rules.hs view

file too large to diff

+ tests/examples/pre-ghc910/RulesSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap1.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap10.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap10_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap10_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap11.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap11_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap11_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap1_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap1_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap2.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap2_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap2_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap3.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap3_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap3_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap4.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap4_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap4_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap5.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap5_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap5_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap6.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap6_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap6_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap7.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap7_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap7_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap8.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap8_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap9.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap9_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/SH_Overlap9_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/ST.hs view

file too large to diff

+ tests/examples/pre-ghc910/SayAnnNames.hs view

file too large to diff

+ tests/examples/pre-ghc910/ScopedTypeVariables.hs view

file too large to diff

+ tests/examples/pre-ghc910/ScopesBug.hs view

file too large to diff

+ tests/examples/pre-ghc910/SelfDep.hs view

file too large to diff

+ tests/examples/pre-ghc910/SemiInstance.hs view

file too large to diff

+ tests/examples/pre-ghc910/SemiWorkout.hs view

file too large to diff

+ tests/examples/pre-ghc910/SemicolonIf.hs view

file too large to diff

+ tests/examples/pre-ghc910/SemigroupWarnings.hs view

file too large to diff

+ tests/examples/pre-ghc910/Setup.hs view

file too large to diff

+ tests/examples/pre-ghc910/Shebang.hs view

file too large to diff

+ tests/examples/pre-ghc910/ShiftingLambda.hs view

file too large to diff

+ tests/examples/pre-ghc910/ShouldFail.hs view

file too large to diff

+ tests/examples/pre-ghc910/SigTvKinds.hs view

file too large to diff

+ tests/examples/pre-ghc910/SigTvKinds2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Sigs.hs view

file too large to diff

+ tests/examples/pre-ghc910/Simple.hs view

file too large to diff

+ tests/examples/pre-ghc910/SimpleComplexTuple.hs view

file too large to diff

+ tests/examples/pre-ghc910/SimpleDo.hs view

file too large to diff

+ tests/examples/pre-ghc910/SlidingDataClassDecl.hs view

file too large to diff

+ tests/examples/pre-ghc910/SlidingDoClause.hs view

file too large to diff

+ tests/examples/pre-ghc910/SlidingLambda.hs view

file too large to diff

+ tests/examples/pre-ghc910/SlidingListComp.hs view

file too large to diff

+ tests/examples/pre-ghc910/SlidingRecordSetter.hs view

file too large to diff

+ tests/examples/pre-ghc910/SlidingTypeSyn.hs view

file too large to diff

+ tests/examples/pre-ghc910/SpacesSplice.hs view

file too large to diff

+ tests/examples/pre-ghc910/SpecializePhaseControl.hs view

file too large to diff

+ tests/examples/pre-ghc910/Splice.hs view

file too large to diff

+ tests/examples/pre-ghc910/SpliceSemi.hs view

file too large to diff

+ tests/examples/pre-ghc910/Splices.hs view

file too large to diff

+ tests/examples/pre-ghc910/SplicesUsed.hs view

file too large to diff

+ tests/examples/pre-ghc910/StackOverflow.hs view

file too large to diff

+ tests/examples/pre-ghc910/StarBinder.hs view

file too large to diff

+ tests/examples/pre-ghc910/StaticPointers.hs view

file too large to diff

+ tests/examples/pre-ghc910/Stmts.hs view

file too large to diff

+ tests/examples/pre-ghc910/StrangeTypeClass.hs view

file too large to diff

+ tests/examples/pre-ghc910/Stream.hs view

file too large to diff

+ tests/examples/pre-ghc910/StrictLet.hs view

file too large to diff

+ tests/examples/pre-ghc910/StringGap.hs view

file too large to diff

+ tests/examples/pre-ghc910/StringRef.hs view

file too large to diff

+ tests/examples/pre-ghc910/Structure8.hs view

file too large to diff

+ tests/examples/pre-ghc910/Structure8a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10009.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10030.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10041.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10045.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10047.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10052-input.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10052.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10083.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10083a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10100.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10104.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10109.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10110A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10110B.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10110C.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10112.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10134.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10134a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10139.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10141.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10148.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10156.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10180.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10181.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10182.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10182a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10184.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10185.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10188.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10194.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10195.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10196.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10196.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10215.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10218.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10220B.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10226.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10233.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10233a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10245.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10246.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10251.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10263.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10267.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10267a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10279.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10279.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10283.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10284.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10285.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10285a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10294.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10294a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10306.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10318.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10321.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10322A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10322B.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10322C.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10335.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10340.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10348.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10351.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10359.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10361a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10361b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10370.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10384.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10390.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10398.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10403.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10414.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10420.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10420a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10423.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10428.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10438.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10447.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10451.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10460.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10461.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10463.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10481.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10482.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10482a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10487.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10487_M.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10489.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10493.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10494.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10495.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10503.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10507.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10508_api.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10516.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10519.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10521.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10521b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10524.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10534.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10534a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10549.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10549a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10561.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10562.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10564.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10570.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10590.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10596.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10602.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10602b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10615.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10618.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10620.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10627.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10632.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10634.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10637.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10638.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10638.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10642.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10662.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10667.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10668.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10670.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10670a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10678.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10689.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10689a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10694.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10698.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10704.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10704a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10713.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10734.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10742.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10744.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10747.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10753.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10767.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10781.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10796a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10796b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10806.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10815.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10819.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10819.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10819_Lib.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10820.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10826.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10830.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10836.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10845.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10846.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10870.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10890.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10890_1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10890_2.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10890_2A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10890_2B.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10891.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10891.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10895.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10897a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10897b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10904.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10908.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10929.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10931.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10934.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10935.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10942.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10942.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10942_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10945.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10946.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10955dyn.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10962.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10971a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10971b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10971c.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10971d.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10997.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10997_1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10997_1a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10997a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T10999.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11010.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11016.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11039.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11053.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11067.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11071.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11071a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11076.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11076A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11077.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11103.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11112.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11128.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11136.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11142.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11148.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11155.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11164.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11164a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11164b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11167.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11167_ambig.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11167_ambiguous_fixity.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11167_ambiguous_fixity_A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11167_ambiguous_fixity_B.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11173.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11173a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11182.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11187.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11192.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11193.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11208.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11216.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11224.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11232.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11237.hs view

file too large to diff

+ tests/examples/pre-ghc910/T1133Aa.hs view

file too large to diff

+ tests/examples/pre-ghc910/T1133a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11381.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11484.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11671_run.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11727.hs view

file too large to diff

+ tests/examples/pre-ghc910/T11959.hs view

file too large to diff

+ tests/examples/pre-ghc910/T12045TH1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T12045TH2.hs view

file too large to diff

+ tests/examples/pre-ghc910/T12045a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T12478_5.hs view

file too large to diff

+ tests/examples/pre-ghc910/T13050.hs view

file too large to diff

+ tests/examples/pre-ghc910/T13087.hs view

file too large to diff

+ tests/examples/pre-ghc910/T13343.hs view

file too large to diff

+ tests/examples/pre-ghc910/T13594.hs view

file too large to diff

+ tests/examples/pre-ghc910/T13747.hs view

file too large to diff

+ tests/examples/pre-ghc910/T14164.hs view

file too large to diff

+ tests/examples/pre-ghc910/T14650.hs view

file too large to diff

+ tests/examples/pre-ghc910/T15365.hs view

file too large to diff

+ tests/examples/pre-ghc910/T16326_Compile1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17296.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17544_kw.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17c.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17d.hs view

file too large to diff

+ tests/examples/pre-ghc910/T17e.hs view

file too large to diff

+ tests/examples/pre-ghc910/T18023.hs view

file too large to diff

+ tests/examples/pre-ghc910/T1830_1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T1830_2.hs view

file too large to diff

+ tests/examples/pre-ghc910/T1830_3.hs view

file too large to diff

+ tests/examples/pre-ghc910/T1830_3a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T18432.hs view

file too large to diff

+ tests/examples/pre-ghc910/T18522-dbg-ppr.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2006.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2204.hs view

file too large to diff

+ tests/examples/pre-ghc910/T22315b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T22332a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T22500.hs view

file too large to diff

+ tests/examples/pre-ghc910/T23465.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2388.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2632.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2632.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2931.hs view

file too large to diff

+ tests/examples/pre-ghc910/T2991.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3078.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3132.hs view

file too large to diff

+ tests/examples/pre-ghc910/T322.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3263-2.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3391.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3391.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3468a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3572.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3572.hs view

file too large to diff

+ tests/examples/pre-ghc910/T365.hs view

file too large to diff

+ tests/examples/pre-ghc910/T366.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3927.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3927a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T3927b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4056.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4056.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4139.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4169.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4169.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4170.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4170.hs view

file too large to diff

+ tests/examples/pre-ghc910/T4437.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5001b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5217.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5333.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5721.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5821.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5884Other.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5908.hs view

file too large to diff

+ tests/examples/pre-ghc910/T5951.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018Afail.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018Bfail.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018Cfail.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018Dfail.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018fail.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018failclosed.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018failclosed2.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018rnfail.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018th.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6018th.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6062.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6062.hs view

file too large to diff

+ tests/examples/pre-ghc910/T6124.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7411.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7669a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7672.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7672a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7765.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7788.hs view

file too large to diff

+ tests/examples/pre-ghc910/T7918A.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8030.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8034.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8101b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8131b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8274.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8455.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8455.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8550.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8555.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8633.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8743a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8759a.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8759a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8799.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8807.hs view

file too large to diff

+ tests/examples/pre-ghc910/T8970.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9015.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9017.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9177a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9204a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9204b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9204b2.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9233.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9233a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9238.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9260.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9367.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9430.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9554.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9600-1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9600.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9632.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9662.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9824.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9824.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9839_02.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9839_03.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9839_04.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9839_05.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9839_06.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9840.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9840a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9858a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9858b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9858c.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9858d.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9858e.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9867.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9878b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9938.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9938B.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9939.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9951.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9951b.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9964.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9968.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9968a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9973.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9975a.hs view

file too large to diff

+ tests/examples/pre-ghc910/T9975b.hs view

file too large to diff

+ tests/examples/pre-ghc910/TDDataConstructor.hs view

file too large to diff

+ tests/examples/pre-ghc910/TDExistential.hs view

file too large to diff

+ tests/examples/pre-ghc910/TDGADT.hs view

file too large to diff

+ tests/examples/pre-ghc910/TDGoodConsConstraints.hs view

file too large to diff

+ tests/examples/pre-ghc910/TDVector.hs view

file too large to diff

+ tests/examples/pre-ghc910/TD_TH_splice.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH2.hs view

file too large to diff

+ tests/examples/pre-ghc910/THMonadInstance.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_abstractFamily.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_abstractFamily.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_bracket1.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_bracket1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_bracket2.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_bracket2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_bracket3.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_bracket3.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_class1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_dataD1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_finalizer.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_localname.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_localname.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_lookupName.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_namePackage.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_nameSpace.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_ppr1.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_ppr1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_raiseErr1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_recover.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_recover_warns.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_recursiveDoImport.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyDecl1.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyDecl1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyDecl1a.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyDecl2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyInstances.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyLinear.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyMkName.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyType1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_reifyType2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repE1.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repE1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repE2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repE3.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repE3.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repGuard.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repGuardOutput.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repPatSig.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repPatSigTVar.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repPrim.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repPrim2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repPrimOutput.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_repPrimOutput2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_scope.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_scope.2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_scope.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_sections.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceD2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceDecl1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceDecl2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceDecl3.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE3.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE4.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE5_Lib.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE5_prof_Lib.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE5_prof_ext.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_spliceExpr1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_tf1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_tf2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_tf3.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_unresolvedInfix.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_unresolvedInfix.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_unresolvedInfix2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TH_unresolvedInfix_Lib.hs view

file too large to diff

+ tests/examples/pre-ghc910/TcCustomSolverSuper.hs view

file too large to diff

+ tests/examples/pre-ghc910/TemplateHaskell.hs view

file too large to diff

+ tests/examples/pre-ghc910/Templates.hs view

file too large to diff

+ tests/examples/pre-ghc910/TensorTests.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test.1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test.2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10255.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10268.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10269.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10276.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10278.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10280.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10307.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10309.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10312.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10313.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10354.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10357.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10358.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test10396.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test11018.hs view

file too large to diff

+ tests/examples/pre-ghc910/Test12417.hs view

file too large to diff

+ tests/examples/pre-ghc910/TestBoolFormula.hs view

file too large to diff

+ tests/examples/pre-ghc910/TestUtils.hs view

file too large to diff

+ tests/examples/pre-ghc910/Token.hs view

file too large to diff

+ tests/examples/pre-ghc910/TopLevelSemis.hs view

file too large to diff

+ tests/examples/pre-ghc910/TopLevelSemis1.hs view

file too large to diff

+ tests/examples/pre-ghc910/TopLevelSemis2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TopLevelSemis3.hs view

file too large to diff

+ tests/examples/pre-ghc910/TopLevelSemis4.hs view

file too large to diff

+ tests/examples/pre-ghc910/Trac10045.hs view

file too large to diff

+ tests/examples/pre-ghc910/TransAssociated.hs view

file too large to diff

+ tests/examples/pre-ghc910/TransBundle.hs view

file too large to diff

+ tests/examples/pre-ghc910/TransformListComp.hs view

file too large to diff

+ tests/examples/pre-ghc910/Trit.hs view

file too large to diff

+ tests/examples/pre-ghc910/TupSection.hs view

file too large to diff

+ tests/examples/pre-ghc910/Tuple.hs view

file too large to diff

+ tests/examples/pre-ghc910/TupleN.hs view

file too large to diff

+ tests/examples/pre-ghc910/TupleSections.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeBrackets.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeBrackets2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeBrackets4.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeFamilies.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeFamilies2.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeFamilyInstanceLHS.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeInstance.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeLevelVec.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeOperators.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeSignature.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeSignatureParens.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeSkolEscape.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeSynOperator.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypeSynParens.hs view

file too large to diff

+ tests/examples/pre-ghc910/TypedSplice.hs view

file too large to diff

+ tests/examples/pre-ghc910/Types.hs view

file too large to diff

+ tests/examples/pre-ghc910/Unboxed.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined10.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined10a.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined11.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined13.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined2.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined3.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined4.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined5.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined6.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined7.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined8.hs view

file too large to diff

+ tests/examples/pre-ghc910/Undefined9.hs view

file too large to diff

+ tests/examples/pre-ghc910/Unicode.hs view

file too large to diff

+ tests/examples/pre-ghc910/UnicodeRules.hs view

file too large to diff

+ tests/examples/pre-ghc910/UnicodeSyntax.hs view

file too large to diff

+ tests/examples/pre-ghc910/Utilities.hs view

file too large to diff

+ tests/examples/pre-ghc910/Utils.hs view

file too large to diff

+ tests/examples/pre-ghc910/Utils2.hs view

file too large to diff

+ tests/examples/pre-ghc910/ViewPatterns.hs view

file too large to diff

+ tests/examples/pre-ghc910/Vta1.hs view

file too large to diff

+ tests/examples/pre-ghc910/Vta2.hs view

file too large to diff

+ tests/examples/pre-ghc910/WCompatWarningsNotOn.hs view

file too large to diff

+ tests/examples/pre-ghc910/WCompatWarningsOff.hs view

file too large to diff

+ tests/examples/pre-ghc910/WCompatWarningsOn.hs view

file too large to diff

+ tests/examples/pre-ghc910/WCompatWarningsOnOff.hs view

file too large to diff

+ tests/examples/pre-ghc910/Warning.hs view

file too large to diff

+ tests/examples/pre-ghc910/Webhook.hs view

file too large to diff

+ tests/examples/pre-ghc910/Zipper.hs view

file too large to diff

+ tests/examples/pre-ghc910/Zwaluw.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado001.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado002.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado003.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado004.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado005.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado006.hs view

file too large to diff

+ tests/examples/pre-ghc910/ado007.hs view

file too large to diff

+ tests/examples/pre-ghc910/anf.hs view

file too large to diff

+ tests/examples/pre-ghc910/boolFormula.hs view

file too large to diff

+ tests/examples/pre-ghc910/brackets.hs view

file too large to diff

+ tests/examples/pre-ghc910/completesig01.hs view

file too large to diff

+ tests/examples/pre-ghc910/deriving-via-compile.hs view

file too large to diff

+ tests/examples/pre-ghc910/determ004.hs view

file too large to diff

+ tests/examples/pre-ghc910/determinism001.hs view

file too large to diff

+ tests/examples/pre-ghc910/dynamic-paper.hs view

file too large to diff

+ tests/examples/pre-ghc910/dynbrk005.hs view

file too large to diff

+ tests/examples/pre-ghc910/empty-foralls.hs view

file too large to diff

+ tests/examples/pre-ghc910/empty-foralls2.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-class.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-ps-rec-sel.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-record-selector.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-super-class-fail.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-super-class.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-syntax.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-type-synonym.hs view

file too large to diff

+ tests/examples/pre-ghc910/export-type.hs view

file too large to diff

+ tests/examples/pre-ghc910/ffi1.hs view

file too large to diff

+ tests/examples/pre-ghc910/frontend01.hs view

file too large to diff

+ tests/examples/pre-ghc910/ghci006.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockA026.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockA027.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockA031.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockA034.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockC026.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockC027.hs view

file too large to diff

+ tests/examples/pre-ghc910/haddockC031.hs view

file too large to diff

+ tests/examples/pre-ghc910/hie010.hs view

file too large to diff

+ tests/examples/pre-ghc910/listcomps.hs view

file too large to diff

+ tests/examples/pre-ghc910/mdo.hs view

file too large to diff

+ tests/examples/pre-ghc910/mixed-pat-syn-record-sels.hs view

file too large to diff

+ tests/examples/pre-ghc910/mkGADTVars.hs view

file too large to diff

+ tests/examples/pre-ghc910/mod181.hs view

file too large to diff

+ tests/examples/pre-ghc910/multi-export.hs view

file too large to diff

+ tests/examples/pre-ghc910/n-plus-k-patterns.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedlabelsfail01.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedlabelsrun01.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedlabelsrun02.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedlabelsrun03.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecflds_generics.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail01.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail02.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail03.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail04.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail05.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail06.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail07.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail08.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail09.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail10.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail11.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail12.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail13.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsfail14.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsrun01.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsrun02.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsrun03.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsrun04.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsrun05.hs view

file too large to diff

+ tests/examples/pre-ghc910/overloadedrecfldsrun06.hs view

file too large to diff

+ tests/examples/pre-ghc910/performGC.hs view

file too large to diff

+ tests/examples/pre-ghc910/plugins07.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc001.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc002.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc003.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc004.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc005.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc006.hs view

file too large to diff

+ tests/examples/pre-ghc910/pmc007.hs view

file too large to diff

+ tests/examples/pre-ghc910/poly-export-fail2.hs view

file too large to diff

+ tests/examples/pre-ghc910/poly-export.hs view

file too large to diff

+ tests/examples/pre-ghc910/poly-export2.hs view

file too large to diff

+ tests/examples/pre-ghc910/poly-export3.hs view

file too large to diff

+ tests/examples/pre-ghc910/proc-do-complex-four-out.hs view

file too large to diff

+ tests/examples/pre-ghc910/proc-do-complex-out.hs view

file too large to diff

+ tests/examples/pre-ghc910/proc-do-complex.hs view

file too large to diff

+ tests/examples/pre-ghc910/proc-lets-out.hs view

file too large to diff

+ tests/examples/pre-ghc910/proc-lets.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdocompile001.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdocompile002.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun001.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun002.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun003.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun004.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun005.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun006.hs view

file too large to diff

+ tests/examples/pre-ghc910/qdorun007.hs view

file too large to diff

+ tests/examples/pre-ghc910/read018.hs view

file too large to diff

+ tests/examples/pre-ghc910/record-dot-four-out.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-check-sels.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-compile.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-exquant.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-mixing-fields.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-no-uni-update.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-no-uni-update2.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-poly-update.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-poly.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-prov-req.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-req-only.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-req.hs view

file too large to diff

+ tests/examples/pre-ghc910/records-run.hs view

file too large to diff

+ tests/examples/pre-ghc910/saks029.hs view

file too large to diff

+ tests/examples/pre-ghc910/saks032.hs view

file too large to diff

+ tests/examples/pre-ghc910/spec-inline-determ.hs view

file too large to diff

+ tests/examples/pre-ghc910/stringSource.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10255.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10268.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10269.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10278.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10280.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10307.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10309.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10312.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10354.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10357.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10358.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10396.hs view

file too large to diff

+ tests/examples/pre-ghc910/t10399.hs view

file too large to diff

+ tests/examples/pre-ghc910/tc265.hs view

file too large to diff

+ tests/examples/pre-ghc910/tcfail223.hs view

file too large to diff

+ tests/examples/pre-ghc910/update-existential.hs view

file too large to diff

+ tests/examples/transform/AddArgFromWhereComments.hs view

file too large to diff

+ tests/examples/transform/AddArgFromWhereComments.hs.expected view

file too large to diff

tests/examples/transform/AddDecl.hs view

file too large to diff

tests/examples/transform/AddDecl.hs.expected view

file too large to diff

tests/examples/transform/AddLocalDecl1.hs view

file too large to diff

tests/examples/transform/AddLocalDecl1.hs.expected view

file too large to diff

tests/examples/transform/WhereIn3a.hs.expected view

file too large to diff

+ tests/examples/transform/WhereIn3b.hs view

file too large to diff

+ tests/examples/transform/WhereIn3b.hs.expected view

file too large to diff

− tests/examples/vect/DiophantineVect.hs

file too large to diff