From ac76b691278899feed16a6047a880b9a44e4d225 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 17 Apr 2018 17:08:21 +0200
Subject: [PATCH 1/2] Permit stack.yaml failure in travis
---
.travis.yml | 1 +
1 file changed, 1 insertion(+)
diff --git a/.travis.yml b/.travis.yml
index 55adf2e..2223ff3 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -148,6 +148,7 @@ matrix:
allow_failures:
#- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
- env: BUILD=stack ARGS="--resolver nightly"
+ - env: BUILD=stack ARGS=""
before_install:
# Using compiler above sets CC to an invalid value, so unset it
From 10e1c19788aeb8089d0df7814c6b49769da9c2c9 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 17 Apr 2018 17:00:55 +0200
Subject: [PATCH 2/2] Add support for ghc-8.4
---
.travis.yml | 24 +++---
brittany.cabal | 6 +-
src/Language/Haskell/Brittany/Internal.hs | 11 ++-
.../Haskell/Brittany/Internal/Config.hs | 3 +-
.../Brittany/Internal/ExactPrintUtils.hs | 20 +++--
.../Brittany/Internal/Layouters/Decl.hs | 78 +++++++++++--------
.../Brittany/Internal/Layouters/Expr.hs | 42 ++++++++--
.../Brittany/Internal/Layouters/Expr.hs-boot | 7 +-
.../Haskell/Brittany/Internal/Layouters/IE.hs | 5 +-
.../Brittany/Internal/Layouters/Import.hs | 1 -
.../Brittany/Internal/Layouters/Module.hs | 1 -
.../Brittany/Internal/Layouters/Pattern.hs | 7 +-
.../Brittany/Internal/Layouters/Stmt.hs | 3 +-
.../Brittany/Internal/Layouters/Stmt.hs-boot | 3 +-
.../Brittany/Internal/Layouters/Type.hs | 1 -
.../Haskell/Brittany/Internal/Prelude.hs | 25 +++++-
.../Haskell/Brittany/Internal/Types.hs | 7 +-
17 files changed, 159 insertions(+), 85 deletions(-)
diff --git a/.travis.yml b/.travis.yml
index 2223ff3..46b2763 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -73,9 +73,12 @@ matrix:
- env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #cabal 8.0.2"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- - env: BUILD=cabal GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
- compiler: ": #cabal 8.2.1"
- addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+ - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
+ compiler: ": #cabal 8.2.2"
+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+ - env: BUILD=cabal GHCVER=8.4.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
+ compiler: ": #cabal 8.4.1"
+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
# Build with the newest GHC and cabal-install. This is an accepted failure,
# see below.
@@ -85,15 +88,15 @@ matrix:
##### CABAL DIST CHECK
- - env: BUILD=cabaldist GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
- compiler: ": #cabal 8.2.1 dist"
- addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+ - env: BUILD=cabaldist GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
+ compiler: ": #cabal 8.2.2 dist"
+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
##### CANEW #####
- - env: BUILD=canew GHCVER=8.2.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
- compiler: ": #cabal new 8.2.1"
- addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
+ - env: BUILD=canew GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
+ compiler: ": #cabal new 8.2.2"
+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
##### STACK #####
@@ -118,6 +121,9 @@ matrix:
- env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml"
compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}}
+ - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml"
+ compiler: ": #stack 8.2.2"
+ addons: {apt: {packages: [libgmp-dev]}}
# Nightly builds are allowed to fail
- env: BUILD=stack ARGS="--resolver nightly"
diff --git a/brittany.cabal b/brittany.cabal
index bee2b04..d734dc2 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -82,8 +82,8 @@ library {
-fno-warn-redundant-constraints
}
build-depends:
- { base >=4.9 && <4.11
- , ghc >=8.0.1 && <8.3
+ { base >=4.9 && <4.12
+ , ghc >=8.0.1 && <8.5
, ghc-paths >=0.1.0.9 && <0.2
, ghc-exactprint >=0.5.6.0 && <0.5.7
, transformers >=0.5.2.0 && <0.6
@@ -110,7 +110,7 @@ library {
, semigroups >=0.18.2 && <0.19
, cmdargs >=0.10.14 && <0.11
, czipwith >=1.0.1.0 && <1.1
- , ghc-boot-th >=8.0.1 && <8.3
+ , ghc-boot-th >=8.0.1 && <8.5
, filepath >=1.4.1.0 && <1.5
}
default-extensions: {
diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs
index e6a3c72..eb57aa4 100644
--- a/src/Language/Haskell/Brittany/Internal.hs
+++ b/src/Language/Haskell/Brittany/Internal.hs
@@ -47,7 +47,6 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC hiding (parseModule)
import ApiAnnotation ( AnnKeywordId(..) )
-import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan )
import HsSyn
@@ -248,7 +247,7 @@ parsePrintModuleTests conf filename input = do
-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- else return $ TextL.toStrict $ Text.Builder.toLazyText out
-ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM ()
+ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM ()
ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
post <- ppPreamble lmod
decls `forM_` \decl -> do
@@ -302,7 +301,7 @@ withTransformedAnns ast m = do
in annsBalanced
-ppDecl :: LHsDecl RdrName -> PPMLocal ()
+ppDecl :: LHsDecl GhcPs -> PPMLocal ()
ppDecl d@(L loc decl) = case decl of
SigD sig -> -- trace (_sigHead sig) $
withTransformedAnns d $ do
@@ -322,7 +321,7 @@ ppDecl d@(L loc decl) = case decl of
-- Prints the information associated with the module annotation
-- This includes the imports
-ppPreamble :: GenLocated SrcSpan (HsModule RdrName)
+ppPreamble :: GenLocated SrcSpan (HsModule GhcPs)
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
filteredAnns <- mAsk <&> \annMap ->
@@ -390,13 +389,13 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
return post
-_sigHead :: Sig RdrName -> String
+_sigHead :: Sig GhcPs -> String
_sigHead = \case
TypeSig names _ ->
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig"
-_bindHead :: HsBind RdrName -> String
+_bindHead :: HsBind GhcPs -> String
_bindHead = \case
FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _pat _ _ _ ([], []) -> "PatBind smth"
diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs
index 76e9c95..2719e82 100644
--- a/src/Language/Haskell/Brittany/Internal/Config.hs
+++ b/src/Language/Haskell/Brittany/Internal/Config.hs
@@ -38,6 +38,7 @@ import Language.Haskell.Brittany.Internal.Config.Types.Instances
import Language.Haskell.Brittany.Internal.Utils
import Data.Coerce ( Coercible, coerce )
+import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
@@ -272,7 +273,7 @@ readConfigs
-> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths
- let merged = Semigroup.mconcat $ reverse (cmdlineConfig:catMaybes configs)
+ let merged = Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs
diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
index 749804c..19bc835 100644
--- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
+++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
@@ -29,10 +29,9 @@ import qualified GHC as GHC hiding (parseModule)
import qualified Lexer as GHC
import qualified StringBuffer as GHC
import qualified Outputable as GHC
-import RdrName ( RdrName(..) )
+import qualified CmdLineParser as GHC
import HsSyn
import SrcLoc ( SrcSpan, Located )
-import RdrName ( RdrName(..) )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@@ -79,7 +78,7 @@ parseModuleWithCpp cpp opts args fp dynCheck =
when (not $ null warnings)
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
- ++ show (warnings <&> \(L _ s) -> s)
+ ++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
@@ -111,7 +110,7 @@ parseModuleFromString args fp dynCheck str =
when (not $ null warnings)
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
- ++ show (warnings <&> \(L _ s) -> s)
+ ++ show (warnings <&> warnExtractorCompat)
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of
@@ -187,7 +186,7 @@ commentAnnFixTransform modul = SYB.everything (>>) genF modul
where
genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
genF = (\_ -> return ()) `SYB.extQ` exprF
- exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform ()
+ exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
exprF lexpr@(L _ expr) = case expr of
RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->
moveTrailingComments lexpr (List.last fs)
@@ -226,7 +225,7 @@ moveTrailingComments astFrom astTo = do
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have.
extractToplevelAnns
- :: Located (HsModule RdrName)
+ :: Located (HsModule GhcPs)
-> ExactPrint.Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns
extractToplevelAnns lmod anns = output
@@ -265,3 +264,12 @@ foldedAnnKeys ast = SYB.everything
)
ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
+
+
+#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
+warnExtractorCompat :: GHC.Warn -> String
+warnExtractorCompat (GHC.Warn _ (L _ s)) = s
+#else /* ghc-8.0 && ghc-8.2 */
+warnExtractorCompat :: GenLocated l String -> String
+warnExtractorCompat (L _ s) = s
+#endif
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
index babcab1..53f58b7 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
@@ -20,7 +20,6 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
-import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan )
import HsSyn
@@ -88,11 +87,7 @@ layoutSig lsig@(L _loc sig) = case sig of
InlineSig name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
- let specStr = case spec of
- Inline -> "INLINE "
- Inlinable -> "INLINABLE "
- NoInline -> "NOINLINE "
- EmptyInlineSpec -> "" -- i have no idea if this is correct.
+ specStr <- specStringCompat lsig spec
let phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default
@@ -108,7 +103,23 @@ layoutSig lsig@(L _loc sig) = case sig of
<> Text.pack " #-}"
_ -> briDocByExactNoComment lsig -- TODO
-layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName))
+specStringCompat
+ :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
+#if MIN_VERSION_ghc(8,4,0)
+specStringCompat ast = \case
+ NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""
+ Inline -> pure "INLINE "
+ Inlinable -> pure "INLINABLE "
+ NoInline -> pure "NOINLINE "
+#else
+specStringCompat _ = \case
+ Inline -> pure "INLINE "
+ Inlinable -> pure "INLINABLE "
+ NoInline -> pure "NOINLINE "
+ EmptyInlineSpec -> pure ""
+#endif
+
+layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt body _ _ _ -> layoutExpr body
BindStmt lPat expr _ _ _ -> do
@@ -122,7 +133,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
layoutBind
:: ToBriDocC
- (HsBindLR RdrName RdrName)
+ (HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of
FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
@@ -148,15 +159,15 @@ layoutBind lbind@(L _ bind) = case bind of
hasComments
_ -> Right <$> unknownNodeError "" lbind
-data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
- | BagSig (LSig RdrName)
+data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
+ | BagSig (LSig GhcPs)
bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds
- :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])
+ :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
layoutLocalBinds lbinds@(L _ binds) = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
@@ -178,11 +189,11 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x
EmptyLocalBinds -> return $ Nothing
--- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is
+-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is
-- parSpacing stuff.B
layoutGrhs
- :: LGRHS RdrName (LHsExpr RdrName)
- -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
+ :: LGRHS GhcPs (LHsExpr GhcPs)
+ -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)
layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body
@@ -191,12 +202,14 @@ layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
layoutPatternBind
:: Maybe Text
-> BriDocNumbered
- -> LMatch RdrName (LHsExpr RdrName)
+ -> LMatch GhcPs (LHsExpr GhcPs)
-> ToBriDocM BriDocNumbered
-layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do
+layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do
+ let pats = m_pats match
+ let (GRHSs grhss whereBinds) = m_grhss match
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
- let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr
+ let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
(Just idStr, p1 : pr) | isInfix -> docCols
ColPatternsFuncInfix
@@ -222,25 +235,26 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (
mWhereDocs
hasComments
-#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */
fixPatternBindIdentifier
- :: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text
-fixPatternBindIdentifier ctx idStr = case ctx of
- (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
- (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
- (FunRhs _ _ NoSrcStrict) -> idStr
- (StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1
- _ -> idStr
+ :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
+fixPatternBindIdentifier match idStr = go $ m_ctxt match
where
+ go = \case
+ (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
+ (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
+ (FunRhs _ _ NoSrcStrict) -> idStr
+ (StmtCtxt ctx1 ) -> goInner ctx1
+ _ -> idStr
-- I have really no idea if this path ever occurs, but better safe than
-- risking another "drop bangpatterns" bugs.
- fixPatternBindIdentifier' = \case
- (PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr
- (ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
- (TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
+ goInner = \case
+ (PatGuard ctx1) -> go ctx1
+ (ParStmtCtxt ctx1) -> goInner ctx1
+ (TransStmtCtxt ctx1) -> goInner ctx1
_ -> idStr
-#else /* ghc-8.0 */
-fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text
+#else /* ghc-8.0 */
+fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier _ x = x
#endif
@@ -248,7 +262,7 @@ layoutPatternBindFinal
:: Maybe Text
-> BriDocNumbered
-> Maybe BriDocNumbered
- -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)]
+ -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]
-> Maybe [BriDocNumbered]
-> Bool
-> ToBriDocM BriDocNumbered
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index 9116c79..93a06ac 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
@@ -15,8 +15,7 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
-import RdrName ( RdrName(..) )
-import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )
+import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..), RdrName(..) )
import HsSyn
import Name
import qualified FastString
@@ -56,7 +55,12 @@ layoutExpr lexpr@(L _ expr) = do
allocateNode $ overLitValBriDoc olit
HsLit lit -> do
allocateNode $ litBriDoc lit
- HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do
+ HsLam (MG (L _ [lmatch@(L _ match)]) _ _ _)
+ | pats <- m_pats match
+ , GRHSs [lgrhs] llocals <- m_grhss match
+ , L _ EmptyLocalBinds <- llocals
+ , L _ (GRHS [] body) <- lgrhs
+ -> do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
let funcPatternPartLine =
@@ -112,7 +116,7 @@ layoutExpr lexpr@(L _ expr) = do
(docLit $ Text.pack "\\case")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
HsApp exp1@(L _ HsApp{}) exp2 -> do
- let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])
+ let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs])
gather list = \case
L _ (HsApp l r) -> gather (r:list) l
x -> (x, list)
@@ -220,7 +224,7 @@ layoutExpr lexpr@(L _ expr) = do
-- TODO
briDocByExactInlineOnly "HsAppTypeOut{}" lexpr
OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do
- let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)])
+ let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)])
gather opExprList = \case
(L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1
final -> (final, opExprList)
@@ -1077,7 +1081,31 @@ layoutExpr lexpr@(L _ expr) = do
#endif
-#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
+#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
+litBriDoc :: HsLit GhcPs -> BriDocFInt
+litBriDoc = \case
+ HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
+ HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
+ HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString
+ HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString
+ HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+ HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+ HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+ HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+ HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+ HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+ HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t
+ HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
+ HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
+ _ -> error "litBriDoc: literal with no SourceText"
+
+overLitValBriDoc :: OverLitVal -> BriDocFInt
+overLitValBriDoc = \case
+ HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t
+ HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
+ HsIsString (SourceText t) _ -> BDFLit $ Text.pack t
+ _ -> error "overLitValBriDoc: literal with no SourceText"
+#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
litBriDoc :: HsLit -> BriDocFInt
litBriDoc = \case
HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
@@ -1101,7 +1129,7 @@ overLitValBriDoc = \case
HsFractional (FL t _) -> BDFLit $ Text.pack t
HsIsString (SourceText t) _ -> BDFLit $ Text.pack t
_ -> error "overLitValBriDoc: literal with no SourceText"
-#else
+#else /* ghc-8.0 */
litBriDoc :: HsLit -> BriDocFInt
litBriDoc = \case
HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
index 0d01034..1f76032 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
@@ -14,7 +14,6 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
-import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import HsSyn
import Name
@@ -23,8 +22,12 @@ import Name
layoutExpr :: ToBriDoc HsExpr
--- layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
+-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
+litBriDoc :: HsLit GhcPs -> BriDocFInt
+#else /* ghc-8.0 && ghc-8.2 */
litBriDoc :: HsLit -> BriDocFInt
+#endif
overLitValBriDoc :: OverLitVal -> BriDocFInt
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
index 2ba66a0..4e5af9f 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
@@ -11,7 +11,6 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
-import RdrName (RdrName(..))
import GHC ( unLoc
, runGhc
, GenLocated(L)
@@ -89,7 +88,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
- :: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered]
+ :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie]
let ieDocs = layoutIE <$> lies
@@ -114,7 +113,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do
-- () -- no comments
-- ( -- a comment
-- )
-layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered
+layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline llies = do
ieDs <- layoutAnnAndSepLLIEs llies
hasComments <- hasAnyCommentsBelow llies
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
index 7eb3e27..3f56dcd 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
@@ -7,7 +7,6 @@ import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Config.Types
-import RdrName ( RdrName(..) )
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
index 1b7918d..2eebd20 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
@@ -8,7 +8,6 @@ import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types
-import RdrName (RdrName(..))
import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import HsSyn
import Name
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index bf09e52..c65b357 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -13,7 +13,6 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
-import RdrName ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import HsSyn
import Name
@@ -34,7 +33,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
-- ^^^^^^^^^^ this part
-- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below.
-layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered)
+layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
@@ -199,7 +198,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend
- :: Located (Pat RdrName)
+ :: Located (Pat GhcPs)
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do
@@ -211,7 +210,7 @@ wrapPatPrepend pat prepElem = do
return $ x1' Seq.<| xR
wrapPatListy
- :: [Located (Pat RdrName)]
+ :: [Located (Pat GhcPs)]
-> String
-> String
-> ToBriDocM (Seq BriDocNumbered)
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
index 4128aea..70daf6c 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
@@ -13,7 +13,6 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
-import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import HsSyn
import Name
@@ -26,7 +25,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
-layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
+layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
docWrapNode lstmt $ case stmt of
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
index 0cb46be..faf583a 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
@@ -12,7 +12,6 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
-import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import HsSyn
import Name
@@ -21,4 +20,4 @@ import BasicTypes
-layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
+layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index 646f986..dfde7f5 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
@@ -13,7 +13,6 @@ import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
-import RdrName ( RdrName(..) )
import GHC ( runGhc
, GenLocated(L)
, moduleNameString
diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs
index dbd4b52..2d8a038 100644
--- a/src/Language/Haskell/Brittany/Internal/Prelude.hs
+++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs
@@ -1,8 +1,24 @@
-module Language.Haskell.Brittany.Internal.Prelude (module E)
+module Language.Haskell.Brittany.Internal.Prelude
+ ( module E
+ , module Language.Haskell.Brittany.Internal.Prelude
+ )
where
+-- rather project-specific stuff:
+---------------------------------
+#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
+import HsExtension as E ( GhcPs )
+#endif
+
+import RdrName as E ( RdrName )
+
+
+
+-- more general:
+----------------
+
import Data.Functor.Identity as E ( Identity(..) )
import Control.Concurrent.Chan as E ( Chan )
import Control.Concurrent.MVar as E ( MVar )
@@ -379,3 +395,10 @@ import Control.Monad.Trans.Maybe as E ( MaybeT (..)
import Data.Data as E ( toConstr
)
+todo :: a
+todo = error "todo"
+
+
+#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */
+type GhcPs = RdrName
+#endif
diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs
index 1d26b73..9bea756 100644
--- a/src/Language/Haskell/Brittany/Internal/Types.hs
+++ b/src/Language/Haskell/Brittany/Internal/Types.hs
@@ -16,7 +16,6 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Data.Text.Lazy.Builder as Text.Builder
-import RdrName ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId )
import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment )
@@ -190,9 +189,9 @@ data BrIndent = BrIndentNone
type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex]
-type ToBriDoc (sym :: * -> *) = Located (sym RdrName) -> ToBriDocM BriDocNumbered
-type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
-type ToBriDocC sym c = Located sym -> ToBriDocM c
+type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
+type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
+type ToBriDocC sym c = Located sym -> ToBriDocM c
data DocMultiLine
= MultiLineNo