ghc-exactprint 0.6 → 0.6.1

raw patch · 33 files changed

+5397/−41 lines, 33 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog +2/−0
• ghc-exactprint.cabal +30/−22
• src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs +2938/−0
• src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs +23/−2
• src/Language/Haskell/GHC/ExactPrint/Delta.hs +34/−1
• src/Language/Haskell/GHC/ExactPrint/Parsers.hs +13/−0
• src/Language/Haskell/GHC/ExactPrint/Pretty.hs +16/−0
• src/Language/Haskell/GHC/ExactPrint/Print.hs +23/−1
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +22/−1
• src/Language/Haskell/GHC/ExactPrint/Types.hs +27/−1
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +6/−0
• tests/Test.hs +36/−7
• tests/Test/Transform.hs +32/−6
• tests/examples/failing/dsrun010.hs +25/−0
• tests/examples/ghc88/ClassParens.hs +11/−0
• tests/examples/ghc88/DumpParsedAst.hs +20/−0
• tests/examples/ghc88/EmptyCase008.hs +55/−0
• tests/examples/ghc88/Exp.hs +203/−0
• tests/examples/ghc88/ExplicitForAllRules1.hs +46/−0
• tests/examples/ghc88/Internal.hs +342/−0
• tests/examples/ghc88/PersistUniqueTest.hs +45/−0
• tests/examples/ghc88/StarBinder.hs +7/−0
• tests/examples/ghc88/T12045TH1.hs +18/−0
• tests/examples/ghc88/T12045TH2.hs +31/−0
• tests/examples/ghc88/T12045a.hs +84/−0
• tests/examples/ghc88/T13087.hs +9/−0
• tests/examples/ghc88/T15365.hs +32/−0
• tests/examples/ghc88/T4437.hs +57/−0
• tests/examples/ghc88/TH_recover_warns.hs +11/−0
• tests/examples/ghc88/TH_recursiveDoImport.hs +25/−0
• tests/examples/ghc88/TH_reifyDecl1.hs +94/−0
• tests/examples/ghc88/Utils.hs +1056/−0
• tests/examples/ghc88/hie010.hs +24/−0

@@ -1,3 +1,5 @@+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

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             0.6+version:             0.6.1 synopsis:            ExactPrint for GHC description:         Using the API Annotations available from GHC 7.10.2, this                      library provides a means to round trip any code that can@@ -38,7 +38,8 @@                    , GHC == 8.4.4                    , GHC == 8.6.1                    , GHC == 8.6.2-                   , GHC == 8.6.3+                   , GHC == 8.6.4+                   , GHC == 8.6.5 extra-source-files:  ChangeLog                      src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs                      tests/examples/failing/*.hs@@ -48,6 +49,7 @@                      tests/examples/ghc82/*.hs                      tests/examples/ghc84/*.hs                      tests/examples/ghc86/*.hs+                     tests/examples/ghc88/*.hs                      tests/examples/pre-ghc86/*.hs                      tests/examples/vect/*.hs                      tests/examples/transform/*.hs@@ -92,7 +94,7 @@   -- other-modules:   -- other-extensions:   GHC-Options:         -Wall-  build-depends:       base >=4.8 && <4.13+  build-depends:       base >=4.8 && <4.14                      , bytestring >= 0.10.6                      , containers >= 0.5                      , directory >= 1.2@@ -111,19 +113,22 @@       build-depends: ghc-boot   hs-source-dirs:      src -  if impl (ghc > 8.4.4)-      hs-source-dirs: src-ghc86+  if impl (ghc > 8.6.5)+      hs-source-dirs: src-ghc88   else-    if impl (ghc > 8.2.2)-        hs-source-dirs: src-ghc84+    if impl (ghc > 8.4.4)+        hs-source-dirs: src-ghc86     else-      if impl (ghc > 8.0.3)-          hs-source-dirs: src-ghc82+      if impl (ghc > 8.2.2)+          hs-source-dirs: src-ghc84       else-        if impl (ghc > 7.10.3)-            hs-source-dirs: src-ghc80+        if impl (ghc > 8.0.3)+            hs-source-dirs: src-ghc82         else-            hs-source-dirs: src-ghc710+          if impl (ghc > 7.10.3)+              hs-source-dirs: src-ghc80+          else+              hs-source-dirs: src-ghc710    default-language:    Haskell2010   if impl (ghc < 7.10.2)@@ -137,19 +142,22 @@   else     hs-source-dirs:      tests -  if impl (ghc > 8.4.4)-      hs-source-dirs: src-ghc86+  if impl (ghc > 8.6.5)+      hs-source-dirs: src-ghc88   else-    if impl (ghc > 8.2.2)-        hs-source-dirs: src-ghc84+    if impl (ghc > 8.4.4)+        hs-source-dirs: src-ghc86     else-      if impl (ghc > 8.0.3)-          hs-source-dirs: src-ghc82+      if impl (ghc > 8.2.2)+          hs-source-dirs: src-ghc84       else-        if impl (ghc > 7.10.3)-            hs-source-dirs: src-ghc80+        if impl (ghc > 8.0.3)+            hs-source-dirs: src-ghc82         else-            hs-source-dirs: src-ghc710+          if impl (ghc > 7.10.3)+              hs-source-dirs: src-ghc80+          else+              hs-source-dirs: src-ghc710    main-is:             Test.hs   other-modules:       Test.Common@@ -161,7 +169,7 @@   if impl (ghc < 7.10.2)       buildable: False   Build-depends:       HUnit >= 1.2-                     , base < 4.13+                     , base < 4.14                      , bytestring                      , containers >= 0.5                      , Diff

@@ -0,0 +1,2938 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns      #-}+++-- | '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 qualified SrcLoc         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, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated ()+annotate = markLocated++-- instance Annotate (GHC.SrcSpanLess ast) where+--   markAST s ast = undefined+instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where+  markAST l (GHC.L _ ast) = markAST l ast++-- ---------------------------------------------------------------------++-- | Constructs a syntax tree which contains information about which+-- annotations are required by each element.+markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast,  GHC.HasSrcSpan ast)+             => 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 :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)+                         => Bool -> [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 :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)+                    => [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+      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 isSym+              then ifInContext (Set.fromList [PrefixOp,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+           doNormalRdrName+         "*"  -> 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+    setContext (Set.singleton PrefixOp) $ 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 mtybndrs termbndrs lhs rhs) = do+    markLocated ln+    setContext (Set.singleton ExplicitNeverActive) $ markActivation l act++    case mtybndrs of+      Nothing -> return ()+      Just bndrs -> do+        mark GHC.AnnForall+        mapM_ markLocated bndrs+        mark GHC.AnnDot++    mark GHC.AnnForall+    mapM_ markLocated termbndrs+    mark GHC.AnnDot++    markLocated lhs+    mark GHC.AnnEqual+    markLocated rhs+    inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi+    markTrailingSemi+{-+  = HsRule -- Source rule+       { rd_ext  :: XHsRule pass+           -- ^ After renamer, free-vars from the LHS and RHS+       , rd_name :: Located (SourceText,RuleName)+           -- ^ Note [Pragma source text] in BasicTypes+       , rd_act  :: Activation+       , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]+           -- ^ Forall'd type vars+       , rd_tmvs :: [LRuleBndr pass]+           -- ^ Forall'd term vars, before typechecking; after typechecking+           --    this includes all forall'd vars+       , rd_lhs  :: Located (HsExpr pass)+       , rd_rhs  :: Located (HsExpr pass)+       }++-}++  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+{-+newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }++type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)++type FamInstEqn pass rhs+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)+++-}+  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 GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs)+           -> Annotated ()+markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do+  markTyClassArgs bndrs fixity ln pats+  mark GHC.AnnEqual+  markLocated rhs+{-+data FamEqn pass pats rhs+  = FamEqn+       { feqn_ext    :: XCFamEqn pass pats rhs+       , feqn_tycon  :: Located (IdP pass)+       , feqn_bndrs  :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars+       , feqn_pats   :: pats+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration+       , feqn_rhs    :: rhs+       }+-}++markFamEqn (GHC.XFamEqn _) = error "got XFamEqn"++-- ---------------------------------------------------------------------++instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where++  markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs 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++    markTyClassArgs bndrs 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 unless (null cons) $ mark GHC.AnnEqual+    markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs)+    markTrailingSemi++  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+        setContext (Set.singleton PrefixOp) $ 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+    setContext (Set.singleton PrefixOp) $ 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+    inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt+    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.IsPromoted) $ 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.HsAppKindTy l t k) = do+      setContext (Set.singleton PrefixOp)  $ markLocated t+      markTypeApp l+      markLocated k++    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+      markOptional GHC.AnnOpenP  -- '('+      markLocated t+      mark GHC.AnnDcolon -- '::'+      markLocated k+      markOptional 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.IsPromoted) $ 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.HsSplicedT{} -> error "HsSplicedT 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)+          -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated 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 _ pat ty) = do+        markLocated pat+        mark GHC.AnnDcolon+        markLHsSigWcType ty++      markPat _ GHC.CoPat {} =+        traceM "warning: CoPat introduced after renaming"++      markPat _ (GHC.XPat (GHC.L l p)) = markPat l p+      -- 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+    markListWithLayout 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.AnnSemi+        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 _ e typ) = 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 _ e ty) = 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+{-+    SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renameer, FVs+            , tcdLName  :: Located (IdP pass)     -- ^ Type constructor+            , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an+                                                  -- associated type these+                                                  -- include outer binders+            , tcdFixity :: LexicalFixity    -- ^ Fixity used in the declaration+            , tcdRhs    :: LHsType pass }         -- ^ RHS of type declaration++-}+  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 Nothing 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 Nothing 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 Nothing 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"++-- ---------------------------------------------------------------------++markTypeApp :: GHC.SrcSpan -> Annotated ()+markTypeApp loc = do+  let l = GHC.srcSpanFirstCharacter loc+  markExternal l GHC.AnnVal "@"++-- ---------------------------------------------------------------------++markTyClassArgs :: (Annotate a, GHC.HasOccName a)+            => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity+            -- -> GHC.Located a -> [ast] -> Annotated ()+            -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated ()+markTyClassArgs mbndrs fixity ln tyVars = do+  let+    cvt (GHC.HsValArg  val) = markLocated val+    cvt (GHC.HsTypeArg loc typ) = do+      markTypeApp loc+      -- let l = GHC.srcSpanFirstCharacter loc+      -- markExternal l GHC.AnnVal "@"+      markLocated typ+    cvt (GHC.HsArgPar _ss) = undefined+  markTyClassWorker cvt mbndrs fixity ln tyVars+    {-+type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)++data HsArg tm ty+  = HsValArg tm   -- Argument is an ordinary expression     (f arg)+  | HsTypeArg  ty -- Argument is a visible type application (f @ty)+  | HsArgPar SrcSpan -- See Note [HsArgPar]+-}++-- TODO:AZ: simplify+markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, GHC.HasOccName a, Annotate ast,GHC.HasSrcSpan ast)+            => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity+            -> GHC.Located a -> [ast] -> Annotated ()+markTyClass = markTyClassWorker markLocated++markTyClassWorker :: (Annotate a, GHC.HasOccName a)+            => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity+            -- -> GHC.Located a -> [ast] -> Annotated ()+            -> GHC.Located a -> [b] -> Annotated ()+markTyClassWorker markFn mbndrs fixity ln tyVars = do+    let processBinders =+          case mbndrs of+            Nothing -> return ()+            Just bndrs -> do+              mark GHC.AnnForall+              mapM_ markLocated bndrs+              mark GHC.AnnDot++    -- 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+        processBinders+        setContext (Set.singleton PrefixOp) $ markLocated ln+        -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars+        setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars+        when (length tyVars >= 2) $ do+          markParens GHC.AnnCloseP+          setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars+        markManyOptional GHC.AnnCloseP+      else do+        case tyVars of+          (x:y:xs) -> do+            markParens GHC.AnnOpenP+            processBinders+            markFn x+            setContext (Set.singleton InfixOp) $ markLocated ln+            markFn y+            markParens GHC.AnnCloseP+            mapM_ markFn 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 Nothing 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+{-+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)++type FamInstEqn pass rhs+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)++type HsTyPats pass = [LHsTypeArg pass]++-}+  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 mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do+    mark GHC.AnnType+    mark GHC.AnnInstance+    markTyClass mbndrs fixity ln bndrs+    mark GHC.AnnEqual+    markLocated typ+{-+type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)++data LHsQTyVars pass   -- See Note [HsType binders]+  = HsQTvs { hsq_ext :: XHsQTvs pass++           , hsq_explicit :: [LHsTyVarBndr pass]+                -- Explicit variables, written by the user+                -- See Note [HsForAllTy tyvar binders]+    }+++data FamEqn pass pats rhs+  = FamEqn+       { feqn_ext    :: XCFamEqn pass pats rhs+       , feqn_tycon  :: Located (IdP pass)+       , feqn_bndrs  :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars+       , feqn_pats   :: pats+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration+       , feqn_rhs    :: rhs+       }+-}++  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

@@ -10,6 +10,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook+{-# LANGUAGE ViewPatterns      #-}+ -- | '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.@@ -116,8 +118,13 @@   MarkManyOptional :: GHC.AnnKeywordId                                     -> next -> AnnotationF next   MarkOffsetPrim   :: GHC.AnnKeywordId -> Int -> Maybe String              -> next -> AnnotationF next   MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String        -> next -> AnnotationF next+#if __GLASGOW_HASKELL__ > 806+  WithAST         :: (Data a,Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) =>+                           a -> Annotated b                                -> next -> AnnotationF next+#else   WithAST          :: Data a => GHC.Located a                              -> Annotated b                                -> next -> AnnotationF next+#endif   CountAnns        :: GHC.AnnKeywordId                        -> (Int     -> next) -> AnnotationF next   WithSortKey      :: [(GHC.SrcSpan, Annotated ())]                        -> next -> AnnotationF next @@ -211,7 +218,12 @@ -- ---------------------------------------------------------------------  -- |Main driver point for annotations.+#if __GLASGOW_HASKELL__ > 806+withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)+        => a -> Annotated () -> Annotated ()+#else withAST :: Data a => GHC.Located a -> Annotated () -> Annotated ()+#endif withAST lss action = liftF (WithAST lss action ())  -- ---------------------------------------------------------------------@@ -243,12 +255,21 @@  -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 806+withLocated :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)+            => a+            -> (GHC.SrcSpan -> a -> Annotated ())+            -> Annotated ()+withLocated a@(GHC.dL->GHC.L l _) action =+  withAST a (action l a)+#else withLocated :: Data a             => GHC.Located a             -> (GHC.SrcSpan -> a -> Annotated ())             -> Annotated ()-withLocated a@(GHC.L l ast) action =-  withAST a (action l ast)+withLocated a@(GHC.L l t) action =+  withAST a (action l t)+#endif  -- --------------------------------------------------------------------- 

@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+ -- |  This module converts 'GHC.ApiAnns' into 'Anns' by traversing a -- structure created by the "Annotate" module. --@@ -151,8 +154,13 @@ -- --------------------------------------------------------------------- -- | Transform concrete annotations into relative annotations which are -- more useful when transforming an AST.+#if __GLASGOW_HASKELL__ > 806+relativiseApiAnns :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)+                  => ast+#else relativiseApiAnns :: Annotate ast                   => GHC.Located ast+#endif                   -> GHC.ApiAnns                   -> Anns relativiseApiAnns = relativiseApiAnnsWithComments []@@ -162,19 +170,32 @@ -- 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 ::+#if __GLASGOW_HASKELL__ > 806+                     (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)+                  => [Comment]+                  -> ast+#else                      Annotate ast                   => [Comment]                   -> GHC.Located ast+#endif                   -> GHC.ApiAnns                   -> Anns relativiseApiAnnsWithComments =     relativiseApiAnnsWithOptions normalLayout  relativiseApiAnnsWithOptions ::+#if __GLASGOW_HASKELL__ > 806+                     (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)+                  => DeltaOptions+                  -> [Comment]+                  -> ast+#else                      Annotate ast                   => DeltaOptions                   -> [Comment]                   -> GHC.Located ast+#endif                   -> GHC.ApiAnns                   -> Anns relativiseApiAnnsWithOptions opts cs modu ghcAnns@@ -427,8 +448,13 @@ getSrcSpan :: Delta GHC.SrcSpan getSrcSpan = asks curSrcSpan +#if __GLASGOW_HASKELL__ > 806+withSrcSpanDelta :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b+withSrcSpanDelta (GHC.dL->GHC.L l a) =+#else withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b withSrcSpanDelta (GHC.L l a) =+#endif   local (\s -> s { curSrcSpan = l                  , annConName = annGetConstr a                  , drContext = pushAcs (drContext s)@@ -561,10 +587,17 @@ -- -------------------------------------  -- | Enter a new AST element. Maintain SrcSpan stack+#if __GLASGOW_HASKELL__ > 806+withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)+        => a+        -> Delta b -> Delta b+withAST lss@(GHC.dL->GHC.L ss _) action = do+#else withAST :: Data a         => GHC.Located a         -> Delta b -> Delta b withAST lss@(GHC.L ss _) action = do+#endif   -- Calculate offset required to get to the start of the SrcSPan   off <- gets apLayoutStart   (resetAnns .  withSrcSpanDelta lss) (do@@ -827,7 +860,7 @@ addEofAnnotation :: Delta () addEofAnnotation = do   pe <- getPriorEnd-  (ma,_kw) <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)+  (ma,_kw) <- withSrcSpanDelta (GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) (getAnnotationDelta GHC.AnnEofPos)   case ma of     [] -> return ()     (pa:pss) -> do

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -49,6 +50,9 @@ import Language.Haskell.GHC.ExactPrint.Types  import Control.Monad.RWS+#if __GLASGOW_HASKELL__ > 806+import Data.Data (Data)+#endif  import GHC.Paths (libdir) @@ -79,12 +83,21 @@  -- | Wrapper function which returns Annotations along with the parsed -- element.+#if __GLASGOW_HASKELL__ > 806+parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w)+          => GHC.DynFlags+          -> FilePath+          -> GHC.P w+          -> String+          -> Either (GHC.SrcSpan, String) (Anns, w)+#else parseWith :: Annotate w           => GHC.DynFlags           -> FilePath           -> GHC.P (GHC.Located w)           -> String           -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)+#endif parseWith dflags fileName parser s =   case runParser parser dflags fileName s of #if __GLASGOW_HASKELL__ >= 804

@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -226,6 +228,7 @@            (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.AnnDotdot)       -> 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))@@ -238,6 +241,7 @@            (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.AnnLet)          -> 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))@@ -309,8 +313,13 @@  -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 806+withSrcSpanPretty :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b+withSrcSpanPretty (GHC.dL->GHC.L l a) action = do+#else withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b withSrcSpanPretty (GHC.L l a) action = do+#endif   -- 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 ())@@ -327,10 +336,17 @@ -- ---------------------------------------------------------------------  -- | Enter a new AST element. Maintain SrcSpan stack+#if __GLASGOW_HASKELL__ > 806+withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)+        => a+        -> Pretty b -> Pretty b+withAST lss@(GHC.dL->GHC.L ss t) action = do+#else withAST :: Data a         => GHC.Located a         -> Pretty b -> Pretty b withAST lss@(GHC.L ss t) action = do+#endif   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

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}@@ -73,7 +74,11 @@ data PrintOptions m a = PrintOptions             {               epAnn :: !Annotation+#if __GLASGOW_HASKELL__ > 806+            , epAstPrint :: forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a+#else             , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a+#endif             , epTokenPrint :: String -> m a             , epWhitespacePrint :: String -> m a             , epRigidity :: Rigidity@@ -82,7 +87,11 @@  -- | Helper to create a 'PrintOptions' printOptions ::+#if __GLASGOW_HASKELL__ > 806+      (forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a)+#else       (forall ast . Data ast => GHC.Located ast -> a -> m a)+#endif       -> (String -> m a)       -> (String -> m a)       -> Rigidity@@ -150,7 +159,8 @@  -- --------------------------------------------------------------------- -printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a+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@@ -278,7 +288,14 @@  ------------------------------------------------------------------------- -- |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 :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w)+#if __GLASGOW_HASKELL__ > 806+exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w)+        => ast -> EP w m a -> EP w m a+#else exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a+#endif exactPC ast action =     do       return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))@@ -311,7 +328,12 @@   colOffset <- getLayoutOffset   printWhitespace (undelta p cl colOffset) +#if __GLASGOW_HASKELL__ > 806+getAndRemoveAnnotation :: (Monad m, Monoid w, Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)+                       => a -> EP w m (Maybe Annotation)+#else getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation)+#endif getAndRemoveAnnotation a = gets (getAnnotationEP a . epAnns)  markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()

@@ -301,7 +301,12 @@  -- |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 :: (Constraints a,Monad m)+#if __GLASGOW_HASKELL__ >= 808+              => a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()+#else+              => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()+#endif addSimpleAnnT ast dp kds = do   let ann = annNone { annEntryDelta = dp                     , annsDP = kds@@ -325,7 +330,11 @@ -- ---------------------------------------------------------------------  -- |'Transform' monad version of 'getEntryDP'+#if __GLASGOW_HASKELL__ >= 808+getEntryDPT :: (Constraints a,Monad m) => a -> TransformT m DeltaPos+#else getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos+#endif getEntryDPT ast = do   anns <- getAnnsT   return (getEntryDP anns ast)@@ -333,7 +342,11 @@ -- ---------------------------------------------------------------------  -- |'Transform' monad version of 'getEntryDP'+#if __GLASGOW_HASKELL__ >= 808+setEntryDPT :: (Constraints a,Monad m) => a -> DeltaPos -> TransformT m ()+#else setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m ()+#endif setEntryDPT ast dp = do   modifyAnnsT (setEntryDP ast dp) @@ -387,7 +400,11 @@  -- |Return the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments.+#if __GLASGOW_HASKELL__ >= 808+getEntryDP :: (Constraints a) => Anns -> a -> DeltaPos+#else getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos+#endif getEntryDP anns ast =   case Map.lookup (mkAnnKey ast) anns of     Nothing  -> DP (0,0)@@ -397,7 +414,11 @@  -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments.+#if __GLASGOW_HASKELL__ >= 808+setEntryDP :: (Constraints a) => a -> DeltaPos -> Anns -> Anns+#else setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns+#endif setEntryDP ast dp anns =   case Map.lookup (mkAnnKey ast) anns of     Nothing  -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-} module Language.Haskell.GHC.ExactPrint.Types   ( -- * Core Types    Anns@@ -33,6 +35,9 @@   , ACS'(..)   , ListContexts(..) +  -- * For managing compatibility+  , Constraints+   -- * GHC version compatibility   , GhcPs   , GhcRn@@ -45,6 +50,7 @@   ) where  import Data.Data (Data, Typeable, toConstr,cast)+-- import Data.Generics  import qualified DynFlags      as GHC import qualified GHC@@ -55,6 +61,14 @@  -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 808+type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)+#else+type Constraints a = (Data a)+#endif++-- ---------------------------------------------------------------------+ -- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted -- from an @AnnKeywordId@ because the annotation must be interleaved into the -- stream and does not have a well-defined position@@ -156,9 +170,15 @@ instance Show AnnKey where   show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn ++#if __GLASGOW_HASKELL__ > 806+mkAnnKeyPrim :: (Constraints a)+             => a -> AnnKey+mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a)+#else mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a)-+#endif  #if __GLASGOW_HASKELL__ <= 802 type GhcPs = GHC.RdrName@@ -171,7 +191,11 @@ #endif  -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.+#if __GLASGOW_HASKELL__ > 806+mkAnnKey :: (Constraints a) => a -> AnnKey+#else mkAnnKey :: (Data a) => GHC.Located a -> AnnKey+#endif mkAnnKey ld =   case cast ld :: Maybe (GHC.LHsDecl GhcPs) of     Just d -> declFun mkAnnKeyPrim d@@ -330,6 +354,8 @@                 | InClassDecl                 | InSpliceDecl                 | LeftMost -- Is this the leftmost operator in a chain of OpApps?+                | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt+                          -- TODO:AZ: do we actually need this?                  -- Next four used to identify current list context                 | CtxOnly

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -325,7 +326,12 @@   -- cm has type :: Map SrcSpan [Located AnnotationComment]   = map tokComment . GHC.sortLocated . concat $ Map.elems cm +#if __GLASGOW_HASKELL__ > 806+getAnnotationEP :: (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)+                => a -> Anns -> Maybe Annotation+#else getAnnotationEP :: (Data a) =>  GHC.Located a  -> Anns -> Maybe Annotation+#endif getAnnotationEP  la as =   Map.lookup (mkAnnKey la) as 

@@ -28,12 +28,14 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86+data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88      deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion ghcVersion =-#if __GLASGOW_HASKELL__ > 804+#if __GLASGOW_HASKELL__ > 806+  GHC88+#elif __GLASGOW_HASKELL__ > 804   GHC86 #elif __GLASGOW_HASKELL__ > 802   GHC84@@ -54,10 +56,10 @@     GHC82  -> ["pre-ghc86",  "ghc710", "ghc80", "ghc82", "vect"]     GHC84  -> ["pre-ghc86",  "ghc710", "ghc80", "ghc82", "ghc84", "vect" ]     GHC86  -> [              "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ]+    GHC88  -> [              "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ] -    -- GHC86  -> [             "ghc710", "ghc80", "ghc82", "ghc84"]-    -- GHC86  -> ["ghc86-copied"]-    -- GHC86  -> ["ghc86"]+    -- GHC88  -> ["ghc88"]+    -- GHC88  -> ["ghc88-copied"]  -- --------------------------------------------------------------------- @@ -198,11 +200,38 @@ tt' = runTestText (putTextToHandle stdout True) $ TestList [  -      -- mkPrettyRoundtrip "ghc82" "TensorTests.hs"+      -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"+      -- mkPrettyRoundtrip "ghc86" "mdo.hs" -      mkParserTest      "ghc710" "GADTContext.hs"+      -- mkParserTest      "ghc88" "DumpParsedast.hs"+      -- mkParserTest      "ghc88-copied" "T15365.hs"+      -- mkPrettyRoundtrip  "ghc88-copied" "T15365.hs"+      -- mkParserTest      "ghc88-copied" "T4437.hs" +      -- mkParserTest      "ghc88-copied" "TH_recover_warns.hs"+      -- mkPrettyRoundtrip  "ghc88-copied" "TH_recover_warns.hs"++      -- mkParserTest      "ghc88-copied" "TH_recursiveDoImport.hs"+      -- mkPrettyRoundtrip  "ghc88-copied" "TH_recursiveDoImport.hs"++      -- mkParserTest      "ghc88-copied" "dsrun010.hs"+      -- mkPrettyRoundtrip  "ghc88-copied" "dsrun010.hs"++        -- mkParserTest      "ghc88" "Internal.hs"+        -- mkParserTest      "ghc88" "Main.hs"+        mkParserTest      "ghc88" "PersistUniqueTest.hs"++      -- ---------------------------------------------------------------+      -- mkParserTest "ghc710" "Roles.hs"+      -- ---------------------------------------------------------------++++       -- mkParserTest      "ghc86" "deriving-via-compile.hs"+      -- mkParserTest      "ghc88" "ClassParens.hs"++     --   mkParserTest "pre-ghc86" "TensorTests.hs"     -- , mkParserTest "pre-ghc86" "Webhook.hs"     -- , mkParserTest "ghc710" "RdrNames.hs"

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} module Test.Transform where  import Language.Haskell.GHC.ExactPrint@@ -329,18 +330,43 @@ #endif     replaceHsVar x = x -#if __GLASGOW_HASKELL__ > 802+++#if __GLASGOW_HASKELL__ > 806     replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs-#endif+    replacePat (GHC.dL->GHC.L ln (GHC.VarPat {}))+        | cond ln = GHC.cL ln (GHC.VarPat GHC.noExt (GHC.cL ln newName))+#elif __GLASGOW_HASKELL__ > 804+    replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs     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.noExt (GHC.L ln newName))+#elif __GLASGOW_HASKELL__ > 802+    replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs+    replacePat (GHC.L ln (GHC.VarPat {}))         | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName))+#elif __GLASGOW_HASKELL__ >= 800+    replacePat (GHC.L ln (GHC.VarPat {}))+        | 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))+    replacePat (GHC.L ln (GHC.VarPat {}))+        | cond ln = GHC.L ln (GHC.VarPat newName) #endif     replacePat 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   

@@ -0,0 +1,25 @@+-- Check that pattern match failure in do-notation+-- is reflected by calling the monadic 'fail', not by a+-- runtime exception++{-# LANGUAGE NoMonadFailDesugaring #-}+{-# OPTIONS -Wno-missing-monadfail-instances #-}++import Control.Monad+import Data.Maybe++test :: (MonadPlus m) => [a] -> m Bool+test xs+  =   do+        (_:_) <- return xs+                -- Should fail here+        return True+    `mplus`+        -- Failure in LH arg should trigger RH arg+      do+        return False++main :: IO ()+main+  = do  let x = fromJust (test [])+        putStrLn (show x)

@@ -0,0 +1,11 @@+module ClassParens where++class LiftingMonad  (trans :: MTrans) where+  proof :: Monad m :- Monad (trans m)++class LiftingMonad2  ((trans :: MTrans)) where+  proof :: Monad m :- Monad (trans m)++data Nat (t :: NatKind) where+    ZeroNat :: Nat Zero+    SuccNat :: Nat t -> Nat (Succ t)

@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies+             , TypeApplications, TypeInType #-}++module DumpParsedAst where+import Data.Kind++data Peano = Zero | Succ Peano++type family Length (as :: [k]) :: Peano where+  Length (a : as) = Succ (Length as)+  Length '[]      = Zero++-- vis kind app+data T f (a :: k) = MkT (f a)++type family F1 (a :: k) (f :: k -> Type) :: Type where+  F1 @Peano a f = T @Peano f a++main = putStrLn "hello"+

@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-}++-- Check interaction between Newtypes and DataFamilies+module EmptyCase008 where++import Data.Kind (Type)++data family DA a++newtype Foo3 a = Foo3 (DA a)++data instance DA Int = MkDA1 Char | MkDA2++-- Non-exhaustive. Missing: MkDA1 Char, MkDA2+f11 :: Foo3 Int -> ()+f11 = \case++-- Non-exhaustive. (no info about a)+f12 :: Foo3 a -> ()+f12 = \case++data instance DA () -- Empty data type++-- Exhaustive.+f13 :: Foo3 () -> ()+f13 = \case++-- ----------------+data family DB a :: Type -> Type++data instance DB Int a where+  MkDB1 :: DB Int ()+  MkDB2 :: DB Int Bool++newtype Foo4 a b = Foo4 (DB a b)++-- Non-exhaustive. Missing: Foo4 MkDB1+f14 :: Foo4 Int () -> ()+f14 = \case++-- Exhaustive+f15 :: Foo4 Int [a] -> ()+f15 = \case++-- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b)+f16 :: Foo4 a b -> ()+f16 = \case++data instance DB Char Bool -- Empty data type++-- Exhaustive (empty data type)+f17 :: Foo4 Char Bool -> ()+f17 = \case+

@@ -0,0 +1,203 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.Array.Accelerate.Utility.Lift.Exp (+   Unlift,+   Unlifted,+   Tuple,+   unlift,+   modify,+   modify2,+   modify3,+   modify4,+   Exp(Exp), expr, atom,+   unliftPair,+   unliftTriple,+   unliftQuadruple,+   asExp,+   mapFst,+   mapSnd,+   fst3,+   snd3,+   thd3,+   indexCons,+   ) where++import qualified Data.Array.Accelerate.Data.Complex as Complex+import qualified Data.Array.Accelerate as A+import Data.Complex (Complex((:+)))+import Data.Array.Accelerate ((:.)((:.)))++import qualified Data.Tuple.HT as Tuple+import Data.Tuple.HT (mapTriple)+++{- |+This class simplifies untupling of expressions.+If you have a function++> g :: ((Exp a, Exp b), Exp (c,d)) -> (Exp e, Exp f)++you cannot apply it to an array @arr :: Array sh ((a,b),(c,d))@ using 'A.map'.+Here, the 'modify' function helps:++> modify ((expr,expr),expr) g :: Exp ((a,b),(c,d)) -> Exp (e,f)++The 'expr'-pattern tells, how deep the tuple shall be unlifted.+This way you can write:++> A.map+>    (Exp.modify ((expr,expr),expr) $ \((a,b), cd) -> g ((a,b), cd))+>    arr++'modify' is based on 'unlift'.+In contrast to 'A.unlift' it does not only unlift one level of tupels,+but is guided by an 'expr'-pattern.+In the example I have demonstrated,+how the pair @(a,b)@ is unlifted, but the pair @(c,d)@ is not.+For the result tuple, 'modify' simply calls 'A.lift'.+In contrast to 'A.unlift',+'A.lift' lifts over all tupel levels until it obtains a single 'Exp'.+-}+class+   (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) =>+      Unlift pattern where+   type Unlifted pattern+   type Tuple pattern+   unlift :: pattern -> A.Exp (Tuple pattern) -> Unlifted pattern++modify ::+   (A.Lift A.Exp a, Unlift pattern) =>+   pattern ->+   (Unlifted pattern -> a) ->+   A.Exp (Tuple pattern) -> A.Exp (A.Plain a)+modify p f = A.lift . f . unlift p++modify2 ::+   (A.Lift A.Exp a, Unlift patternA, Unlift patternB) =>+   patternA ->+   patternB ->+   (Unlifted patternA -> Unlifted patternB -> a) ->+   A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (A.Plain a)+modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b)++modify3 ::+   (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC) =>+   patternA ->+   patternB ->+   patternC ->+   (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) ->+   A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) ->+   A.Exp (Tuple patternC) -> A.Exp (A.Plain a)+modify3 pa pb pc f a b c =+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c)++modify4 ::+   (A.Lift A.Exp a,+    Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) =>+   patternA ->+   patternB ->+   patternC ->+   patternD ->+   (Unlifted patternA -> Unlifted patternB ->+    Unlifted patternC -> Unlifted patternD -> a) ->+   A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) ->+   A.Exp (Tuple patternC) -> A.Exp (Tuple patternD) -> A.Exp (A.Plain a)+modify4 pa pb pc pd f a b c d =+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d)+++instance (A.Elt a) => Unlift (Exp a) where+   type Unlifted (Exp a) = A.Exp a+   type Tuple (Exp a) = a+   unlift _ = id++data Exp e = Exp++expr :: Exp e+expr = Exp++{-# DEPRECATED atom "use expr instead" #-}+-- | for compatibility with accelerate-utility-0.0+atom :: Exp e+atom = expr+++instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where+   type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb)+   type Tuple (pa,pb) = (Tuple pa, Tuple pb)+   unlift (pa,pb) ab =+      (unlift pa $ A.fst ab, unlift pb $ A.snd ab)++instance+   (Unlift pa, Unlift pb, Unlift pc) =>+      Unlift (pa,pb,pc) where+   type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc)+   type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc)+   unlift (pa,pb,pc) =+      mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift+++instance (Unlift pa, A.Slice (Tuple pa), int ~ Exp Int) => Unlift (pa :. int) where+   type Unlifted (pa :. int) = Unlifted pa :. A.Exp Int+   type Tuple (pa :. int) = Tuple pa :. Int+   unlift (pa:.pb) ab =+      (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab)+++instance (Unlift p) => Unlift (Complex p) where+   type Unlifted (Complex p) = Complex (Unlifted p)+   type Tuple (Complex p) = Complex (Tuple p)+   unlift (preal:+pimag) z =+      unlift preal (Complex.real z)+      :++      unlift pimag (Complex.imag z)+++unliftPair :: (A.Elt a, A.Elt b) => A.Exp (a,b) -> (A.Exp a, A.Exp b)+unliftPair = A.unlift++unliftTriple ::+   (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> (A.Exp a, A.Exp b, A.Exp c)+unliftTriple = A.unlift++unliftQuadruple ::+   (A.Elt a, A.Elt b, A.Elt c, A.Elt d) =>+   A.Exp (a,b,c,d) -> (A.Exp a, A.Exp b, A.Exp c, A.Exp d)+unliftQuadruple = A.unlift++asExp :: A.Exp a -> A.Exp a+asExp = id++mapFst ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   (A.Exp a -> A.Exp b) -> A.Exp (a,c) -> A.Exp (b,c)+mapFst f = modify (expr,expr) $ \(a,c) -> (f a, c)++mapSnd ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   (A.Exp b -> A.Exp c) -> A.Exp (a,b) -> A.Exp (a,c)+mapSnd f = modify (expr,expr) $ \(a,b) -> (a, f b)+++fst3 ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   A.Exp (a,b,c) -> A.Exp a+fst3 = modify (expr,expr,expr) Tuple.fst3++snd3 ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   A.Exp (a,b,c) -> A.Exp b+snd3 = modify (expr,expr,expr) Tuple.snd3++thd3 ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   A.Exp (a,b,c) -> A.Exp c+thd3 = modify (expr,expr,expr) Tuple.thd3++++indexCons ::+   (A.Slice ix) => A.Exp ix -> A.Exp Int -> A.Exp (ix :. Int)+indexCons ix n = A.lift $ ix:.n+

@@ -0,0 +1,46 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeApplications #-}++module ExplicitForAllRules1 where++import Data.Proxy+import Data.Kind++-- From Proposal 0007 (w/ fix to "example")++{-# RULES+"example"  forall a b. forall. map @a @b f = f+"example2" forall a. forall (x :: a). id x = x+  #-}++{-# NOINLINE f #-}+f :: a -> b+f = undefined++-- More tests++{-# RULES+"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = ()+"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @()+"example5" forall (a :: Type). forall. h @a = id @a+"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x+  #-}++{-# NOINLINE g #-}+g :: a -> b -> ()+g _ _ = ()++{-# NOINLINE h #-}+h :: a -> a+h x = x++-- Should NOT have a parse error :(+{-# RULES "example6" forall a forall. g a forall = () #-}++-- Should generate a warning+{-# RULES "example7" forall a b. forall (x :: a). id x = x #-}+

@@ -0,0 +1,342 @@+{-# language GADTs, RankNTypes #-}+{-# language FlexibleContexts, DefaultSignatures #-}+{-# language TypeOperators #-}+{-# language LambdaCase #-}+{-# language EmptyCase #-}+module Hedgehog.Function.Internal where++import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Bifunctor (first)+import Data.Functor.Contravariant (Contravariant(..))+import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..))+import Data.Functor.Identity (Identity(..))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Maybe (fromJust)+import Data.Void (Void, absurd)+import Data.Word (Word8, Word64)+import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT)+import Hedgehog.Internal.Seed (Seed(..))+import Hedgehog.Internal.Tree (Tree(..), Node(..))+import Hedgehog.Internal.Property (PropertyT, forAll)++import GHC.Generics++import qualified Hedgehog.Internal.Tree as Tree++infixr 5 :->++-- | Shrinkable, showable functions+--+-- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl).+-- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM.+data a :-> c where+  Unit :: c -> () :-> c+  Nil :: a :-> c+  Pair :: a :-> b :-> c -> (a, b) :-> c+  Sum :: a :-> c -> b :-> c -> Either a b :-> c+  Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c++instance Functor ((:->) r) where+  fmap f (Unit c) = Unit $ f c+  fmap _ Nil = Nil+  fmap f (Pair a) = Pair $ fmap (fmap f) a+  fmap f (Sum a b) = Sum (fmap f a) (fmap f b)+  fmap f (Map a b c) = Map a b (fmap f c)++-- | Tabulate the function+table :: a :-> c -> [(a, c)]+table (Unit c) = [((), c)]+table Nil = []+table (Pair f) = do+  (a, bc) <- table f+  (b, c) <- table bc+  pure ((a, b), c)+table (Sum a b) =+  [(Left x, c) | (x, c) <- table a] +++  [(Right x, c) | (x, c) <- table b]+table (Map _ g a) = first g <$> table a++class GArg a where+  gbuild' :: (a x -> c) -> a x :-> c++-- | Reify a function whose domain has an instance of 'Generic'+gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c+gbuild = gvia from to++-- | @instance Arg A where@ allows functions which take @A@s to be reified+class Arg a where+  build :: (a -> c) -> a :-> c+  default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c+  build = gbuild++variant :: Word64 -> GenT m b -> GenT m b+variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n})++variant' :: Word64 -> CoGenT m b -> CoGenT m b+variant' n (CoGenT f) =+  CoGenT $ \a -> variant n . f a++class GVary a where+  gvary' :: CoGenT m (a x)++instance GVary V1 where+  gvary' = conquer++instance GVary U1 where+  gvary' = conquer++instance (GVary a, GVary b) => GVary (a :+: b) where+  gvary' =+    choose+      (\case; L1 a -> Left a; R1 a -> Right a)+      (variant' 0 gvary')+      (variant' 1 gvary')++instance (GVary a, GVary b) => GVary (a :*: b) where+  gvary' =+    divide+      (\(a :*: b) -> (a, b))+      (variant' 0 gvary')+      (variant' 1 gvary')++instance GVary c => GVary (M1 a b c) where+  gvary' = contramap unM1 gvary'++instance Vary b => GVary (K1 a b) where+  gvary' = contramap unK1 vary++-- | Build a co-generator for a type which has a 'Generic' instance+gvary :: (Generic a, GVary (Rep a)) => CoGenT m a+gvary = CoGenT $ \a -> applyCoGenT gvary' (from a)++-- | 'Vary' provides a canonical co-generator for a type.+--+-- While technically there are many possible co-generators for a given type, we don't get any+-- benefit from caring.+class Vary a where+  vary :: CoGenT m a+  default vary :: (Generic a, GVary (Rep a)) => CoGenT m a+  vary = gvary++-- | Build a co-generator for an 'Integral' type+varyIntegral :: Integral a => CoGenT m a+varyIntegral = CoGenT $ variant . fromIntegral++-- |+-- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way,+-- the generated function will have a varying (but still deterministic) right hand side.+--+-- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to+-- derive 'Generic' and use the default instance of the 'Vary' type class.+--+-- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@+newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b }+type CoGen = CoGenT Identity++instance Contravariant (CoGenT m) where+  contramap f (CoGenT g) = CoGenT (g . f)++instance Divisible (CoGenT m) where+  divide f (CoGenT gb) (CoGenT gc) =+    CoGenT $ \a ->+    let (b, c) = f a in gc c . gb b+  conquer = CoGenT $ const id++instance Decidable (CoGenT m) where+  choose f (CoGenT gb) (CoGenT gc) =+    CoGenT $ \a ->+    case f a of+      Left b -> gb b . variant 0+      Right c -> gc c . variant 1+  lose f = CoGenT $ \a -> absurd (f a)++instance (Show a, Show b) => Show (a :-> b) where+  show = show . table++-- | Evaluate a possibly partial function+apply' :: a :-> b -> a -> Maybe b+apply' (Unit c) () = Just c+apply' Nil _ = Nothing+apply' (Pair f) (a, b) = do+  f' <- apply' f a+  apply' f' b+apply' (Sum f _) (Left a) = apply' f a+apply' (Sum _ g) (Right a) = apply' g a+apply' (Map f _ g) a = apply' g (f a)++-- | Evaluate a total function. Unsafe.+unsafeApply :: a :-> b -> a -> b+unsafeApply f = fromJust . apply' f++-- | The type of randomly-generated functions+data Fn a b = Fn b (a :-> Tree (MaybeT Identity) b)++-- | Extract the root value from a 'Tree'. Unsafe.+unsafeFromTree :: Functor m => Tree (MaybeT m) a -> m a+unsafeFromTree =+  fmap (maybe (error "empty generator in function") nodeValue) .+  runMaybeT .+  runTree++instance (Show a, Show b) => Show (Fn a b) where+  show (Fn b a) =+    case table a of+      [] -> "_ -> " ++ show b+      ta -> showTable ta ++ "_ -> " ++ show b+    where+      showTable :: (Show a, Show b) => [(a, Tree (MaybeT Identity) b)] -> String+      showTable [] = "<empty function>\n"+      showTable (x : xs) = unlines (showCase <$> x : xs)+        where+          showCase (lhs, rhs) = show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs)++-- | Shrink the function+shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b]+shrinkFn shr (Unit a) = Unit <$> shr a+shrinkFn _ Nil = []+shrinkFn shr (Pair f) =+  (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f+shrinkFn shr (Sum a b) =+  fmap (\case; Sum Nil Nil -> Nil; x -> x) $+  [ Sum a Nil | notNil b ] +++  [ Sum Nil b | notNil a ] +++  fmap (`Sum` b) (shrinkFn shr a) +++  fmap (a `Sum`) (shrinkFn shr b)+  where+    notNil Nil = False+    notNil _ = True+shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a++shrinkTree :: Monad m => Tree (MaybeT m) a -> m [Tree (MaybeT m) a]+shrinkTree (Tree m) = do+  a <- runMaybeT m+  case a of+    Nothing -> pure []+    Just (Node _ cs) -> pure cs++-- | Evaluate an 'Fn'+apply :: Fn a b -> a -> b+apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f++-- | Generate a function using the user-supplied co-generator+fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b)+fnWith cg gb =+  Fn <$>+  gb <*>+  genFn (\a -> applyCoGenT cg a gb)+  where+    genFn :: Arg a => (a -> Gen b) -> Gen (a :-> Tree (MaybeT Identity) b)+    genFn g =+      GenT $ \sz sd ->+      Tree.unfold (shrinkFn $ runIdentity . shrinkTree) .+      fmap (runGenT sz sd) $ build g++-- | Generate a function+fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b)+fn = fnWith vary++-- | Run the function generator to retrieve a function+forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b)+forAllFn = fmap apply . forAll++instance Vary ()+instance (Vary a, Vary b) => Vary (Either a b)+instance (Vary a, Vary b) => Vary (a, b)+instance Vary Void+instance Vary Bool+instance Vary Ordering+instance Vary a => Vary (Maybe a)+instance Vary a => Vary [a]+instance Vary Int8 where; vary = varyIntegral+instance Vary Int16 where; vary = varyIntegral+instance Vary Int32 where; vary = varyIntegral+instance Vary Int64 where; vary = varyIntegral+instance Vary Int where; vary = varyIntegral+instance Vary Integer where; vary = varyIntegral+instance Vary Word8 where; vary = varyIntegral++-- | Reify a function via an isomorphism.+--+-- If your function's domain has no instance of 'Generic' then you can still reify it using+-- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral'+-- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element+-- is the sign, and the second element is the bit-string.+--+-- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@+via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c+via a b f = Map a b . build $ f . b++instance Arg Void where+  build _ = Nil++instance Arg () where+  build f = Unit $ f ()++instance (Arg a, Arg b) => Arg (a, b) where+  build f = Pair . build $ \a -> build $ \b -> f (a, b)++instance (Arg a, Arg b) => Arg (Either a b) where+  build f = Sum (build $ f . Left) (build $ f . Right)++gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c+gvia a b f = Map a b . gbuild' $ f . b++instance GArg V1 where+  gbuild' _ = Nil++instance GArg U1 where+  gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1)++instance (GArg a, GArg b) => GArg (a :*: b) where+  gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b)+    where+      fromPair (a :*: b) = (a, b)+      toPair (a, b) = (a :*: b)++instance (GArg a, GArg b) => GArg (a :+: b) where+  gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1)+    where+      fromSum = \case; L1 a -> Left a; R1 a -> Right a+      toSum = either L1 R1++instance GArg c => GArg (M1 a b c) where+  gbuild' = gvia unM1 M1++instance Arg b => GArg (K1 a b) where+  gbuild' f = Map unK1 K1 . build $ f . K1++-- | Reify a function on 'Integral's+buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c)+buildIntegral = via toBits fromBits+  where+    toBits :: Integral a => a -> (Bool, [Bool])+    toBits n+      | n >= 0 = (True, go n)+      | otherwise = (False, go $ -n - 1)+      where+        go 0 = []+        go m =+          let+            (q, r) = quotRem m 2+          in+            (r == 1) : go q++    fromBits :: Integral a => (Bool, [Bool]) -> a+    fromBits (pos, bts)+      | pos = go bts+      | otherwise = negate $ go bts + 1+      where+        go [] = 0+        go (x:xs) = (if x then 1 else 0) + 2 * go xs++instance Arg Bool+instance Arg Ordering+instance Arg a => Arg (Maybe a)+instance Arg a => Arg [a]+instance Arg Int8 where; build = buildIntegral+instance Arg Int16 where; build = buildIntegral+instance Arg Int32 where; build = buildIntegral+instance Arg Int64 where; build = buildIntegral+instance Arg Int where; build = buildIntegral+instance Arg Integer where; build = buildIntegral+

@@ -0,0 +1,45 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module PersistUniqueTest where++import Init++-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs+#if WITH_NOSQL+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|+#else+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+#endif+  Fo+      foo Int+      bar Int+      Primary foo+      UniqueBar bar+      deriving Eq Show+|]+#ifdef WITH_NOSQL+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m ()+cleanDB = do+  deleteWhere ([] :: [Filter Fo])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "custom primary key" $ do+#ifdef WITH_NOSQL+  return ()+#else+  it "getBy" $ db $ do+    let b = 5+    k <- insert $ Fo 3 b+    Just vk <- get k+    Just vu <- getBy (UniqueBar b)+    vu @== Entity k vk+  it "insertUniqueEntity" $ db $ do+    let fo = Fo 3 5+    Just (Entity _ insertedFoValue) <- insertUniqueEntity fo+    Nothing <- insertUniqueEntity fo+    fo @== insertedFoValue+#endif+

@@ -0,0 +1,7 @@+{-# LANGUAGE TypeOperators, TypeFamilies #-}+{-# OPTIONS -Wno-star-is-type #-}++module X (type (X.*)) where++type family (*) a b where { (*) a b = Either b a }+

@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds+             , TypeInType, TypeApplications, TypeFamilies  #-}++module T12045TH1 where+import Data.Kind+import Language.Haskell.TH hiding (Type)++$([d| type family F (a :: k) :: Type where+                     F @Type Int = Bool+                     F @(Type->Type) Maybe = Char |])+++$([d| data family D (a :: k) |])++$([d| data instance D @Type a = DBool |])++$([d| data instance D @(Type -> Type) b = DChar |])+

@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds+             , TypeFamilies, DataKinds #-}++module T12045TH2 where++import Data.Kind+import Language.Haskell.TH hiding (Type)+import System.IO++type family Foo (a :: k) :: Type where+  Foo @Type a = Bool++type family Baz (a :: k)+type instance Baz @(Type->Type->Type) a = Char++$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1)+                   [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1])+              [] <- reify ''Foo+      FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2))+              [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz+      runIO $ putStrLn $ pprint foo+      runIO $ putStrLn $ pprint baz+      runIO $ putStrLn $ pprint inst+      runIO $ hFlush stdout+      return [ ClosedTypeFamilyD+                 (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1)+                 [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1]+             , OpenTypeFamilyD+                 (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2)+             , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] )+

@@ -0,0 +1,84 @@+{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds,+    RankNTypes, ConstraintKinds, TypeFamilies #-}++module T12045a where++import Data.Kind+import Data.Typeable++data T (f :: k -> Type) a = MkT (f a)++newtype TType f a= MkTType (T @Type f a)++t1 :: TType Maybe Bool+t1 = MkTType (MkT (Just True))++t2 :: TType Maybe a+t2 = MkTType (MkT Nothing)++data Nat = O | S Nat++data T1 :: forall k1 k2. k1 -> k2 -> Type where+  MkT1 :: T1 a b++x :: T1 @_ @Nat False n+x = MkT1++-- test from trac 12045+type Cat k = k -> k -> Type++data FreeCat :: Cat k -> Cat k where+  Nil  :: FreeCat f a a+  Cons :: f a b -> FreeCat f b c -> FreeCat f a c++liftCat :: f a b -> FreeCat f a b+liftCat x = Cons x Nil++data Node = Unit | N++data NatGraph :: Cat Node where+  One  :: NatGraph Unit N+  Succ :: NatGraph N    N++one :: (FreeCat @Node NatGraph) Unit N+one = liftCat One++type Typeable1 = Typeable @(Type -> Type)+type Typeable2 = Typeable @(Type -> Type -> Type)+type Typeable3 = Typeable @(Cat Bool)++type family F a where+  F Type = Type -> Type+  F (Type -> Type) = Type+  F other = other++data T2 :: F k -> Type++foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type+foo a b = undefined++data family D (a :: k)+data instance D @Type a = DBool+data instance D @(Type -> Type) b = DChar++class C a where+  tc :: (D a) -> Int++instance C Int where+  tc DBool = 5++instance C Bool where+  tc DBool = 6++instance C Maybe where+  tc DChar = 7++-- Tests from D5229+data P a = MkP+type MkPTrue = MkP @Bool++type BoolEmpty = '[] @Bool++type family F1 (a :: k) :: Type+type G2 (a :: Bool) = F1 @Bool a+

@@ -0,0 +1,9 @@+{-# LANGUAGE AlternativeLayoutRule #-}+{-# LANGUAGE LambdaCase            #-}++isOne :: Int -> Bool+isOne = \case 1 -> True+              _ -> False++main = return ()+

@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module T15365 where++$([d| type (|||) = Either++      (&&&) :: Bool -> Bool -> Bool+      (&&&) = (&&)++      type role (***)+      data (***)++      class (???)+      instance (???)++      data family ($$$)+      data instance ($$$)++      type family (^^^)+      type instance (^^^) = Int++      type family (###) where+        (###) = Int++      pattern (:!!!) :: Bool+      pattern (:!!!) = True+    |])+

@@ -0,0 +1,57 @@+-- | A test for ensuring that GHC's supporting language extensions remains in+-- sync with Cabal's own extension list.+--+-- If you have ended up here due to a test failure, please see+-- Note [Adding a language extension] in compiler/main/DynFlags.hs.++module Main (main) where++import Control.Monad+import Data.List+import DynFlags+import Language.Haskell.Extension++main :: IO ()+main = do+    let ghcExtensions = map flagSpecName xFlags+        cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ]+        ghcOnlyExtensions = ghcExtensions \\ cabalExtensions+        cabalOnlyExtensions = cabalExtensions \\ ghcExtensions+    check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions+    check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions++check :: String -> [String] -> [String] -> IO ()+check title expected got+    = do let unexpected = got \\ expected+             missing = expected \\ got+             showProblems problemType problems+                 = unless (null problems) $+                       do putStrLn (title ++ ": " ++ problemType)+                          putStrLn "-----"+                          mapM_ putStrLn problems+                          putStrLn "-----"+                          putStrLn ""+         showProblems "Unexpected flags" unexpected+         showProblems "Missing flags" missing++-- See Note [Adding a language extension] in compiler/main/DynFlags.hs.+expectedGhcOnlyExtensions :: [String]+expectedGhcOnlyExtensions = ["RelaxedLayout",+                             "AlternativeLayoutRule",+                             "AlternativeLayoutRuleTransitional",+                             "EmptyDataDeriving",+                             "GeneralisedNewtypeDeriving"]++expectedCabalOnlyExtensions :: [String]+expectedCabalOnlyExtensions = ["Generics",+                               "ExtensibleRecords",+                               "RestrictedTypeSynonyms",+                               "HereDocuments",+                               "NewQualifiedOperators",+                               "XmlSyntax",+                               "RegularPatterns",+                               "SafeImports",+                               "Safe",+                               "Unsafe",+                               "Trustworthy"]+

@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+module Bug where++import Language.Haskell.TH++-- Warnings should be preserved through recover+main :: IO ()+main = putStrLn $(recover (stringE "splice failed")+                          [| let x = "a" in let x = "b" in x |])+

@@ -0,0 +1,25 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}+module TH_recursiveDoImport where+import Data.IORef+import Language.Haskell.TH++data SelfRef = SelfRef (IORef (IORef SelfRef))++recIO :: ExpQ+recIO = [e|+    do rec r1 <- newIORef r2+           r2 <- newIORef (SelfRef r1)+       readIORef r2 |]++mdoIO :: ExpQ+mdoIO = [e|+    mdo r1 <- return r2+        r2 <- return (const 1 r1)+        return r1 |]++emptyRecIO :: ExpQ+emptyRecIO = [e|+   do rec {}+      return () |]+

@@ -0,0 +1,94 @@+-- test reification of data declarations++{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module TH_reifyDecl1 where++import Data.Kind as K+import System.IO+import Language.Haskell.TH+import Text.PrettyPrint.HughesPJ++infixl 3 `m1`++-- simple+data T = A | B++-- parametric+data R a = C a | D++-- recursive+data List a = Nil | Cons a (List a)++-- infix operator+data Tree a = Leaf | Tree a :+: Tree a++-- type declaration+type IntList = [Int]++-- newtype declaration+newtype Length = Length Int++-- simple class+class C1 a where+  m1 :: a -> Int++-- class with instances+class C2 a where+  m2 :: a -> Int+instance C2 Int where+  m2 x = x++-- associated types+class C3 a where+  type AT1 a+  data AT2 a++instance C3 Int where+  type AT1 Int = Bool+  data AT2 Int = AT2Int++-- type family+type family TF1 a++-- type family, with instances+type family TF2 a+type instance TF2 Bool = Bool++-- data family+data family DF1 a++-- data family, with instances+data family DF2 a+data instance DF2 Bool = DBool++data family DF3 (a :: k)+data instance DF3 @K.Type a = DF3Bool+data instance DF3 @(K.Type -> K.Type) b = DF3Char++$(return [])++test :: ()+test = $(let+      display :: Name -> Q ()+      display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }+    in do { display ''T+          ; display ''R+          ; display ''List+          ; display ''Tree+          ; display ''IntList+          ; display ''Length+          ; display 'Leaf+          ; display 'm1+          ; display ''C1+          ; display ''C2+          ; display ''C3+          ; display ''AT1+          ; display ''AT2+          ; display ''TF1+          ; display ''TF2+          ; display ''DF1+          ; display ''DF2+          ; display ''DF3+          ; [| () |] })+

@@ -0,0 +1,1056 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Utils+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+--                portions Copyright (c) 2007, Galois Inc.+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A large and somewhat miscellaneous collection of utility functions used+-- throughout the rest of the Cabal lib and in other tools that use the Cabal+-- lib like @cabal-install@. It has a very simple set of logging actions. It+-- has low level functions for running programs, a bunch of wrappers for+-- various directory and file functions that do extra logging.++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Isaac Jones nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Simple.Utils (+        -- * logging and errors+        die,+        dieWithLocation,+        topHandler,+        warn, notice, info, debug,+        debugNoWrap, chattyTry,++        -- * running programs+        rawSystemExit,+        rawSystemExitCode,+        rawSystemExitWithEnv,+        rawSystemStdout,+        rawSystemStdInOut,+        rawSystemIOWithEnv,+        maybeExit,+        xargs,+        findProgramLocation,++        -- * copying files+        createDirectoryIfMissingVerbose,+        copyFileVerbose,+        copyDirectoryRecursiveVerbose,+        copyFiles,++        -- * installing files+        installOrdinaryFile,+        installExecutableFile,+        installOrdinaryFiles,+        installDirectoryContents,++        -- * File permissions+        setFileOrdinary,+        setFileExecutable,++        -- * file names+        currentDir,++        -- * finding files+        findFile,+        findFirstFile,+        findFileWithExtension,+        findFileWithExtension',++        -- * environment variables+        isInSearchPath,++        -- * simple file globbing+        matchFileGlob,+        matchDirFileGlob,+        parseFileGlob,+        FileGlob(..),++        -- * temp files and dirs+        withTempFile,+        withTempDirectory,++        -- * .cabal and .buildinfo files+        defaultPackageDesc,+        findPackageDesc,+        defaultHookedPackageDesc,+        findHookedPackageDesc,++        -- * reading and writing files safely+        withFileContents,+        writeFileAtomic,+        rewriteFile,++        -- * Unicode+        fromUTF8,+        toUTF8,+        readUTF8File,+        withUTF8FileContents,+        writeUTF8File,+        normaliseLineEndings,++        -- * generic utils+        equating,+        comparing,+        isInfixOf,+        intercalate,+        lowercase,+        wrapText,+        wrapLine,+  ) where++import Control.Monad+    ( when, unless, filterM )+import Control.Concurrent.MVar+    ( newEmptyMVar, putMVar, takeMVar )+import Data.List+  ( nub, unfoldr, isPrefixOf, tails, intercalate )+import Data.Char as Char+    ( toLower, chr, ord )+import Data.Bits+    ( Bits((.|.), (.&.), shiftL, shiftR) )+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8++import System.Directory+    ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile+    , findExecutable )+import System.Environment+    ( getProgName )+import System.Cmd+    ( rawSystem )+import System.Exit+    ( exitWith, ExitCode(..) )+import System.FilePath+    ( normalise, (</>), (<.>)+    , getSearchPath, takeDirectory, splitFileName+    , splitExtension, splitExtensions, splitDirectories )+import System.Directory+    ( createDirectory, renameFile, removeDirectoryRecursive )+import System.IO+    ( Handle, openFile, openBinaryFile, openBinaryTempFile+    , IOMode(ReadMode), hSetBinaryMode+    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )+import System.IO.Error as IO.Error+    ( isDoesNotExistError, isAlreadyExistsError+    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )+import System.IO.Error+    ( ioeSetLocation, ioeGetLocation )+import System.IO.Unsafe+    ( unsafeInterleaveIO )+import qualified Control.Exception as Exception++import Distribution.Text+    ( display )++import Control.Exception (evaluate)+import System.Process (runProcess)++import Control.Concurrent (forkIO)+import System.Process (runInteractiveProcess, waitForProcess)+#if __GLASGOW_HASKELL__ >= 702+import System.Process (showCommandForUser)+#endif++import Distribution.Compat.CopyFile+         ( copyFile, copyOrdinaryFile, copyExecutableFile+         , setFileOrdinary, setFileExecutable, setDirOrdinary )+import Distribution.Compat.TempFile+         ( openTempFile, createTempDirectory )+import Distribution.Compat.Exception+         ( IOException, throwIOIO, tryIO, catchIO, catchExit )+import Distribution.Verbosity++-- ----------------------------------------------------------------------------+-- Exception and logging utils++dieWithLocation :: FilePath -> Maybe Int -> String -> IO a+dieWithLocation filename lineno msg =+  ioError . setLocation lineno+          . flip ioeSetFileName (normalise filename)+          $ userError msg+  where+    setLocation Nothing  err = err+    setLocation (Just n) err = ioeSetLocation err (show n)++die :: String -> IO a+die msg = ioError (userError msg)++topHandler :: IO a -> IO a+topHandler prog = catchIO prog handle+  where+    handle ioe = do+      hFlush stdout+      pname <- getProgName+      hPutStr stderr (mesage pname)+      exitWith (ExitFailure 1)+      where+        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)+        file         = case ioeGetFileName ioe of+                         Nothing   -> ""+                         Just path -> path ++ location ++ ": "+        location     = case ioeGetLocation ioe of+                         l@(n:_) | n >= '0' && n <= '9' -> ':' : l+                         _                              -> ""+        detail       = ioeGetErrorString ioe++-- | Non fatal conditions that may be indicative of an error or problem.+--+-- We display these at the 'normal' verbosity level.+--+warn :: Verbosity -> String -> IO ()+warn verbosity msg =+  when (verbosity >= normal) $ do+    hFlush stdout+    hPutStr stderr (wrapText ("Warning: " ++ msg))++-- | Useful status messages.+--+-- We display these at the 'normal' verbosity level.+--+-- This is for the ordinary helpful status messages that users see. Just+-- enough information to know that things are working but not floods of detail.+--+notice :: Verbosity -> String -> IO ()+notice verbosity msg =+  when (verbosity >= normal) $+    putStr (wrapText msg)++-- | More detail on the operation of some action.+--+-- We display these messages when the verbosity level is 'verbose'+--+info :: Verbosity -> String -> IO ()+info verbosity msg =+  when (verbosity >= verbose) $+    putStr (wrapText msg)++-- | Detailed internal debugging information+--+-- We display these messages when the verbosity level is 'deafening'+--+debug :: Verbosity -> String -> IO ()+debug verbosity msg =+  when (verbosity >= deafening) $ do+    putStr (wrapText msg)+    hFlush stdout++-- | A variant of 'debug' that doesn't perform the automatic line+-- wrapping. Produces better output in some cases.+debugNoWrap :: Verbosity -> String -> IO ()+debugNoWrap verbosity msg =+  when (verbosity >= deafening) $ do+    putStrLn msg+    hFlush stdout++-- | Perform an IO action, catching any IO exceptions and printing an error+--   if one occurs.+chattyTry :: String  -- ^ a description of the action we were attempting+          -> IO ()   -- ^ the action itself+          -> IO ()+chattyTry desc action =+  catchIO action $ \exception ->+    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception++-- -----------------------------------------------------------------------------+-- Helper functions++-- | Wraps text to the default line width. Existing newlines are preserved.+wrapText :: String -> String+wrapText = unlines+         . map (intercalate "\n"+              . map unwords+              . wrapLine 79+              . words)+         . lines++-- | Wraps a list of words to a list of lines of words of a particular width.+wrapLine :: Int -> [String] -> [[String]]+wrapLine width = wrap 0 []+  where wrap :: Int -> [String] -> [String] -> [[String]]+        wrap 0   []   (w:ws)+          | length w + 1 > width+          = wrap (length w) [w] ws+        wrap col line (w:ws)+          | col + length w + 1 > width+          = reverse line : wrap 0 [] (w:ws)+        wrap col line (w:ws)+          = let col' = col + length w + 1+             in wrap col' (w:line) ws+        wrap _ []   [] = []+        wrap _ line [] = [reverse line]++-- -----------------------------------------------------------------------------+-- rawSystem variants+maybeExit :: IO ExitCode -> IO ()+maybeExit cmd = do+  res <- cmd+  unless (res == ExitSuccess) $ exitWith res++printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()+printRawCommandAndArgs verbosity path args+ | verbosity >= deafening = print (path, args)+ | verbosity >= verbose   =+#if __GLASGOW_HASKELL__ >= 702+                            putStrLn $ showCommandForUser path args+#else+                            putStrLn $ unwords (path : args)+#endif+ | otherwise              = return ()++printRawCommandAndArgsAndEnv :: Verbosity+                             -> FilePath+                             -> [String]+                             -> [(String, String)]+                             -> IO ()+printRawCommandAndArgsAndEnv verbosity path args env+ | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)+                               print (path, args)+ | verbosity >= verbose   = putStrLn $ unwords (path : args)+ | otherwise              = return ()++-- Exit with the same exitcode if the subcommand fails+rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()+rawSystemExit verbosity path args = do+  printRawCommandAndArgs verbosity path args+  hFlush stdout+  exitcode <- rawSystem path args+  unless (exitcode == ExitSuccess) $ do+    debug verbosity $ path ++ " returned " ++ show exitcode+    exitWith exitcode++rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode+rawSystemExitCode verbosity path args = do+  printRawCommandAndArgs verbosity path args+  hFlush stdout+  exitcode <- rawSystem path args+  unless (exitcode == ExitSuccess) $ do+    debug verbosity $ path ++ " returned " ++ show exitcode+  return exitcode++rawSystemExitWithEnv :: Verbosity+                     -> FilePath+                     -> [String]+                     -> [(String, String)]+                     -> IO ()+rawSystemExitWithEnv verbosity path args env = do+    printRawCommandAndArgsAndEnv verbosity path args env+    hFlush stdout+    ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing+    exitcode <- waitForProcess ph+    unless (exitcode == ExitSuccess) $ do+        debug verbosity $ path ++ " returned " ++ show exitcode+        exitWith exitcode++-- Closes the passed in handles before returning.+rawSystemIOWithEnv :: Verbosity+                   -> FilePath+                   -> [String]+                   -> [(String, String)]+                   -> Maybe Handle  -- ^ stdin+                   -> Maybe Handle  -- ^ stdout+                   -> Maybe Handle  -- ^ stderr+                   -> IO ExitCode+rawSystemIOWithEnv verbosity path args env inp out err = do+    printRawCommandAndArgsAndEnv verbosity path args env+    hFlush stdout+    ph <- runProcess path args Nothing (Just env) inp out err+    exitcode <- waitForProcess ph+    unless (exitcode == ExitSuccess) $ do+      debug verbosity $ path ++ " returned " ++ show exitcode+    return exitcode++-- | Run a command and return its output.+--+-- The output is assumed to be text in the locale encoding.+--+rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String+rawSystemStdout verbosity path args = do+  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args+                                                  Nothing False+  when (exitCode /= ExitSuccess) $+    die errors+  return output++-- | Run a command and return its output, errors and exit status. Optionally+-- also supply some input. Also provides control over whether the binary/text+-- mode of the input and output.+--+rawSystemStdInOut :: Verbosity+                  -> FilePath -> [String]+                  -> Maybe (String, Bool) -- ^ input text and binary mode+                  -> Bool                 -- ^ output in binary mode+                  -> IO (String, String, ExitCode) -- ^ output, errors, exit+rawSystemStdInOut verbosity path args input outputBinary = do+  printRawCommandAndArgs verbosity path args++  Exception.bracket+     (runInteractiveProcess path args Nothing Nothing)+     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)+    $ \(inh,outh,errh,pid) -> do++      -- output mode depends on what the caller wants+      hSetBinaryMode outh outputBinary+      -- but the errors are always assumed to be text (in the current locale)+      hSetBinaryMode errh False++      -- fork off a couple threads to pull on the stderr and stdout+      -- so if the process writes to stderr we do not block.++      err <- hGetContents errh+      out <- hGetContents outh++      mv <- newEmptyMVar+      let force str = (evaluate (length str) >> return ())+            `Exception.finally` putMVar mv ()+          --TODO: handle exceptions like text decoding.+      _ <- forkIO $ force out+      _ <- forkIO $ force err++      -- push all the input, if any+      case input of+        Nothing -> return ()+        Just (inputStr, inputBinary) -> do+                -- input mode depends on what the caller wants+          hSetBinaryMode inh inputBinary+          hPutStr inh inputStr+          hClose inh+          --TODO: this probably fails if the process refuses to consume+          -- or if it closes stdin (eg if it exits)++      -- wait for both to finish, in either order+      takeMVar mv+      takeMVar mv++      -- wait for the program to terminate+      exitcode <- waitForProcess pid+      unless (exitcode == ExitSuccess) $+        debug verbosity $ path ++ " returned " ++ show exitcode+                       ++ if null err then "" else+                          " with error message:\n" ++ err+                       ++ case input of+                            Nothing       -> ""+                            Just ("",  _) -> ""+                            Just (inp, _) -> "\nstdin input:\n" ++ inp++      return (out, err, exitcode)+++-- | Look for a program on the path.+findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)+findProgramLocation verbosity prog = do+  debug verbosity $ "searching for " ++ prog ++ " in path."+  res <- findExecutable prog+  case res of+      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")+      Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)+  return res+++-- | Like the unix xargs program. Useful for when we've got very long command+-- lines that might overflow an OS limit on command line length and so you+-- need to invoke a command multiple times to get all the args in.+--+-- Use it with either of the rawSystem variants above. For example:+--+-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs+--+xargs :: Int -> ([String] -> IO ())+      -> [String] -> [String] -> IO ()+xargs maxSize rawSystemFun fixedArgs bigArgs =+  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs+      chunkSize = maxSize - fixedArgSize+   in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)++  where chunks len = unfoldr $ \s ->+          if null s then Nothing+                    else Just (chunk [] len s)++        chunk acc _   []     = (reverse acc,[])+        chunk acc len (s:ss)+          | len' < len = chunk (s:acc) (len-len'-1) ss+          | otherwise  = (reverse acc, s:ss)+          where len' = length s++-- ------------------------------------------------------------+-- * File Utilities+-- ------------------------------------------------------------++----------------+-- Finding files++-- | Find a file by looking in a search path. The file path must match exactly.+--+findFile :: [FilePath]    -- ^search locations+         -> FilePath      -- ^File Name+         -> IO FilePath+findFile searchPath fileName =+  findFirstFile id+    [ path </> fileName+    | path <- nub searchPath]+  >>= maybe (die $ fileName ++ " doesn't exist") return++-- | Find a file by looking in a search path with one of a list of possible+-- file extensions. The file base name should be given and it will be tried+-- with each of the extensions in each element of the search path.+--+findFileWithExtension :: [String]+                      -> [FilePath]+                      -> FilePath+                      -> IO (Maybe FilePath)+findFileWithExtension extensions searchPath baseName =+  findFirstFile id+    [ path </> baseName <.> ext+    | path <- nub searchPath+    , ext <- nub extensions ]++-- | Like 'findFileWithExtension' but returns which element of the search path+-- the file was found in, and the file path relative to that base directory.+--+findFileWithExtension' :: [String]+                       -> [FilePath]+                       -> FilePath+                       -> IO (Maybe (FilePath, FilePath))+findFileWithExtension' extensions searchPath baseName =+  findFirstFile (uncurry (</>))+    [ (path, baseName <.> ext)+    | path <- nub searchPath+    , ext <- nub extensions ]++findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)+findFirstFile file = findFirst+  where findFirst []     = return Nothing+        findFirst (x:xs) = do exists <- doesFileExist (file x)+                              if exists+                                then return (Just x)+                                else findFirst xs+++-- | List all the files in a directory and all subdirectories.+--+-- The order places files in sub-directories after all the files in their+-- parent directories. The list is generated lazily so is not well defined if+-- the source directory structure changes before the list is used.+--+getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive topdir = recurseDirectories [""]+  where+    recurseDirectories :: [FilePath] -> IO [FilePath]+    recurseDirectories []         = return []+    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do+      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)+      files' <- recurseDirectories (dirs' ++ dirs)+      return (files ++ files')++      where+        collect files dirs' []              = return (reverse files, reverse dirs')+        collect files dirs' (entry:entries) | ignore entry+                                            = collect files dirs' entries+        collect files dirs' (entry:entries) = do+          let dirEntry = dir </> entry+          isDirectory <- doesDirectoryExist (topdir </> dirEntry)+          if isDirectory+            then collect files (dirEntry:dirs') entries+            else collect (dirEntry:files) dirs' entries++        ignore ['.']      = True+        ignore ['.', '.'] = True+        ignore _          = False++------------------------+-- Environment variables++-- | Is this directory in the system search path?+isInSearchPath :: FilePath -> IO Bool+isInSearchPath path = fmap (elem path) getSearchPath++----------------+-- File globbing++data FileGlob+   -- | No glob at all, just an ordinary file+   = NoGlob FilePath++   -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to+   --    @FileGlob \"foo\/bar\" \".baz\"@+   | FileGlob FilePath String++parseFileGlob :: FilePath -> Maybe FileGlob+parseFileGlob filepath = case splitExtensions filepath of+  (filepath', ext) -> case splitFileName filepath' of+    (dir, "*") | '*' `elem` dir+              || '*' `elem` ext+              || null ext            -> Nothing+               | null dir            -> Just (FileGlob "." ext)+               | otherwise           -> Just (FileGlob dir ext)+    _          | '*' `elem` filepath -> Nothing+               | otherwise           -> Just (NoGlob filepath)++matchFileGlob :: FilePath -> IO [FilePath]+matchFileGlob = matchDirFileGlob "."++matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]+matchDirFileGlob dir filepath = case parseFileGlob filepath of+  Nothing -> die $ "invalid file glob '" ++ filepath+                ++ "'. Wildcards '*' are only allowed in place of the file"+                ++ " name, not in the directory name or file extension."+                ++ " If a wildcard is used it must be with an file extension."+  Just (NoGlob filepath') -> return [filepath']+  Just (FileGlob dir' ext) -> do+    files <- getDirectoryContents (dir </> dir')+    case   [ dir' </> file+           | file <- files+           , let (name, ext') = splitExtensions file+           , not (null name) && ext' == ext ] of+      []      -> die $ "filepath wildcard '" ++ filepath+                    ++ "' does not match any files."+      matches -> return matches++----------------------------------------+-- Copying and installing files and dirs++-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.+--+createDirectoryIfMissingVerbose :: Verbosity+                                -> Bool     -- ^ Create its parents too?+                                -> FilePath+                                -> IO ()+createDirectoryIfMissingVerbose verbosity create_parents path0+  | create_parents = createDirs (parents path0)+  | otherwise      = createDirs (take 1 (parents path0))+  where+    parents = reverse . scanl1 (</>) . splitDirectories . normalise++    createDirs []         = return ()+    createDirs (dir:[])   = createDir dir throwIOIO+    createDirs (dir:dirs) =+      createDir dir $ \_ -> do+        createDirs dirs+        createDir dir throwIOIO++    createDir :: FilePath -> (IOException -> IO ()) -> IO ()+    createDir dir notExistHandler = do+      r <- tryIO $ createDirectoryVerbose verbosity dir+      case (r :: Either IOException ()) of+        Right ()                   -> return ()+        Left  e+          | isDoesNotExistError  e -> notExistHandler e+          -- createDirectory (and indeed POSIX mkdir) does not distinguish+          -- between a dir already existing and a file already existing. So we+          -- check for it here. Unfortunately there is a slight race condition+          -- here, but we think it is benign. It could report an exeption in+          -- the case that the dir did exist but another process deletes the+          -- directory and creates a file in its place before we can check+          -- that the directory did indeed exist.+          | isAlreadyExistsError e -> (do+              isDir <- doesDirectoryExist dir+              if isDir then return ()+                       else throwIOIO e+              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())+          | otherwise              -> throwIOIO e++createDirectoryVerbose :: Verbosity -> FilePath -> IO ()+createDirectoryVerbose verbosity dir = do+  info verbosity $ "creating " ++ dir+  createDirectory dir+  setDirOrdinary dir++-- | Copies a file without copying file permissions. The target file is created+-- with default permissions. Any existing target file is replaced.+--+-- At higher verbosity levels it logs an info message.+--+copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()+copyFileVerbose verbosity src dest = do+  info verbosity ("copy " ++ src ++ " to " ++ dest)+  copyFile src dest++-- | Install an ordinary file. This is like a file copy but the permissions+-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"+-- while on Windows it uses the default permissions for the target directory.+--+installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()+installOrdinaryFile verbosity src dest = do+  info verbosity ("Installing " ++ src ++ " to " ++ dest)+  copyOrdinaryFile src dest++-- | Install an executable file. This is like a file copy but the permissions+-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"+-- while on Windows it uses the default permissions for the target directory.+--+installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()+installExecutableFile verbosity src dest = do+  info verbosity ("Installing executable " ++ src ++ " to " ++ dest)+  copyExecutableFile src dest++-- | Copies a bunch of files to a target directory, preserving the directory+-- structure in the target location. The target directories are created if they+-- do not exist.+--+-- The files are identified by a pair of base directory and a path relative to+-- that base. It is only the relative part that is preserved in the+-- destination.+--+-- For example:+--+-- > copyFiles normal "dist/src"+-- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]+--+-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and+-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".+--+-- This operation is not atomic. Any IO failure during the copy (including any+-- missing source files) leaves the target in an unknown state so it is best to+-- use it with a freshly created directory so that it can be simply deleted if+-- anything goes wrong.+--+copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+copyFiles verbosity targetDir srcFiles = do++  -- Create parent directories for everything+  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles+  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs++  -- Copy all the files+  sequence_ [ let src  = srcBase   </> srcFile+                  dest = targetDir </> srcFile+               in copyFileVerbose verbosity src dest+            | (srcBase, srcFile) <- srcFiles ]++-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.+--+installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+installOrdinaryFiles verbosity targetDir srcFiles = do++  -- Create parent directories for everything+  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles+  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs++  -- Copy all the files+  sequence_ [ let src  = srcBase   </> srcFile+                  dest = targetDir </> srcFile+               in installOrdinaryFile verbosity src dest+            | (srcBase, srcFile) <- srcFiles ]++-- | This installs all the files in a directory to a target location,+-- preserving the directory layout. All the files are assumed to be ordinary+-- rather than executable files.+--+installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()+installDirectoryContents verbosity srcDir destDir = do+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+  srcFiles <- getDirectoryContentsRecursive srcDir+  installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]++---------------------------------+-- Deprecated file copy functions++{-# DEPRECATED copyDirectoryRecursiveVerbose+      "You probably want installDirectoryContents instead" #-}+copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()+copyDirectoryRecursiveVerbose verbosity srcDir destDir = do+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+  srcFiles <- getDirectoryContentsRecursive srcDir+  copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]++---------------------------+-- Temporary files and dirs++-- | Use a temporary filename that doesn't already exist.+--+withTempFile :: Bool     -- ^ Keep temporary files?+             -> FilePath -- ^ Temp dir to create the file in+             -> String   -- ^ File name template. See 'openTempFile'.+             -> (FilePath -> Handle -> IO a) -> IO a+withTempFile keepTempFiles tmpDir template action =+  Exception.bracket+    (openTempFile tmpDir template)+    (\(name, handle) -> do hClose handle+                           unless keepTempFiles $ removeFile name)+    (uncurry action)++-- | Create and use a temporary directory.+--+-- Creates a new temporary directory inside the given directory, making use+-- of the template. The temp directory is deleted after use. For example:+--+-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...+--+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.+-- @src/sdist.342@.+--+withTempDirectory :: Verbosity+                  -> Bool     -- ^ Keep temporary files?+                  -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectory _verbosity keepTempFiles targetDir template =+  Exception.bracket+    (createTempDirectory targetDir template)+    (unless keepTempFiles . removeDirectoryRecursive)++-----------------------------------+-- Safely reading and writing files++-- | Gets the contents of a file, but guarantee that it gets closed.+--+-- The file is read lazily but if it is not fully consumed by the action then+-- the remaining input is truncated and the file is closed.+--+withFileContents :: FilePath -> (String -> IO a) -> IO a+withFileContents name action =+  Exception.bracket (openFile name ReadMode) hClose+                    (\hnd -> hGetContents hnd >>= action)++-- | Writes a file atomically.+--+-- The file is either written sucessfully or an IO exception is raised and+-- the original file is left unchanged.+--+-- On windows it is not possible to delete a file that is open by a process.+-- This case will give an IO exception but the atomic property is not affected.+--+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()+writeFileAtomic targetPath content = do+  let (targetDir, targetFile) = splitFileName targetPath+  Exception.bracketOnError+    (openBinaryTempFile targetDir $ targetFile <.> "tmp")+    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)+    (\(tmpPath, handle) -> do+        BS.hPut handle content+        hClose handle+        renameFile tmpPath targetPath)++-- | Write a file but only if it would have new content. If we would be writing+-- the same as the existing content then leave the file as is so that we do not+-- update the file's modification time.+--+rewriteFile :: FilePath -> String -> IO ()+rewriteFile path newContent =+  flip catchIO mightNotExist $ do+    existingContent <- readFile path+    _ <- evaluate (length existingContent)+    unless (existingContent == newContent) $+      writeFileAtomic path (BS.Char8.pack newContent)+  where+    mightNotExist e | isDoesNotExistError e = writeFileAtomic path+                                              (BS.Char8.pack newContent)+                    | otherwise             = ioError e++-- | The path name that represents the current directory.+-- In Unix, it's @\".\"@, but this is system-specific.+-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)+currentDir :: FilePath+currentDir = "."++-- ------------------------------------------------------------+-- * Finding the description file+-- ------------------------------------------------------------++-- |Package description file (/pkgname/@.cabal@)+defaultPackageDesc :: Verbosity -> IO FilePath+defaultPackageDesc _verbosity = findPackageDesc currentDir++-- |Find a package description file in the given directory.  Looks for+-- @.cabal@ files.+findPackageDesc :: FilePath    -- ^Where to look+                -> IO FilePath -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+      -- file we filter to exclude dirs and null base file names:+      cabalFiles <- filterM doesFileExist+                       [ dir </> file+                       | file <- files+                       , let (name, ext) = splitExtension file+                       , not (null name) && ext == ".cabal" ]+      case cabalFiles of+        []          -> noDesc+        [cabalFile] -> return cabalFile+        multiple    -> multiDesc multiple++  where+    noDesc :: IO a+    noDesc = die $ "No cabal file found.\n"+                ++ "Please create a package description file <pkgname>.cabal"++    multiDesc :: [String] -> IO a+    multiDesc l = die $ "Multiple cabal files found.\n"+                    ++ "Please use only one of: "+                    ++ intercalate ", " l++-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)+defaultHookedPackageDesc :: IO (Maybe FilePath)+defaultHookedPackageDesc = findHookedPackageDesc currentDir++-- |Find auxiliary package information in the given directory.+-- Looks for @.buildinfo@ files.+findHookedPackageDesc+    :: FilePath                 -- ^Directory to search+    -> IO (Maybe FilePath)      -- ^/dir/@\/@/pkgname/@.buildinfo@, if present+findHookedPackageDesc dir = do+    files <- getDirectoryContents dir+    buildInfoFiles <- filterM doesFileExist+                        [ dir </> file+                        | file <- files+                        , let (name, ext) = splitExtension file+                        , not (null name) && ext == buildInfoExt ]+    case buildInfoFiles of+        [] -> return Nothing+        [f] -> return (Just f)+        _ -> die ("Multiple files with extension " ++ buildInfoExt)++buildInfoExt  :: String+buildInfoExt = ".buildinfo"++-- ------------------------------------------------------------+-- * Unicode stuff+-- ------------------------------------------------------------++-- This is a modification of the UTF8 code from gtk2hs and the+-- utf8-string package.++fromUTF8 :: String -> String+fromUTF8 []     = []+fromUTF8 (c:cs)+  | c <= '\x7F' = c : fromUTF8 cs+  | c <= '\xBF' = replacementChar : fromUTF8 cs+  | c <= '\xDF' = twoBytes c cs+  | c <= '\xEF' = moreBytes 3 0x800     cs (ord c .&. 0xF)+  | c <= '\xF7' = moreBytes 4 0x10000   cs (ord c .&. 0x7)+  | c <= '\xFB' = moreBytes 5 0x200000  cs (ord c .&. 0x3)+  | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)+  | otherwise   = replacementChar : fromUTF8 cs+  where+    twoBytes c0 (c1:cs')+      | ord c1 .&. 0xC0 == 0x80+      = let d = ((ord c0 .&. 0x1F) `shiftL` 6)+             .|. (ord c1 .&. 0x3F)+         in if d >= 0x80+               then  chr d           : fromUTF8 cs'+               else  replacementChar : fromUTF8 cs'+    twoBytes _ cs' = replacementChar : fromUTF8 cs'++    moreBytes :: Int -> Int -> [Char] -> Int -> [Char]+    moreBytes 1 overlong cs' acc+      | overlong <= acc && acc <= 0x10FFFF+     && (acc < 0xD800 || 0xDFFF < acc)+     && (acc < 0xFFFE || 0xFFFF < acc)+      = chr acc : fromUTF8 cs'++      | otherwise+      = replacementChar : fromUTF8 cs'++    moreBytes byteCount overlong (cn:cs') acc+      | ord cn .&. 0xC0 == 0x80+      = moreBytes (byteCount-1) overlong cs'+          ((acc `shiftL` 6) .|. ord cn .&. 0x3F)++    moreBytes _ _ cs' _+      = replacementChar : fromUTF8 cs'++    replacementChar = '\xfffd'++toUTF8 :: String -> String+toUTF8 []        = []+toUTF8 (c:cs)+  | c <= '\x07F' = c+                 : toUTF8 cs+  | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))+                 : chr (0x80 .|. (w .&. 0x3F))+                 : toUTF8 cs+  | c <= '\xFFFF'= chr (0xE0 .|.  (w `shiftR` 12))+                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))+                 : chr (0x80 .|.  (w .&. 0x3F))+                 : toUTF8 cs+  | otherwise    = chr (0xf0 .|.  (w `shiftR` 18))+                 : chr (0x80 .|. ((w `shiftR` 12)  .&. 0x3F))+                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))+                 : chr (0x80 .|.  (w .&. 0x3F))+                 : toUTF8 cs+  where w = ord c++-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input+--+ignoreBOM :: String -> String+ignoreBOM ('\xFEFF':string) = string+ignoreBOM string            = string++-- | Reads a UTF8 encoded text file as a Unicode String+--+-- Reads lazily using ordinary 'readFile'.+--+readUTF8File :: FilePath -> IO String+readUTF8File f = fmap (ignoreBOM . fromUTF8)+               . hGetContents =<< openBinaryFile f ReadMode++-- | Reads a UTF8 encoded text file as a Unicode String+--+-- Same behaviour as 'withFileContents'.+--+withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a+withUTF8FileContents name action =+  Exception.bracket+    (openBinaryFile name ReadMode)+    hClose+    (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8)++-- | Writes a Unicode String as a UTF8 encoded text file.+--+-- Uses 'writeFileAtomic', so provides the same guarantees.+--+writeUTF8File :: FilePath -> String -> IO ()+writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8++-- | Fix different systems silly line ending conventions+normaliseLineEndings :: String -> String+normaliseLineEndings [] = []+normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows+normaliseLineEndings ('\r':s)      = '\n' : normaliseLineEndings s -- old osx+normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s++-- ------------------------------------------------------------+-- * Common utils+-- ------------------------------------------------------------++equating :: Eq a => (b -> a) -> b -> b -> Bool+equating p x y = p x == p y++comparing :: Ord a => (b -> a) -> b -> b -> Ordering+comparing p x y = p x `compare` p y++isInfixOf :: String -> String -> Bool+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)++lowercase :: String -> String+lowercase = map Char.toLower+

@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+module MoreExplicitForalls where++import Data.Proxy++data family F1 a+data instance forall (x :: Bool). F1 (Proxy x) = MkF++class C a where+  type F2 a b++instance forall a. C [a] where+  type forall b. F2 [a] b = Int+++type family G a b where+  forall x y. G [x] (Proxy y) = Double+  forall z.   G z   z         = Bool+