brittany 0.12.0.0 → 0.12.1.0
raw patch · 15 files changed
+459/−201 lines, 15 filesdep ~basedep ~ghcdep ~ghc-boot-thPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, ghc, ghc-boot-th, ghc-exactprint, semigroups
API changes (from Hackage documentation)
+ Language.Haskell.Brittany.Internal.Prelude: ghcDL :: Located a -> Located a
Files
- ChangeLog.md +20/−0
- README.md +19/−24
- brittany.cabal +12/−7
- src-brittany/Main.hs +45/−40
- src-literatetests/10-tests.blt +51/−0
- src-literatetests/14-extensions.blt +26/−0
- src-literatetests/15-regressions.blt +13/−1
- src-unittests/AsymptoticPerfTests.hs +1/−1
- src/Language/Haskell/Brittany/Internal/Backend.hs +3/−7
- src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +4/−1
- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +86/−12
- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +89/−45
- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +20/−9
- src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +57/−53
- src/Language/Haskell/Brittany/Internal/Prelude.hs +13/−1
ChangeLog.md view
@@ -1,5 +1,25 @@ # Revision history for brittany +## 0.12.1.0 -- September 2019++* Support ghc-8.8+* Support for OverloadedLabels extension+ (thanks to Evan Rutledge Borden @eborden)+* Support for Implicit Params extension (thanks to pepe iborra @pepeiborra)+* Add flag `--no-user-config` to enable only using manually passed config+* Disable the performance test suite by default to prevent spurious failures+ on certain CI setups. The github/travis brittany CI still has all tests+ enabled. See the `brittany-test-perf` flag in the cabal file.+* Bugfixes:+ - Fix one wandering-comment bug for let-in expressions+ - Fix invalid result for prefix operator pattern matches+ - Fix lambda expression with laziness/strictness annotation+ - Fix parenthesis handling for infix pattern matches with 3+ arguments+* Changes to layouting behaviour:+ - For pattern matching and data/instance definitions, the usage of+ parenthesis is now "normalized", i.e. superfluous parens are removed by+ brittany.+ ## 0.12.0.0 -- June 2019 * Support for ghc-8.6 (basic support, not necessarily all new syntactic
README.md view
@@ -13,7 +13,7 @@ (but excluding `-XCPP` which is too hard); - Retain newlines and comments unmodified; - Be clever about using the available horizontal space while not overflowing- the column maximum if it cannot be avoided;+ the column maximum unless it cannot be avoided; - Be clever about aligning things horizontally (this can be turned off completely however); - Have linear complexity in the size of the input.@@ -74,32 +74,27 @@ nix-env -i ./result ~~~ -- via `cabal v1-build`-- ~~~~.sh- # optionally:- # mkdir brittany- # cd brittany- # cabal sandbox init- cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_x- ~~~~--- via `cabal v2-install`+- via `cabal` - ~~~~.sh- cabal v2-install brittany- ~~~~+ Due to constant changes to the cabal UI, I have given up on making sure+ these instructions work before releases. Please do not expect these+ instructions to be up-to-date; they may produce incomprehensible error+ messages, they may be broken otherwise, they may work now but break with+ the next cabal release. Thanks for your understanding, and feel free to+ open issues for any problems you encounter. -- lennart -- via `cabal v2-build`, should v2-install not work:+ If you are using cabal-3.0, using+ `cabal install brittany --installdir=$HOME/.cabal/bin`+ might work. Keep in mind that cabal merely puts a symlink to the "store"+ into the installdir, so you have to re-install if you ever clean your+ store. On cabal-2.4, try `cabal v2-install brittany`. On cabal-2.2 or+ earlier you might be succesful using+ ```cabal new-build exe:brittany; cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/```.+ Alternatively, you can also use the v1-approach with sandboxes as+ `cabal v1-sandbox init; cabal v1-install brittany --bindir=$HOME/.cabal/bin`. - ~~~~.sh- cabal unpack brittany- cd brittany-0.11.0.0- # cabal new-configure -w $PATH_TO_GHC_8_x- cabal new-build exe:brittany- # and it should be safe to just copy the executable, e.g.- cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/- ~~~~+ (TODO: These instructions are more confusing than helpful. I am inclined+ to just remove them.) - on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`:
brittany.cabal view
@@ -1,5 +1,5 @@ name: brittany-version: 0.12.0.0+version: 0.12.1.0 synopsis: Haskell source code formatter description: { See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.@@ -39,6 +39,11 @@ default: False manual: True +flag brittany-test-perf+ description: determines if performance test suite is enabled+ default: False+ manual: True+ library { default-language: Haskell2010@@ -84,10 +89,10 @@ -fno-warn-redundant-constraints } build-depends:- { base >=4.9 && <4.13- , ghc >=8.0.1 && <8.7+ { base >=4.9 && <4.14+ , ghc >=8.0.1 && <8.9 , ghc-paths >=0.1.0.9 && <0.2- , ghc-exactprint >=0.5.8 && <0.6.2+ , ghc-exactprint >=0.5.8 && <0.6.3 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3@@ -109,10 +114,10 @@ , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5- , semigroups >=0.18.2 && <0.19+ , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1- , ghc-boot-th >=8.0.1 && <8.7+ , ghc-boot-th >=8.0.1 && <8.9 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 }@@ -205,7 +210,7 @@ } test-suite unittests- if flag(brittany-dev-lib) {+ if flag(brittany-dev-lib) || !flag(brittany-test-perf) { buildable: False } else { buildable: True
src-brittany/Main.hs view
@@ -57,8 +57,7 @@ instance Read WriteMode where readPrec = val "display" Display <|> val "inplace" Inplace- where- val iden v = ReadPrec.lift $ ReadP.string iden >> return v+ where val iden v = ReadPrec.lift $ ReadP.string iden >> return v instance Show WriteMode where show Display = "display"@@ -114,7 +113,8 @@ licenseDoc :: PP.Doc licenseDoc = PP.vcat $ List.intersperse (PP.text "")- [ parDoc $ "Copyright (C) 2016-2017 Lennart Spitzner"+ [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner"+ , parDoc $ "Copyright (C) 2019 PRODA LTD" , parDocW [ "This program is free software: you can redistribute it and/or modify" , "it under the terms of the GNU Affero General Public License,"@@ -146,6 +146,7 @@ printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty+ noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty configPaths <- addFlagStringParams "" ["config-file"] "PATH"@@ -165,11 +166,11 @@ "c" ["check-mode"] (flagHelp- (PP.vcat- [ PP.text "check for changes but do not write them out"- , PP.text "exits with code 0 if no changes necessary, 1 otherwise"- ]- )+ (PP.vcat+ [ PP.text "check for changes but do not write them out"+ , PP.text "exits with code 0 if no changes necessary, 1 otherwise"+ ]+ ) ) writeMode <- addFlagReadParam ""@@ -194,7 +195,8 @@ when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version- putStrLn $ "Copyright (C) 2016-2018 Lennart Spitzner"+ putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner"+ putStrLn $ "Copyright (C) 2019 PRODA LTD" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do@@ -216,7 +218,11 @@ else pure configPaths config <-- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad)+ runMaybeT+ (if noUserConfig+ then readConfigs cmdlineConfig configsToLoad+ else readConfigsWithUserConfig cmdlineConfig configsToLoad+ ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x@@ -224,17 +230,18 @@ $ trace (showConfigYaml config) $ return () - results <- zipWithM (coreIO putStrErrLn config (suppressOutput || checkMode))- inputPaths- outputPaths+ results <- zipWithM+ (coreIO putStrErrLn config (suppressOutput || checkMode))+ inputPaths+ outputPaths if checkMode- then when (any (==Changes) (Data.Either.rights results)) $- System.Exit.exitWith (System.Exit.ExitFailure 1)+ then when (any (== Changes) (Data.Either.rights results))+ $ System.Exit.exitWith (System.Exit.ExitFailure 1) else case results of- xs | all Data.Either.isRight xs -> pure ()- [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)- _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)+ xs | all Data.Either.isRight xs -> pure ()+ [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)+ _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) data ChangeStatus = Changes | NoChanges@@ -276,20 +283,19 @@ viaDebug = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let- cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags- then case cppMode of- CPPModeAbort -> do- return $ Left "Encountered -XCPP. Aborting."- CPPModeWarn -> do- putErrorLnIO- $ "Warning: Encountered -XCPP."- ++ " Be warned that -XCPP is not supported and that"- ++ " brittany cannot check that its output is syntactically"- ++ " valid in its presence."- return $ Right True- CPPModeNowarn -> return $ Right True- else return $ Right False+ let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags+ then case cppMode of+ CPPModeAbort -> do+ return $ Left "Encountered -XCPP. Aborting."+ CPPModeWarn -> do+ putErrorLnIO+ $ "Warning: Encountered -XCPP."+ ++ " Be warned that -XCPP is not supported and that"+ ++ " brittany cannot check that its output is syntactically"+ ++ " valid in its presence."+ return $ Right True+ CPPModeNowarn -> return $ Right True+ else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic@@ -306,7 +312,7 @@ (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do- parseRes <- parseModule ghcOptions p cppCheckFunc+ parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it@@ -357,13 +363,12 @@ let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s- let- out = TextL.toStrict $ if hackAroundIncludes- then- TextL.intercalate (TextL.pack "\n")- $ fmap hackF- $ TextL.splitOn (TextL.pack "\n") outRaw- else outRaw+ let out = TextL.toStrict $ if hackAroundIncludes+ then+ TextL.intercalate (TextL.pack "\n")+ $ fmap hackF+ $ TextL.splitOn (TextL.pack "\n") outRaw+ else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out
src-literatetests/10-tests.blt view
@@ -330,7 +330,16 @@ #test symbol prefix (***) x y = x +#test infix more args simple+(f >=> g) k = f k >>= g +#test infix more args alignment+(Left a <$$> Left dd) e f = True+(Left a <$$> Right d ) e f = True+(Right a <$$> Left d ) e f = False+(Right a <$$> Right dd) e f = True++ ############################################################################### ############################################################################### ###############################################################################@@ -612,7 +621,40 @@ _ -> True ] +###############################################################################+###############################################################################+###############################################################################+#group expression.let+###############################################################################+###############################################################################+############################################################################### +#test single-bind-comment-long+testMethod foo bar baz qux =+ let x = undefined foo bar baz qux qux baz bar :: String+ -- some comment explaining the in expression+ in undefined foo x :: String++#test single-bind-comment-short+testMethod foo bar baz qux =+ let x = undefined :: String+ -- some comment explaining the in expression+ in undefined :: String++#test single-bind-comment-before+testMethod foo bar baz qux =+ -- some comment explaining the in expression+ let x = undefined :: String in undefined :: String++#test multiple-binds-comment+foo foo bar baz qux =+ let a = 1+ b = 2+ c = 3+ -- some comment explaining the in expression+ in undefined :: String++ ############################################################################### ############################################################################### ###############################################################################@@ -1065,6 +1107,13 @@ instance MyClass Int where myMethod x = x + 1 +#test simple-method-comment++instance MyClass Int where+ myMethod x =+ -- insightful comment+ x + 1+ #test simple-method-signature instance MyClass Int where@@ -1213,6 +1262,7 @@ type instance MyFam (Maybe a) = a -> Bool #test simple-typefam-instance-parens+#pending the parens cause problems since ghc-8.8 type instance (MyFam (String -> Int)) = String @@ -1230,6 +1280,7 @@ = AnotherType -- Here's another #test simple-typefam-instance-parens-comment+#pending the parens cause problems since ghc-8.8 -- | A happy family type instance (MyFam Bool) -- This is an odd one
src-literatetests/14-extensions.blt view
@@ -130,3 +130,29 @@ hello |] pure True++###############################################################################+## OverloadedLabels+#test bare label+{-# LANGUAGE OverloadedLabels #-}+foo = #bar++#test applied and composed label+{-# LANGUAGE OverloadedLabels #-}+foo = #bar . #baz $ fmap #foo xs++###############################################################################+## ImplicitParams++#test IP usage+{-# LANGUAGE ImplicitParams #-}+foo = ?bar++#test IP binding+{-# LANGUAGE ImplicitParams #-}+foo = let ?bar = Foo in value++#test IP type signature+{-# LANGUAGE ImplicitParams #-}+foo :: (?bar::Bool) => ()+foo = ()
src-literatetests/15-regressions.blt view
@@ -607,7 +607,7 @@ go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 #test issue 89 - type-family-instance-type instance (XPure StageParse) = ()+type instance XPure StageParse = () type Pair a = (a, a) #test issue 144@@ -668,3 +668,15 @@ nor False False = True _ `nor` _ = False++#test issue 256 prefix operator match++f ((:) a as) = undefined++#test issue 228 lambda plus lazy or bang pattern++{-# LANGUAGE BangPatterns #-}+a = \x -> x+b = \ ~x -> x+c = \ !x -> x+d = \(~x) -> x
src-unittests/AsymptoticPerfTests.hs view
@@ -22,7 +22,7 @@ asymptoticPerfTest :: Spec asymptoticPerfTest = do it "1000 do statements"- $ roundTripEqualWithTimeout 1000000+ $ roundTripEqualWithTimeout 1500000 $ (Text.pack "func = do\n") <> Text.replicate 1000 (Text.pack " statement\n") it "1000 do nestings"
src/Language/Haskell/Brittany/Internal/Backend.hs view
@@ -173,14 +173,10 @@ -- layoutResetSepSpace priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->- do+ when (not $ comment == "(" || comment == ")") $ do case comment of ('#':_) -> layoutMoveToCommentPos y (-999) -- ^ evil hack for CPP- "(" -> pure ()- ")" -> pure ()- -- ^ these two fix the formatting of parens- -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline@@ -217,7 +213,7 @@ Nothing -> pure () Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->- do+ when (not $ comment == "(" || comment == ")") $ do -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999)@@ -251,7 +247,7 @@ Nothing -> pure () Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->- do+ when (not $ comment == "(" || comment == ")") $ do case comment of ('#':_) -> layoutMoveToCommentPos y (-999) -- ^ evil hack for CPP
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs view
@@ -276,7 +276,10 @@ Set.singleton [ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)- , l <- SYB.gmapQi 0 SYB.cast x+ , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x+ -- for some reason, ghc-8.8 has forgotten how to infer the type of l,+ -- even though it is passed to mkAnnKey above, which only accepts+ -- SrcSpan. ] ) ast
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs view
@@ -20,6 +20,7 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types+import Language.Haskell.Brittany.Internal.Layouters.Type import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint@@ -32,6 +33,7 @@ , AnnKeywordId(..) ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )+import qualified FastString import HsSyn #if MIN_VERSION_ghc(8,6,0) import HsExtension (NoExt (..))@@ -231,6 +233,23 @@ hasComments _ -> Right <$> unknownNodeError "" lbind +layoutIPBind :: ToBriDoc IPBind+layoutIPBind lipbind@(L _ bind) = case bind of+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ XIPBind{} -> unknownNodeError "XIPBind" lipbind+ IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"+ IPBind _ (Left (L _ (HsIPName name))) expr -> do+#else+ IPBind (Right _) _ -> error "brittany internal error: IPBind Right"+ IPBind (Left (L _ (HsIPName name))) expr -> do+#endif+ ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name+ binderDoc <- docLit $ Text.pack "="+ exprDoc <- layoutExpr expr+ hasComments <- hasAnyCommentsBelow lipbind+ layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments++ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) | BagSig (LSig GhcPs) @@ -268,8 +287,14 @@ Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" (L noSrcSpan x) #endif- x@(HsIPBinds{}) ->- Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x)+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ x@(HsIPBinds _ XHsIPBinds{}) ->+ Just . (: []) <$> unknownNodeError "XHsIPBinds" (L noSrcSpan x)+ HsIPBinds _ (IPBinds _ bb) ->+#else+ HsIPBinds (IPBinds bb _) ->+#endif+ Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is@@ -316,11 +341,25 @@ _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of- (Just idStr, p1 : pr) | isInfix -> docCols- ColPatternsFuncInfix- ( [appSep $ docForceSingleline p1, appSep $ docLit idStr]- ++ (spacifyDocs $ docForceSingleline <$> pr)- )+ (Just idStr, p1:p2:pr) | isInfix -> if null pr+ then+ docCols ColPatternsFuncInfix+ [ appSep $ docForceSingleline p1+ , appSep $ docLit $ idStr+ , docForceSingleline p2+ ]+ else+ docCols ColPatternsFuncInfix+ ( [docCols ColPatterns+ [ docParenL+ , appSep $ docForceSingleline p1+ , appSep $ docLit $ idStr+ , docForceSingleline p2+ , appSep $ docParenR+ ]+ ]+ ++ (spacifyDocs $ docForceSingleline <$> pr)+ ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix@@ -719,7 +758,7 @@ let (a : b : rest) = vars hasOwnParens <- hasAnnKeywordComment a AnnOpenP -- This isn't quite right, but does give syntactically valid results- let needsParens = not $ null rest || hasOwnParens+ let needsParens = not (null rest) || hasOwnParens docSeq $ [ docLit $ Text.pack "type" , docSeparator@@ -776,24 +815,36 @@ -- TyFamInstDecl -------------------------------------------------------------------------------- ++ layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl layoutTyFamInstDecl inClass (L loc tfid) = do let-#if MIN_VERSION_ghc(8,6,0)+#if MIN_VERSION_ghc(8,8,0) linst = L loc (TyFamInstD NoExt tfid)+ feqn@(FamEqn _ name bndrsMay pats _fixity typ) = hsib_body $ tfid_eqn tfid+ -- bndrsMay isJust e.g. with+ -- type instance forall a . MyType (Maybe a) = Either () a+ lfeqn = L loc feqn+#elif MIN_VERSION_ghc(8,6,0)+ linst = L loc (TyFamInstD NoExt tfid) feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid+ bndrsMay = Nothing lfeqn = L loc feqn #elif MIN_VERSION_ghc(8,4,0) linst = L loc (TyFamInstD tfid) feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid+ bndrsMay = Nothing lfeqn = L loc feqn #elif MIN_VERSION_ghc(8,2,0) linst = L loc (TyFamInstD tfid) lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid+ bndrsMay = Nothing pats = hsib_body boundPats #else linst = L loc (TyFamInstD tfid) lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid+ bndrsMay = Nothing pats = hsib_body boundPats #endif docWrapNodePrior linst $ do@@ -804,15 +855,23 @@ then docLit $ Text.pack "type" else docSeq [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]+ makeForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered+ makeForallDoc bndrs = do+ bndrDocs <- layoutTyVarBndrs bndrs+ docSeq+ ( [docLit (Text.pack "forall")]+ ++ processTyVarBndrsSingleline bndrDocs+ ) lhs = docWrapNode lfeqn . appSep . docWrapNodeRest linst . docSeq- $ (appSep instanceDoc :)- $ [ docParenL | needsParens ]+ $ [appSep instanceDoc]+ ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]+ ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr]- ++ intersperse docSeparator (layoutType <$> pats)+ ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] hasComments <- (||) <$> hasAnyRegularCommentsConnected lfeqn@@ -821,6 +880,20 @@ layoutLhsAndType hasComments lhs "=" typeDoc +#if MIN_VERSION_ghc(8,8,0)+layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]+layoutHsTyPats pats = pats <&> \case+ HsValArg tm -> layoutType tm+ HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]+ -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change+ -- is a bit strange. Hopefully this does not ignore any important+ -- annotations.+ HsArgPar _l -> error "brittany internal error: HsArgPar{}"+#else+layoutHsTyPats :: [LHsType GhcPs] -> [ToBriDocM BriDocNumbered]+layoutHsTyPats pats = layoutType <$> pats+#endif+ -------------------------------------------------------------------------------- -- ClsInstDecl --------------------------------------------------------------------------------@@ -834,6 +907,7 @@ layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular+ $ docSetIndentLevel $ docSortedLines $ fmap layoutAndLocateSig (cid_sigs cid) ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid)
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Expr ( layoutExpr@@ -55,13 +56,23 @@ HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr- HsOverLabel{} -> do- -- TODO- briDocByExactInlineOnly "HsOverLabel{}" lexpr- HsIPVar{} -> do- -- TODO- briDocByExactInlineOnly "HsOverLabel{}" lexpr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ HsOverLabel _ext _reboundFromLabel name ->+#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */+ HsOverLabel _reboundFromLabel name ->+#else /* ghc-8.0 */+ HsOverLabel name ->+#endif+ let label = FastString.unpackFS name+ in docLit . Text.pack $ '#' : label+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ HsIPVar _ext (HsIPName name) ->+#else+ HsIPVar (HsIPName name) ->+#endif+ let label = FastString.unpackFS name+ in docLit . Text.pack $ '?' : label+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsOverLit _ olit -> do #else HsOverLit olit -> do@@ -91,7 +102,27 @@ , L _ (GRHS [] body) <- lgrhs #endif -> do- patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p+ patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->+ fmap return $ do+ -- this code could be as simple as `colsWrapPat =<< layoutPat p`+ -- if it was not for the following two cases:+ -- \ !x -> x+ -- \ ~x -> x+ -- These make it necessary to special-case an additional separator.+ -- (TODO: we create a BDCols here, but then make it ineffective+ -- by wrapping it in docSeq below. We _could_ add alignments for+ -- stuff like lists-of-lambdas. Nothing terribly important..)+ let shouldPrefixSeparator = case p of+ (ghcDL -> L _ LazyPat{}) -> isFirst+ (ghcDL -> L _ BangPat{}) -> isFirst+ _ -> False+ patDocSeq <- layoutPat p+ fixed <- case Seq.viewl patDocSeq of+ p1 Seq.:< pr | shouldPrefixSeparator -> do+ p1' <- docSeq [docSeparator, pure p1]+ pure (p1' Seq.<| pr)+ _ -> pure patDocSeq+ colsWrapPat fixed bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body let funcPatternPartLine = docCols ColCasePattern@@ -268,7 +299,11 @@ expDoc1 expDoc2 ]-#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */+ HsAppType _ _ XHsWildCardBndrs{} ->+ error "brittany internal error: HsAppType XHsWildCardBndrs"+ HsAppType _ exp1 (HsWC _ ty1) -> do+#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsAppType XHsWildCardBndrs{} _ -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType (HsWC _ ty1) exp1 -> do@@ -711,10 +746,10 @@ #else HsLet binds exp1 -> do #endif- expDoc1 <- docSharedWrapper layoutExpr exp1+ expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing.- mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return)- =<< layoutLocalBinds binds+ hasComments <- hasAnyCommentsBelow lexpr+ mBindDocs <- fmap (fmap (fmap pure)) $ layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a ifIndentFreeElse x y =@@ -731,37 +766,38 @@ -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. docSetBaseAndIndent $ case mBindDocs of- Just [bindDoc] -> docAlt- [ docSeq- [ appSep $ docLit $ Text.pack "let"- , appSep $ docForceSingleline bindDoc- , appSep $ docLit $ Text.pack "in"- , docForceSingleline expDoc1- ]- , docLines- [ docAlt- [ docSeq- [ appSep $ docLit $ Text.pack "let"- , ifIndentFreeElse docSetBaseAndIndent docForceSingleline- $ bindDoc- ]- , docAddBaseY BrIndentRegular- $ docPar- (docLit $ Text.pack "let")- (docSetBaseAndIndent bindDoc)- ]- , docAlt- [ docSeq- [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in"- , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1- ]- , docAddBaseY BrIndentRegular- $ docPar- (docLit $ Text.pack "in")- (docSetBaseY expDoc1)- ]- ]- ]+ Just [bindDoc] -> runFilteredAlternative $ do+ addAlternativeCond (not hasComments) $ docSeq+ [ appSep $ docLit $ Text.pack "let"+ , docNodeAnnKW lexpr (Just AnnLet)+ $ appSep $ docForceSingleline bindDoc+ , appSep $ docLit $ Text.pack "in"+ , docForceSingleline expDoc1+ ]+ addAlternative $ docLines+ [ docNodeAnnKW lexpr (Just AnnLet)+ $ docAlt+ [ docSeq+ [ appSep $ docLit $ Text.pack "let"+ , ifIndentFreeElse docSetBaseAndIndent docForceSingleline+ $ bindDoc+ ]+ , docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "let")+ (docSetBaseAndIndent bindDoc)+ ]+ , docAlt+ [ docSeq+ [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in"+ , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1+ ]+ , docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "in")+ (docSetBaseY expDoc1)+ ]+ ] Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let@@ -791,7 +827,8 @@ IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds IndentPolicyFree -> docLines- [ docSeq+ [ docNodeAnnKW lexpr (Just AnnLet)+ $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ]@@ -802,7 +839,8 @@ ] addAlternative $ docLines- [ docAddBaseY BrIndentRegular+ [ docNodeAnnKW lexpr (Just AnnLet)+ $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ bindDocs)@@ -1024,7 +1062,13 @@ Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) #endif recordExpression indentPolicy lexpr rExprDoc rFs-#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+#if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */+ ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) ->+ error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs"+ ExprWithTySig _ _ XHsWildCardBndrs{} ->+ error "brittany internal error: ExprWithTySig XHsWildCardBndrs"+ ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do+#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" ExprWithTySig XHsWildCardBndrs{} _ ->
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Pattern ( layoutPat@@ -13,7 +14,13 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, ol_val )+import GHC ( Located+ , runGhc+ , GenLocated(L)+ , moduleNameString+ , ol_val+ )+import qualified GHC import HsSyn import Name import BasicTypes@@ -33,8 +40,8 @@ -- ^^^^^^^^^^ this part -- We will use `case .. of` as the imagined prefix to the examples used in -- the different cases below.-layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered)-layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of+layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)+layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */@@ -51,8 +58,10 @@ #endif fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr-#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ ParPat _ inner -> do+#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ ParPat _ inner -> do #else /* ghc-8.0 8.2 8.4 */ ParPat inner -> do #endif@@ -77,7 +86,7 @@ -- return $ (x1' Seq.<| middle) Seq.|> xN' ConPatIn lname (PrefixCon args) -> do -- Abc a b c -> expr- let nameDoc = lrdrNameToText lname+ nameDoc <- lrdrNameToTextAnn lname argDocs <- layoutPat `mapM` args if null argDocs then return <$> docLit nameDoc@@ -177,7 +186,9 @@ #endif -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")-#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */+ SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do+#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do@@ -242,13 +253,13 @@ -- else -- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n -- endif- _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat+ _ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat) colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend- :: Located (Pat GhcPs)+ :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do@@ -260,7 +271,7 @@ return $ x1' Seq.<| xR wrapPatListy- :: [Located (Pat GhcPs)]+ :: [LPat GhcPs] -> String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs view
@@ -2,6 +2,8 @@ module Language.Haskell.Brittany.Internal.Layouters.Type ( layoutType+ , layoutTyVarBndrs+ , processTyVarBndrsSingleline ) where @@ -32,21 +34,19 @@ layoutType :: ToBriDoc HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"+#if MIN_VERSION_ghc(8,2,0) #if MIN_VERSION_ghc(8,6,0) HsTyVar _ promoted name -> do- t <- lrdrNameToTextAnn name- case promoted of- Promoted -> docSeq- [ docSeparator- , docTick- , docWrapNode name $ docLit t- ]- NotPromoted -> docWrapNode name $ docLit t-#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+#else /* ghc-8.2 ghc-8.4 */ HsTyVar promoted name -> do+#endif t <- lrdrNameToTextAnn name case promoted of+#if MIN_VERSION_ghc(8,8,0)+ IsPromoted -> docSeq+#else /* ghc-8.2 8.4 8.6 */ Promoted -> docSeq+#endif [ docSeparator , docTick , docWrapNode name $ docLit t@@ -63,32 +63,13 @@ HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do #endif typeDoc <- docSharedWrapper layoutType typ2- tyVarDocs <- bndrs `forM` \case-#if MIN_VERSION_ghc(8,6,0)- (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)- (L _ (KindedTyVar _ lrdrName kind)) -> do- d <- docSharedWrapper layoutType kind- return $ (lrdrNameToText lrdrName, Just $ d)- (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"-#else- (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)- (L _ (KindedTyVar lrdrName kind)) -> do- d <- docSharedWrapper layoutType kind- return $ (lrdrNameToText lrdrName, Just $ d)-#endif+ tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline _ -> id let- tyVarDocLineList = tyVarDocs >>= \case- (tname, Nothing) -> [docLit $ Text.pack " " <> tname]- (tname, Just doc) -> [ docLit $ Text.pack " ("- <> tname- <> Text.pack " :: "- , docForceSingleline $ doc- , docLit $ Text.pack ")"- ]+ tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt [ let open = docLit $ Text.pack "forall"@@ -142,7 +123,7 @@ else let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . "- in docSeq ([open]++tyVarDocLineList++[close])+ in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc@@ -172,31 +153,11 @@ HsForAllTy bndrs typ2 -> do #endif typeDoc <- layoutType typ2- tyVarDocs <- bndrs `forM` \case-#if MIN_VERSION_ghc(8,6,0)- (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)- (L _ (KindedTyVar _ lrdrName kind)) -> do- d <- layoutType kind- return $ (lrdrNameToText lrdrName, Just $ return d)- (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"-#else- (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)- (L _ (KindedTyVar lrdrName kind)) -> do- d <- layoutType kind- return $ (lrdrNameToText lrdrName, Just $ return d)-#endif+ tyVarDocs <- layoutTyVarBndrs bndrs let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline _ -> id- let- tyVarDocLineList = tyVarDocs >>= \case- (tname, Nothing) -> [docLit $ Text.pack " " <> tname]- (tname, Just doc) -> [ docLit $ Text.pack " ("- <> tname- <> Text.pack " :: "- , docForceSingleline doc- , docLit $ Text.pack ")"- ]+ let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq@@ -771,3 +732,46 @@ else docLit $ Text.pack "*" XHsType{} -> error "brittany internal error: XHsType" #endif+#if MIN_VERSION_ghc(8,8,0)+ HsAppKindTy _ ty kind -> do+ t <- docSharedWrapper layoutType ty+ k <- docSharedWrapper layoutType kind+ docAlt+ [ docSeq+ [ docForceSingleline t+ , docSeparator+ , docLit $ Text.pack "@"+ , docForceSingleline k+ ]+ , docPar+ t+ (docSeq [docLit $ Text.pack "@", k ])+ ]+#endif++layoutTyVarBndrs+ :: [LHsTyVarBndr GhcPs]+ -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]+layoutTyVarBndrs = mapM $ \case+#if MIN_VERSION_ghc(8,6,0)+ (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)+ (L _ (KindedTyVar _ lrdrName kind)) -> do+ d <- docSharedWrapper layoutType kind+ return $ (lrdrNameToText lrdrName, Just $ d)+ (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"+#else+ (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)+ (L _ (KindedTyVar lrdrName kind)) -> do+ d <- docSharedWrapper layoutType kind+ return $ (lrdrNameToText lrdrName, Just $ d)+#endif++processTyVarBndrsSingleline+ :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]+processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case+ (tname, Nothing) -> [docLit $ Text.pack " " <> tname]+ (tname, Just doc) ->+ [ docLit $ Text.pack " (" <> tname <> Text.pack " :: "+ , docForceSingleline $ doc+ , docLit $ Text.pack ")"+ ]
src/Language/Haskell/Brittany/Internal/Prelude.hs view
@@ -18,7 +18,10 @@ #endif import RdrName as E ( RdrName )-+#if MIN_VERSION_ghc(8,8,0)+import qualified GHC ( dL, HasSrcSpan, SrcSpanLess )+#endif+import qualified GHC ( Located ) -- more general:@@ -409,4 +412,13 @@ type instance IdP GhcPs = RdrName type GhcPs = RdrName+#endif+++#if MIN_VERSION_ghc(8,8,0)+ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a)+ghcDL = GHC.dL+#else /* ghc-8.0 8.2 8.4 8.6 */+ghcDL :: GHC.Located a -> GHC.Located a+ghcDL x = x #endif