diff --git a/.gitignore b/.gitignore index 906e747..4393459 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,4 @@ local/ cabal.sandbox.config cabal.project.local .ghc.environment.* +result \ No newline at end of file diff --git a/README.md b/README.md index d42d085..f51e5fc 100644 --- a/README.md +++ b/README.md @@ -94,6 +94,12 @@ log the size of the input, but _not_ the full input/output of requests.) aura -A brittany ~~~~ +- via `nix`: + ~~~.sh + nix build -f release.nix # or 'nix-build -f release.nix' + nix-env -i ./result + ~~~ + # Editor Integration #### Sublime text @@ -111,6 +117,8 @@ log the size of the input, but _not_ the full input/output of requests.) brittany built in. #### Atom [Atom Beautify](https://atom.io/packages/atom-beautify) supports brittany as a formatter for Haskell. Since the default formatter is set to hindent, you will need to change this setting to brittany, after installing the extension. +#### Emacs + [format-all](https://github.com/lassik/emacs-format-all-the-code) support brittany as the default formatter for Haskell. # Usage diff --git a/brittany.cabal b/brittany.cabal index 5a16f50..ee5275e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -86,7 +86,7 @@ library { { base >=4.9 && <4.13 , ghc >=8.0.1 && <8.7 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.7 + , ghc-exactprint >=0.5.8 && <0.6.2 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..296987a --- /dev/null +++ b/default.nix @@ -0,0 +1,38 @@ +{ mkDerivation, aeson, base, butcher, bytestring, cmdargs +, containers, czipwith, data-tree-print, deepseq, directory, extra +, filepath, ghc, ghc-boot-th, ghc-exactprint, ghc-paths, hspec +, monad-memo, mtl, multistate, neat-interpolation, parsec, pretty +, random, safe, semigroups, stdenv, strict, syb, text, transformers +, uniplate, unsafe, yaml +}: +mkDerivation { + pname = "brittany"; + version = "0.11.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson base butcher bytestring cmdargs containers czipwith + data-tree-print deepseq directory extra filepath ghc ghc-boot-th + ghc-exactprint ghc-paths monad-memo mtl multistate + neat-interpolation pretty random safe semigroups strict syb text + transformers uniplate unsafe yaml + ]; + executableHaskellDepends = [ + aeson base butcher bytestring cmdargs containers czipwith + data-tree-print deepseq directory extra filepath ghc ghc-boot-th + ghc-exactprint ghc-paths monad-memo mtl multistate + neat-interpolation pretty safe semigroups strict syb text + transformers uniplate unsafe yaml + ]; + testHaskellDepends = [ + aeson base butcher bytestring cmdargs containers czipwith + data-tree-print deepseq directory extra filepath ghc ghc-boot-th + ghc-exactprint ghc-paths hspec monad-memo mtl multistate + neat-interpolation parsec pretty safe semigroups strict syb text + transformers uniplate unsafe yaml + ]; + homepage = "https://github.com/lspitzner/brittany/"; + description = "Haskell source code formatter"; + license = stdenv.lib.licenses.agpl3; +} diff --git a/pkgs.nix b/pkgs.nix new file mode 100644 index 0000000..76cbbb8 --- /dev/null +++ b/pkgs.nix @@ -0,0 +1,5 @@ +{ + url = "https://github.com/nixos/nixpkgs.git"; + ref = "release-18.09"; + rev = "b9fa31cea0e119ecf1867af4944ddc2f7633aacd"; +} diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..b37b2ce --- /dev/null +++ b/release.nix @@ -0,0 +1,5 @@ +{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} +, compiler ? "ghc822" +}: + +pkgs.haskell.packages.${compiler}.callPackage ./shell.nix {} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..5c0ccfe --- /dev/null +++ b/shell.nix @@ -0,0 +1,13 @@ +{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} +, compiler ? "ghc822" +}: + +pkgs.haskell.packages.${compiler}.developPackage { + root = ./.; + name = "brittany"; + overrides = with pkgs.haskell.lib; self: super: { + }; + source-overrides = { + ghc-exactprint = "0.5.8.0"; + }; +} diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 4d274c7..da8c3ee 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -531,6 +531,45 @@ func = if cond -- test abc +#test nonempty-case-short +func = case x of + False -> False + True -> True + +#test nonempty-case-long +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True + +#test nonempty-case-long-do +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True + +#test empty-case-short +func = case x of {} + +#test empty-case-long +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} + +#test empty-case-long-do +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} ############################################################################### ############################################################################### @@ -1155,3 +1194,44 @@ func = do other :: Other other = True + + +############################################################################### +############################################################################### +############################################################################### +#group typefam.instance +############################################################################### +############################################################################### +############################################################################### + +#test simple-typefam-instance + +type instance MyFam Bool = String + +#test simple-typefam-instance-param-type + +type instance MyFam (Maybe a) = a -> Bool + +#test simple-typefam-instance-parens + +type instance (MyFam (String -> Int)) = String + +#test simple-typefam-instance-overflow + +type instance MyFam ALongishType + = AMuchLongerTypeThanThat + -> AnEvenLongerTypeThanTheLastOne + -> ShouldDefinitelyOverflow + +#test simple-typefam-instance-comments + +-- | A happy family +type instance MyFam Bool -- This is an odd one + = AnotherType -- Here's another + +#test simple-typefam-instance-parens-comment + +-- | A happy family +type instance (MyFam Bool) -- This is an odd one + = -- Here's another + AnotherType diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 080c15e..d402ca7 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -650,3 +650,13 @@ jaicyhHumzo btrKpeyiFej mava = do ) Xcde{} -> (s, Pioemav) pure imomue + +#test issue 214 +-- brittany { lconfig_indentPolicy: IndentPolicyMultiple } +foo = bar + arg1 -- this is the first argument + arg2 -- this is the second argument + arg3 -- this is the third argument, now I'll skip one comment + arg4 + arg5 -- this is the fifth argument + arg6 -- this is the sixth argument diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 6352662..701339c 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -9,6 +9,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments + , extractRestComments , filterAnns , docEmpty , docLit @@ -64,6 +65,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , hasAnyCommentsBelow , hasAnyCommentsConnected , hasAnyCommentsPrior + , hasAnyRegularCommentsConnected + , hasAnyRegularCommentsRest , hasAnnKeywordComment , hasAnnKeyword ) @@ -263,9 +266,13 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk extractAllComments :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] extractAllComments ann = - ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ++ ( ExactPrint.annsDP ann >>= \case + ExactPrint.annPriorComments ann ++ extractRestComments ann + +extractRestComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractRestComments ann = + ExactPrint.annFollowingComments ann + ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] _ -> [] ) @@ -278,31 +285,51 @@ filterAnns ast = -- a) connected to any node below (in AST sense) the given node AND -- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsBelow ast@(L l _) = do - anns <- filterAnns ast <$> mAsk - return - $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) - $ (=<<) extractAllComments - $ Map.elems - $ anns +hasAnyCommentsBelow ast@(L l _) = + List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) + <$> astConnectedComments ast --- | True if there are any comments that are --- connected to any node below (in AST sense) the given node +-- | True if there are any comments that are connected to any node below (in AST +-- sense) the given node hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsConnected ast = do +hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast + +-- | True if there are any regular comments connected to any node below (in AST +-- sense) the given node +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected ast = + any isRegularComment <$> astConnectedComments ast + +-- | Regular comments are comments that are actually "source code comments", +-- i.e. things that start with "--" or "{-". In contrast to comment-annotations +-- used by ghc-exactprint for capturing symbols (and their exact positioning). +-- +-- Only the type instance layouter makes use of this filter currently, but +-- it might make sense to apply it more aggressively or make it the default - +-- I believe that most of the time we branch on the existence of comments, we +-- only care about "regular" comments. We simply did not need the distinction +-- because "irregular" comments are not that common outside of type/data decls. +isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool +isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst + +astConnectedComments + :: Data ast + => GHC.Located ast + -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] +astConnectedComments ast = do anns <- filterAnns ast <$> mAsk - return - $ not - $ null - $ (=<<) extractAllComments - $ Map.elems - $ anns + pure $ extractAllComments =<< Map.elems anns hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsPrior ast = astAnn ast <&> \case Nothing -> False Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors +hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsRest ast = astAnn ast <&> \case + Nothing -> False + Just ann -> any isRegularComment (extractRestComments ann) + hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 37724f6..9366a6f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -33,6 +33,9 @@ import GHC ( runGhc ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn +#if MIN_VERSION_ghc(8,6,0) +import HsExtension (NoExt (..)) +#endif import Name import BasicTypes ( InlinePragma(..) , Activation(..) @@ -62,7 +65,8 @@ layoutDecl d@(L loc decl) = case decl of Left ns -> docLines $ return <$> ns Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD _ (TyFamInstD{}) -> layoutTyFamInstDWorkaround d + InstD _ (TyFamInstD _ tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d @@ -73,25 +77,12 @@ layoutDecl d@(L loc decl) = case decl of Left ns -> docLines $ return <$> ns Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD (TyFamInstD{}) -> layoutTyFamInstDWorkaround d + InstD (TyFamInstD tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif -layoutTyFamInstDWorkaround :: ToBriDoc HsDecl -layoutTyFamInstDWorkaround d = do - -- this is a (temporary (..)) workaround for "type instance" decls - -- that do not round-trip through exactprint properly. - let fixer s = case List.stripPrefix "type " s of - Just rest | not ("instance" `isPrefixOf` rest) -> - "type instance " ++ rest - _ -> s - str <- mAsk <&> \anns -> - intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns - allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) - (foldedAnnKeys d) - False - (Text.pack str) -------------------------------------------------------------------------------- -- Sig @@ -156,24 +147,11 @@ layoutSig lsig@(L _loc sig) = case sig of ] ] ] - else - docAlt - $ [ docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr - , appSep $ docLit $ Text.pack "::" - , docForceSingleline typeDoc - ] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - (docWrapNodeRest lsig $ docLit nameStr) - ( docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ) - ] + else layoutLhsAndType + hasComments + (appSep . docWrapNodeRest lsig $ docLit nameStr) + "::" + typeDoc specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String @@ -754,12 +732,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do sharedLhs <- docSharedWrapper id lhs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ - runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] - addAlternative $ docAddBaseY BrIndentRegular $ docPar - sharedLhs - (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) + layoutLhsAndType hasComments sharedLhs "=" typeDoc layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr layoutTyVarBndr needsSep lbndr@(L _ bndr) = do @@ -788,6 +761,55 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do ] +-------------------------------------------------------------------------------- +-- TyFamInstDecl +-------------------------------------------------------------------------------- + +layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl +layoutTyFamInstDecl inClass (L loc tfid) = do + let +#if MIN_VERSION_ghc(8,6,0) + linst = L loc (TyFamInstD NoExt tfid) + feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + 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 + 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 + pats = hsib_body boundPats +#else + linst = L loc (TyFamInstD tfid) + lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + pats = hsib_body boundPats +#endif + docWrapNodePrior linst $ do + nameStr <- lrdrNameToTextAnn name + needsParens <- hasAnnKeyword lfeqn AnnOpenP + let + instanceDoc = if inClass + then docLit $ Text.pack "type" + else docSeq + [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + lhs = + docWrapNode lfeqn + . appSep + . docWrapNodeRest linst + . docSeq + $ (appSep instanceDoc :) + $ [ docParenL | needsParens ] + ++ [appSep $ docWrapNode name $ docLit nameStr] + ++ intersperse docSeparator (layoutType <$> pats) + ++ [ docParenR | needsParens ] + hasComments <- (||) + <$> hasAnyRegularCommentsConnected lfeqn + <*> hasAnyRegularCommentsRest linst + typeDoc <- docSharedWrapper layoutType typ + layoutLhsAndType hasComments lhs "=" typeDoc + + -------------------------------------------------------------------------------- -- ClsInstDecl -------------------------------------------------------------------------------- @@ -855,12 +877,7 @@ layoutClsInst lcid@(L _ cid) = docLines layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) layoutAndLocateTyFamInsts ltfid@(L loc _) = - L loc <$> layoutTyFamInstDecl ltfid - - -- | Send to ExactPrint then remove unecessary whitespace - layoutTyFamInstDecl :: ToBriDoc TyFamInstDecl - layoutTyFamInstDecl ltfid = - fmap stripWhitespace <$> briDocByExactNoComment ltfid + L loc <$> layoutTyFamInstDecl True ltfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) @@ -928,3 +945,32 @@ layoutClsInst lcid@(L _ cid) = docLines isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') + + +-------------------------------------------------------------------------------- +-- Common Helpers +-------------------------------------------------------------------------------- + +layoutLhsAndType + :: Bool + -> ToBriDocM BriDocNumbered + -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +layoutLhsAndType hasComments lhs sep typeDoc = do + let sepDoc = appSep . docLit $ Text.pack sep + runFilteredAlternative $ do + -- (separators probably are "=" or "::") + -- lhs = type + -- lhs :: type + addAlternativeCond (not hasComments) + $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] + -- lhs + -- :: typeA + -- -> typeB + -- lhs + -- = typeA + -- -> typeB + addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols + ColTyOpPrefix + [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index caf51a7..3f1cfb7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -136,6 +136,17 @@ layoutExpr lexpr@(L _ expr) = do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ XMatchGroup{} -> error "brittany internal error: HsLamCase XMatchGroup" +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLamCase _ (MG _ (L _ []) _) -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ + HsLamCase (MG (L _ []) _ _ _) -> do +#else /* ghc-8.0 */ + HsLamCase _ (MG (L _ []) _ _ _) -> do +#endif + docSetParSpacing $ docAddBaseY BrIndentRegular $ + (docLit $ Text.pack "\\case {}") +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do @@ -172,9 +183,10 @@ layoutExpr lexpr@(L _ expr) = do _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + hasComments <- hasAnyCommentsConnected exp2 runFilteredAlternative $ do -- foo x y - addAlternative + addAlternativeCond (not hasComments) $ colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) @@ -520,6 +532,27 @@ layoutExpr lexpr@(L _ expr) = do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ _ XMatchGroup{} -> error "brittany internal error: HsCase XMatchGroup" +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsCase _ cExp (MG _ (L _ []) _) -> do +#else + HsCase cExp (MG (L _ []) _ _ _) -> do +#endif + cExpDoc <- docSharedWrapper layoutExpr cExp + docAlt + [ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") + ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do #else HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do