hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Add support for ghc-8.4

pull/141/head
Lennart Spitzner 2018-04-17 17:00:55 +02:00
parent ac76b69127
commit 10e1c19788
17 changed files with 159 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
.travis.yml
View File

@ -73,9 +73,12 @@ matrix:
- env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #cabal 8.0.2" 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]}} 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 - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #cabal 8.2.1" compiler: ": #cabal 8.2.2"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 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, # Build with the newest GHC and cabal-install. This is an accepted failure,
# see below. # see below.
@ -85,15 +88,15 @@ matrix:
##### CABAL DIST CHECK ##### CABAL DIST CHECK
- env: BUILD=cabaldist GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=cabaldist GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #cabal 8.2.1 dist" compiler: ": #cabal 8.2.2 dist"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
##### CANEW ##### ##### CANEW #####
- env: BUILD=canew GHCVER=8.2.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=canew GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #cabal new 8.2.1" compiler: ": #cabal new 8.2.2"
addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
##### STACK ##### ##### STACK #####
@ -118,6 +121,9 @@ matrix:
- env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml" - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml"
compiler: ": #stack 8.0.2" compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}} 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 # Nightly builds are allowed to fail
- env: BUILD=stack ARGS="--resolver nightly" - env: BUILD=stack ARGS="--resolver nightly"

6
brittany.cabal
View File

@ -82,8 +82,8 @@ library {
-fno-warn-redundant-constraints -fno-warn-redundant-constraints
} }
build-depends: build-depends:
{ base >=4.9 && <4.11 { base >=4.9 && <4.12
, ghc >=8.0.1 && <8.3 , ghc >=8.0.1 && <8.5
, ghc-paths >=0.1.0.9 && <0.2 , ghc-paths >=0.1.0.9 && <0.2
, ghc-exactprint >=0.5.6.0 && <0.5.7 , ghc-exactprint >=0.5.6.0 && <0.5.7
, transformers >=0.5.2.0 && <0.6 , transformers >=0.5.2.0 && <0.6
@ -110,7 +110,7 @@ library {
, semigroups >=0.18.2 && <0.19 , semigroups >=0.18.2 && <0.19
, cmdargs >=0.10.14 && <0.11 , cmdargs >=0.10.14 && <0.11
, czipwith >=1.0.1.0 && <1.1 , 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 , filepath >=1.4.1.0 && <1.5
} }
default-extensions: { default-extensions: {

11
src/Language/Haskell/Brittany/Internal.hs
View File

@ -47,7 +47,6 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC hiding (parseModule) import qualified GHC as GHC hiding (parseModule)
import ApiAnnotation ( AnnKeywordId(..) ) import ApiAnnotation ( AnnKeywordId(..) )
import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import HsSyn import HsSyn
@ -248,7 +247,7 @@ parsePrintModuleTests conf filename input = do
-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- else return $ TextL.toStrict $ Text.Builder.toLazyText out -- 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 ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
post <- ppPreamble lmod post <- ppPreamble lmod
decls `forM_` \decl -> do decls `forM_` \decl -> do
@ -302,7 +301,7 @@ withTransformedAnns ast m = do
in annsBalanced in annsBalanced
ppDecl :: LHsDecl RdrName -> PPMLocal () ppDecl :: LHsDecl GhcPs -> PPMLocal ()
ppDecl d@(L loc decl) = case decl of ppDecl d@(L loc decl) = case decl of
SigD sig -> -- trace (_sigHead sig) $ SigD sig -> -- trace (_sigHead sig) $
withTransformedAnns d $ do withTransformedAnns d $ do
@ -322,7 +321,7 @@ ppDecl d@(L loc decl) = case decl of
-- Prints the information associated with the module annotation -- Prints the information associated with the module annotation
-- This includes the imports -- This includes the imports
ppPreamble :: GenLocated SrcSpan (HsModule RdrName) ppPreamble :: GenLocated SrcSpan (HsModule GhcPs)
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
filteredAnns <- mAsk <&> \annMap -> filteredAnns <- mAsk <&> \annMap ->
@ -390,13 +389,13 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
return post return post
_sigHead :: Sig RdrName -> String _sigHead :: Sig GhcPs -> String
_sigHead = \case _sigHead = \case
TypeSig names _ -> TypeSig names _ ->
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig" _ -> "unknown sig"
_bindHead :: HsBind RdrName -> String _bindHead :: HsBind GhcPs -> String
_bindHead = \case _bindHead = \case
FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _pat _ _ _ ([], []) -> "PatBind smth" PatBind _pat _ _ _ ([], []) -> "PatBind smth"

3
src/Language/Haskell/Brittany/Internal/Config.hs
View File

@ -38,6 +38,7 @@ import Language.Haskell.Brittany.Internal.Config.Types.Instances
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Data.Coerce ( Coercible, coerce ) import Data.Coerce ( Coercible, coerce )
import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Directory as Directory import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath import qualified System.FilePath.Posix as FilePath
@ -272,7 +273,7 @@ readConfigs
-> MaybeT IO Config -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths 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 return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs -- | Reads provided configs

20
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -29,10 +29,9 @@ import qualified GHC as GHC hiding (parseModule)
import qualified Lexer as GHC import qualified Lexer as GHC
import qualified StringBuffer as GHC import qualified StringBuffer as GHC
import qualified Outputable as GHC import qualified Outputable as GHC
import RdrName ( RdrName(..) ) import qualified CmdLineParser as GHC
import HsSyn import HsSyn
import SrcLoc ( SrcSpan, Located ) import SrcLoc ( SrcSpan, Located )
import RdrName ( RdrName(..) )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@ -79,7 +78,7 @@ parseModuleWithCpp cpp opts args fp dynCheck =
when (not $ null warnings) when (not $ null warnings)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: " $ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> \(L _ s) -> s) ++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
@ -111,7 +110,7 @@ parseModuleFromString args fp dynCheck str =
when (not $ null warnings) when (not $ null warnings)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: " $ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> \(L _ s) -> s) ++ show (warnings <&> warnExtractorCompat)
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of case res of
@ -187,7 +186,7 @@ commentAnnFixTransform modul = SYB.everything (>>) genF modul
where where
genF :: Data.Data.Data a => a -> ExactPrint.Transform () genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
genF = (\_ -> return ()) `SYB.extQ` exprF genF = (\_ -> return ()) `SYB.extQ` exprF
exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform () exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
exprF lexpr@(L _ expr) = case expr of exprF lexpr@(L _ expr) = case expr of
RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->
moveTrailingComments lexpr (List.last fs) moveTrailingComments lexpr (List.last fs)
@ -226,7 +225,7 @@ moveTrailingComments astFrom astTo = do
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have. -- implementation would have.
extractToplevelAnns extractToplevelAnns
:: Located (HsModule RdrName) :: Located (HsModule GhcPs)
-> ExactPrint.Anns -> ExactPrint.Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns -> Map ExactPrint.AnnKey ExactPrint.Anns
extractToplevelAnns lmod anns = output extractToplevelAnns lmod anns = output
@ -265,3 +264,12 @@ foldedAnnKeys ast = SYB.everything
) )
ast ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) 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

70
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -20,7 +20,6 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import HsSyn import HsSyn
@ -88,11 +87,7 @@ layoutSig lsig@(L _loc sig) = case sig of
InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> InlineSig name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
let specStr = case spec of specStr <- specStringCompat lsig spec
Inline -> "INLINE "
Inlinable -> "INLINABLE "
NoInline -> "NOINLINE "
EmptyInlineSpec -> "" -- i have no idea if this is correct.
let phaseStr = case phaseAct of let phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default -- in fact the default
@ -108,7 +103,23 @@ layoutSig lsig@(L _loc sig) = case sig of
<> Text.pack " #-}" <> Text.pack " #-}"
_ -> briDocByExactNoComment lsig -- TODO _ -> 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 layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt body _ _ _ -> layoutExpr body BodyStmt body _ _ _ -> layoutExpr body
BindStmt lPat expr _ _ _ -> do BindStmt lPat expr _ _ _ -> do
@ -122,7 +133,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
layoutBind layoutBind
:: ToBriDocC :: ToBriDocC
(HsBindLR RdrName RdrName) (HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered) (Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of layoutBind lbind@(L _ bind) = case bind of
FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
@ -148,15 +159,15 @@ layoutBind lbind@(L _ bind) = case bind of
hasComments hasComments
_ -> Right <$> unknownNodeError "" lbind _ -> Right <$> unknownNodeError "" lbind
data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName) data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
| BagSig (LSig RdrName) | BagSig (LSig GhcPs)
bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds layoutLocalBinds
:: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered]) :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
layoutLocalBinds lbinds@(L _ binds) = case binds of layoutLocalBinds lbinds@(L _ binds) = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) -> -- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- 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 x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x
EmptyLocalBinds -> return $ Nothing 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 -- parSpacing stuff.B
layoutGrhs layoutGrhs
:: LGRHS RdrName (LHsExpr RdrName) :: LGRHS GhcPs (LHsExpr GhcPs)
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)
layoutGrhs lgrhs@(L _ (GRHS guards body)) = do layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body bodyDoc <- layoutExpr body
@ -191,12 +202,14 @@ layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
layoutPatternBind layoutPatternBind
:: Maybe Text :: Maybe Text
-> BriDocNumbered -> BriDocNumbered
-> LMatch RdrName (LHsExpr RdrName) -> LMatch GhcPs (LHsExpr GhcPs)
-> ToBriDocM BriDocNumbered -> 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 patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match let isInfix = isInfixMatch match
let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
(Just idStr, p1 : pr) | isInfix -> docCols (Just idStr, p1 : pr) | isInfix -> docCols
ColPatternsFuncInfix ColPatternsFuncInfix
@ -222,25 +235,26 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (
mWhereDocs mWhereDocs
hasComments 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 fixPatternBindIdentifier
:: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier ctx idStr = case ctx of fixPatternBindIdentifier match idStr = go $ m_ctxt match
where
go = \case
(FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
(FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
(FunRhs _ _ NoSrcStrict) -> idStr (FunRhs _ _ NoSrcStrict) -> idStr
(StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1 (StmtCtxt ctx1 ) -> goInner ctx1
_ -> idStr _ -> idStr
where
-- I have really no idea if this path ever occurs, but better safe than -- I have really no idea if this path ever occurs, but better safe than
-- risking another "drop bangpatterns" bugs. -- risking another "drop bangpatterns" bugs.
fixPatternBindIdentifier' = \case goInner = \case
(PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr (PatGuard ctx1) -> go ctx1
(ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 (ParStmtCtxt ctx1) -> goInner ctx1
(TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 (TransStmtCtxt ctx1) -> goInner ctx1
_ -> idStr _ -> idStr
#else /* ghc-8.0 */ #else /* ghc-8.0 */
fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier _ x = x fixPatternBindIdentifier _ x = x
#endif #endif
@ -248,7 +262,7 @@ layoutPatternBindFinal
:: Maybe Text :: Maybe Text
-> BriDocNumbered -> BriDocNumbered
-> Maybe BriDocNumbered -> Maybe BriDocNumbered
-> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]
-> Maybe [BriDocNumbered] -> Maybe [BriDocNumbered]
-> Bool -> Bool
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered

42
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

@ -15,8 +15,7 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..), RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )
import HsSyn import HsSyn
import Name import Name
import qualified FastString import qualified FastString
@ -56,7 +55,12 @@ layoutExpr lexpr@(L _ expr) = do
allocateNode $ overLitValBriDoc olit allocateNode $ overLitValBriDoc olit
HsLit lit -> do HsLit lit -> do
allocateNode $ litBriDoc lit 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 patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
let funcPatternPartLine = let funcPatternPartLine =
@ -112,7 +116,7 @@ layoutExpr lexpr@(L _ expr) = do
(docLit $ Text.pack "\\case") (docLit $ Text.pack "\\case")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
HsApp exp1@(L _ HsApp{}) exp2 -> do 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 gather list = \case
L _ (HsApp l r) -> gather (r:list) l L _ (HsApp l r) -> gather (r:list) l
x -> (x, list) x -> (x, list)
@ -220,7 +224,7 @@ layoutExpr lexpr@(L _ expr) = do
-- TODO -- TODO
briDocByExactInlineOnly "HsAppTypeOut{}" lexpr briDocByExactInlineOnly "HsAppTypeOut{}" lexpr
OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do 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 gather opExprList = \case
(L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1
final -> (final, opExprList) final -> (final, opExprList)
@ -1077,7 +1081,31 @@ layoutExpr lexpr@(L _ expr) = do
#endif #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 :: HsLit -> BriDocFInt
litBriDoc = \case litBriDoc = \case
HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] 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 HsFractional (FL t _) -> BDFLit $ Text.pack t
HsIsString (SourceText t) _ -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t
_ -> error "overLitValBriDoc: literal with no SourceText" _ -> error "overLitValBriDoc: literal with no SourceText"
#else #else /* ghc-8.0 */
litBriDoc :: HsLit -> BriDocFInt litBriDoc :: HsLit -> BriDocFInt
litBriDoc = \case litBriDoc = \case
HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']

7
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
View File

@ -14,7 +14,6 @@ where
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import HsSyn import HsSyn
import Name import Name
@ -23,8 +22,12 @@ import Name
layoutExpr :: ToBriDoc HsExpr 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 litBriDoc :: HsLit -> BriDocFInt
#endif
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt

5
src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -11,7 +11,6 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName (RdrName(..))
import GHC ( unLoc import GHC ( unLoc
, runGhc , runGhc
, GenLocated(L) , GenLocated(L)
@ -89,7 +88,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
-- handling of the resulting list. Adding parens is -- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive -- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs layoutAnnAndSepLLIEs
:: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered] :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs llies@(L _ lies) = do layoutAnnAndSepLLIEs llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie] let makeIENode ie = docSeq [docCommaSep, ie]
let ieDocs = layoutIE <$> lies let ieDocs = layoutIE <$> lies
@ -114,7 +113,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do
-- () -- no comments -- () -- no comments
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline llies = do layoutLLIEs enableSingleline llies = do
ieDs <- layoutAnnAndSepLLIEs llies ieDs <- layoutAnnAndSepLLIEs llies
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies

1
src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -7,7 +7,6 @@ import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName ( RdrName(..) )
import GHC ( unLoc import GHC ( unLoc
, GenLocated(L) , GenLocated(L)
, moduleNameString , moduleNameString

1
src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -8,7 +8,6 @@ import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName (RdrName(..))
import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import HsSyn import HsSyn
import Name import Name

7
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -13,7 +13,6 @@ where
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import RdrName ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import HsSyn import HsSyn
import Name import Name
@ -34,7 +33,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
-- ^^^^^^^^^^ this part -- ^^^^^^^^^^ this part
-- We will use `case .. of` as the imagined prefix to the examples used in -- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below. -- 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 layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr -- _ -> expr
@ -199,7 +198,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend wrapPatPrepend
:: Located (Pat RdrName) :: Located (Pat GhcPs)
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered) -> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do wrapPatPrepend pat prepElem = do
@ -211,7 +210,7 @@ wrapPatPrepend pat prepElem = do
return $ x1' Seq.<| xR return $ x1' Seq.<| xR
wrapPatListy wrapPatListy
:: [Located (Pat RdrName)] :: [Located (Pat GhcPs)]
-> String -> String
-> String -> String
-> ToBriDocM (Seq BriDocNumbered) -> ToBriDocM (Seq BriDocNumbered)

3
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
View File

@ -13,7 +13,6 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import HsSyn import HsSyn
import Name 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 layoutStmt lstmt@(L _ stmt) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
docWrapNode lstmt $ case stmt of docWrapNode lstmt $ case stmt of

3
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
View File

@ -12,7 +12,6 @@ where
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import HsSyn import HsSyn
import Name import Name
@ -21,4 +20,4 @@ import BasicTypes
layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))

1
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -13,7 +13,6 @@ import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import RdrName ( RdrName(..) )
import GHC ( runGhc import GHC ( runGhc
, GenLocated(L) , GenLocated(L)
, moduleNameString , moduleNameString

25
src/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -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 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 Data.Functor.Identity as E ( Identity(..) )
import Control.Concurrent.Chan as E ( Chan ) import Control.Concurrent.Chan as E ( Chan )
import Control.Concurrent.MVar as E ( MVar ) 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 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

3
src/Language/Haskell/Brittany/Internal/Types.hs
View File

@ -16,7 +16,6 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import RdrName ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId )
import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment )
@ -190,7 +189,7 @@ data BrIndent = BrIndentNone
type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex] type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex]
type ToBriDoc (sym :: * -> *) = Located (sym RdrName) -> ToBriDocM BriDocNumbered type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c type ToBriDocC sym c = Located sym -> ToBriDocM c