summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xChangeLog2
-rw-r--r--ghc-exactprint.cabal52
-rw-r--r--src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs2938
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs25
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Delta.hs35
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Parsers.hs13
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Pretty.hs16
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Print.hs24
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Transform.hs23
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Types.hs28
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Utils.hs6
-rw-r--r--tests/Test.hs43
-rw-r--r--tests/Test/Transform.hs38
-rwxr-xr-xtests/examples/failing/dsrun010.hs25
-rwxr-xr-xtests/examples/ghc88/ClassParens.hs11
-rwxr-xr-xtests/examples/ghc88/DumpParsedAst.hs20
-rwxr-xr-xtests/examples/ghc88/EmptyCase008.hs55
-rwxr-xr-xtests/examples/ghc88/Exp.hs203
-rwxr-xr-xtests/examples/ghc88/ExplicitForAllRules1.hs46
-rwxr-xr-xtests/examples/ghc88/Internal.hs342
-rwxr-xr-xtests/examples/ghc88/PersistUniqueTest.hs45
-rwxr-xr-xtests/examples/ghc88/StarBinder.hs7
-rwxr-xr-xtests/examples/ghc88/T12045TH1.hs18
-rwxr-xr-xtests/examples/ghc88/T12045TH2.hs31
-rwxr-xr-xtests/examples/ghc88/T12045a.hs84
-rwxr-xr-xtests/examples/ghc88/T13087.hs9
-rwxr-xr-xtests/examples/ghc88/T15365.hs32
-rwxr-xr-xtests/examples/ghc88/T4437.hs57
-rwxr-xr-xtests/examples/ghc88/TH_recover_warns.hs11
-rwxr-xr-xtests/examples/ghc88/TH_recursiveDoImport.hs25
-rwxr-xr-xtests/examples/ghc88/TH_reifyDecl1.hs94
-rwxr-xr-xtests/examples/ghc88/Utils.hs1056
-rwxr-xr-xtests/examples/ghc88/hie010.hs24
33 files changed, 5397 insertions, 41 deletions
diff --git a/ChangeLog b/ChangeLog
index 2d1d965..bb14784 100755
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index 43fe923..9ab0a66 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -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 @@ tested-with: GHC == 7.10.3
, 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 @@ extra-source-files: ChangeLog
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 @@ library
-- 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 @@ library
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 @@ Test-Suite test
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 @@ Test-Suite test
if impl (ghc < 7.10.2)
buildable: False
Build-depends: HUnit >= 1.2
- , base < 4.13
+ , base < 4.14
, bytestring
, containers >= 0.5
, Diff
diff --git a/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs
new file mode 100644
index 0000000..30bcc71
--- /dev/null
+++ b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs
@@ -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
diff --git a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs
index b2b7f5a..0961f80 100644
--- a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs
@@ -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 @@ data AnnotationF next where
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 @@ workOutString l kw f = do
-- ---------------------------------------------------------------------
-- |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 @@ markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep
-- ---------------------------------------------------------------------
+#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
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
index b7e31a7..829d988 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -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 @@ import qualified Data.Set as Set
-- ---------------------------------------------------------------------
-- | 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 @@ relativiseApiAnns = relativiseApiAnnsWithComments []
-- 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 @@ getSrcSpanForKw _ kw = do
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 @@ addAnnDeltaPos kw dp = tellKd (kw, dp)
-- -------------------------------------
-- | 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 @@ addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s
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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
index 223abf1..0dd67f2 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -49,6 +50,9 @@ import Language.Haskell.GHC.ExactPrint.Preprocess
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 @@ import qualified Data.Map as Map
-- | 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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
index 3ac79cd..7afabbb 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs
@@ -1,7 +1,9 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -226,6 +228,7 @@ addPrettyAnnotation ann = do
(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 @@ addPrettyAnnotation ann = do
(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 @@ putUnallocatedComments cs = modify (\s -> s { apComments = cs } )
-- ---------------------------------------------------------------------
+#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 @@ withSrcSpanPretty (GHC.L l a) action = do
-- ---------------------------------------------------------------------
-- | 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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs
index 55c9c6a..b47a33b 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Print.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
@@ -73,7 +74,11 @@ exactPrintWithOptions r ast as =
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 @@ data PrintOptions m a = PrintOptions
-- | 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 @@ defaultEPState as = EPState
-- ---------------------------------------------------------------------
-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 @@ allAnns kwid = printStringAtMaybeAnnAll (G kwid) Nothing
-------------------------------------------------------------------------
-- |First move to the given location, then call exactP
+-- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a
+-- exactPC :: (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 @@ advance cl = do
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 ()
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
index bf5bdea..f16091c 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -301,7 +301,12 @@ wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)
-- |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 @@ removeTrailingCommaT ast = do
-- ---------------------------------------------------------------------
-- |'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 @@ getEntryDPT ast = do
-- ---------------------------------------------------------------------
-- |'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 @@ setPrecedingLines ast n c anne = setEntryDP ast (DP (n,c)) anne
-- |Return the true entry 'DeltaPos' from the annotation for a given AST
-- element. This is the 'DeltaPos' ignoring any comments.
+#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 @@ getEntryDP anns ast =
-- |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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
index 152a843..f875a67 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -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 @@ module Language.Haskell.GHC.ExactPrint.Types
, ACS'(..)
, ListContexts(..)
+ -- * For managing compatibility
+ , Constraints
+
-- * GHC version compatibility
, GhcPs
, GhcRn
@@ -45,6 +50,7 @@ module Language.Haskell.GHC.ExactPrint.Types
) where
import Data.Data (Data, Typeable, toConstr,cast)
+-- import Data.Generics
import qualified DynFlags as GHC
import qualified GHC
@@ -55,6 +61,14 @@ import qualified Data.Set as Set
-- ---------------------------------------------------------------------
+#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 @@ data AnnKey = AnnKey GHC.SrcSpan AnnConName
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 @@ type GhcTc = GHC.GhcTc
#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 @@ data AstContext = LambdaExpr
| 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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
index c195340..323b9f7 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -325,7 +326,12 @@ extractComments (_,cm)
-- 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
diff --git a/tests/Test.hs b/tests/Test.hs
index 3921890..0d358cb 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -28,12 +28,14 @@ import Test.HUnit
-- ---------------------------------------------------------------------
-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 @@ testDirs =
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' :: IO (Counts,Int)
tt' = runTestText (putTextToHandle stdout True) $ TestList [
- -- mkPrettyRoundtrip "ghc82" "TensorTests.hs"
+ -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs"
+ -- mkPrettyRoundtrip "ghc86" "mdo.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 "ghc710" "GADTContext.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"
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
index 0eb3561..43369aa 100644
--- a/tests/Test/Transform.hs
+++ b/tests/Test/Transform.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
module Test.Transform where
import Language.Haskell.GHC.ExactPrint
@@ -329,21 +330,46 @@ rename newNameStr spans a
#endif
replaceHsVar x = x
-#if __GLASGOW_HASKELL__ > 802
+
+
+#if __GLASGOW_HASKELL__ > 806
+ replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs
+ 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
-#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.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
+
+
+
-- ---------------------------------------------------------------------
changeWhereIn4 :: Changer
diff --git a/tests/examples/failing/dsrun010.hs b/tests/examples/failing/dsrun010.hs
new file mode 100755
index 0000000..1d4fc48
--- /dev/null
+++ b/tests/examples/failing/dsrun010.hs
@@ -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)
diff --git a/tests/examples/ghc88/ClassParens.hs b/tests/examples/ghc88/ClassParens.hs
new file mode 100755
index 0000000..4292fcc
--- /dev/null
+++ b/tests/examples/ghc88/ClassParens.hs
@@ -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)
diff --git a/tests/examples/ghc88/DumpParsedAst.hs b/tests/examples/ghc88/DumpParsedAst.hs
new file mode 100755
index 0000000..6c6684a
--- /dev/null
+++ b/tests/examples/ghc88/DumpParsedAst.hs
@@ -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"
+
diff --git a/tests/examples/ghc88/EmptyCase008.hs b/tests/examples/ghc88/EmptyCase008.hs
new file mode 100755
index 0000000..359e757
--- /dev/null
+++ b/tests/examples/ghc88/EmptyCase008.hs
@@ -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
+
diff --git a/tests/examples/ghc88/Exp.hs b/tests/examples/ghc88/Exp.hs
new file mode 100755
index 0000000..5f91a36
--- /dev/null
+++ b/tests/examples/ghc88/Exp.hs
@@ -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
+
diff --git a/tests/examples/ghc88/ExplicitForAllRules1.hs b/tests/examples/ghc88/ExplicitForAllRules1.hs
new file mode 100755
index 0000000..f771735
--- /dev/null
+++ b/tests/examples/ghc88/ExplicitForAllRules1.hs
@@ -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 #-}
+
diff --git a/tests/examples/ghc88/Internal.hs b/tests/examples/ghc88/Internal.hs
new file mode 100755
index 0000000..c848e03
--- /dev/null
+++ b/tests/examples/ghc88/Internal.hs
@@ -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
+
diff --git a/tests/examples/ghc88/PersistUniqueTest.hs b/tests/examples/ghc88/PersistUniqueTest.hs
new file mode 100755
index 0000000..9a60a6d
--- /dev/null
+++ b/tests/examples/ghc88/PersistUniqueTest.hs
@@ -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
+
diff --git a/tests/examples/ghc88/StarBinder.hs b/tests/examples/ghc88/StarBinder.hs
new file mode 100755
index 0000000..7f2b8a6
--- /dev/null
+++ b/tests/examples/ghc88/StarBinder.hs
@@ -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 }
+
diff --git a/tests/examples/ghc88/T12045TH1.hs b/tests/examples/ghc88/T12045TH1.hs
new file mode 100755
index 0000000..715678a
--- /dev/null
+++ b/tests/examples/ghc88/T12045TH1.hs
@@ -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 |])
+
diff --git a/tests/examples/ghc88/T12045TH2.hs b/tests/examples/ghc88/T12045TH2.hs
new file mode 100755
index 0000000..c13b9c4
--- /dev/null
+++ b/tests/examples/ghc88/T12045TH2.hs
@@ -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)] )
+
diff --git a/tests/examples/ghc88/T12045a.hs b/tests/examples/ghc88/T12045a.hs
new file mode 100755
index 0000000..7a0697e
--- /dev/null
+++ b/tests/examples/ghc88/T12045a.hs
@@ -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
+
diff --git a/tests/examples/ghc88/T13087.hs b/tests/examples/ghc88/T13087.hs
new file mode 100755
index 0000000..44ec086
--- /dev/null
+++ b/tests/examples/ghc88/T13087.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE AlternativeLayoutRule #-}
+{-# LANGUAGE LambdaCase #-}
+
+isOne :: Int -> Bool
+isOne = \case 1 -> True
+ _ -> False
+
+main = return ()
+
diff --git a/tests/examples/ghc88/T15365.hs b/tests/examples/ghc88/T15365.hs
new file mode 100755
index 0000000..91a9499
--- /dev/null
+++ b/tests/examples/ghc88/T15365.hs
@@ -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
+ |])
+
diff --git a/tests/examples/ghc88/T4437.hs b/tests/examples/ghc88/T4437.hs
new file mode 100755
index 0000000..da2de38
--- /dev/null
+++ b/tests/examples/ghc88/T4437.hs
@@ -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"]
+
diff --git a/tests/examples/ghc88/TH_recover_warns.hs b/tests/examples/ghc88/TH_recover_warns.hs
new file mode 100755
index 0000000..c502712
--- /dev/null
+++ b/tests/examples/ghc88/TH_recover_warns.hs
@@ -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 |])
+
diff --git a/tests/examples/ghc88/TH_recursiveDoImport.hs b/tests/examples/ghc88/TH_recursiveDoImport.hs
new file mode 100755
index 0000000..ce30338
--- /dev/null
+++ b/tests/examples/ghc88/TH_recursiveDoImport.hs
@@ -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 () |]
+
diff --git a/tests/examples/ghc88/TH_reifyDecl1.hs b/tests/examples/ghc88/TH_reifyDecl1.hs
new file mode 100755
index 0000000..076b6e4
--- /dev/null
+++ b/tests/examples/ghc88/TH_reifyDecl1.hs
@@ -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
+ ; [| () |] })
+
diff --git a/tests/examples/ghc88/Utils.hs b/tests/examples/ghc88/Utils.hs
new file mode 100755
index 0000000..fdd7bea
--- /dev/null
+++ b/tests/examples/ghc88/Utils.hs
@@ -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
+
diff --git a/tests/examples/ghc88/hie010.hs b/tests/examples/ghc88/hie010.hs
new file mode 100755
index 0000000..3f87299
--- /dev/null
+++ b/tests/examples/ghc88/hie010.hs
@@ -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
+