From dfa3fef56c0de2539931e0be4049a27b087aab7e Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Tue, 25 Feb 2020 22:04:48 +0000 Subject: [PATCH 01/17] Add support for pattern synonyms --- src-literatetests/14-extensions.blt | 54 ++++++++ .../Brittany/Internal/Layouters/Decl.hs | 128 ++++++++++++++++-- 2 files changed, 171 insertions(+), 11 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 1dc5cf8..9805816 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -82,6 +82,60 @@ import Test ( type (++) , pattern (:.) ) +############################################################################### +## PatternSynonyms +#test bidirectional pattern +{-# LANGUAGE PatternSynonyms #-} +pattern J x = Just x + +#test unidirection pattern +{-# LANGUAGE PatternSynonyms #-} +pattern F x <- (x, _) + +#test explicitly bidirectional pattern +{-# LANGUAGE PatternSynonyms #-} +pattern HeadC x <- x : xs where + HeadC x = [x] + +#test Multiple arguments +{-# LANGUAGE PatternSynonyms #-} +pattern Head2 x y <- x : y : xs where + Head2 x y = [x, y] + +#test Infix argument +{-# LANGUAGE PatternSynonyms #-} +pattern x :> y = [x, y] + +#test Record argument +{-# LANGUAGE PatternSynonyms #-} +pattern MyData { a, b, c } = [a, b, c] + +#test long pattern match +{-# LANGUAGE PatternSynonyms #-} +pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = + [myLongLeftVariableName, myLongRightVariableName] + +#test long explicitly bidirectional match +{-# LANGUAGE PatternSynonyms #-} +pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- + [myLongLeftVariableName, myLongRightVariableName] where + MyInfixPatternMatcher x y = [x, x, y] + +#test Pattern synonym types +{-# LANGUAGE PatternSynonyms #-} +pattern J :: a -> Maybe a +pattern J x = Just x + +#test Pattern synonym type sig wrapped +{-# LANGUAGE PatternSynonyms #-} +pattern LongMatcher + :: longlongtypevar + -> longlongtypevar + -> longlongtypevar + -> Maybe [longlongtypevar] +pattern LongMatcher x y z = Just [x, y, z] + + ############################################################################### ## UnboxedTuples + MagicHash #test unboxed-tuple and vanilla names diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index fbbcafd..265aeb7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -93,11 +93,11 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ - TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ + TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ + TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> @@ -121,15 +121,25 @@ layoutSig lsig@(L _loc sig) = case sig of <> nameStr <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ - ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ + ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */ - ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ + ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ +#endif +#if MIN_VERSION_ghc(8,6,0) + PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ +#elif MIN_VERSION_ghc(8,2,0) + PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ +#else + PatSynSig name (HsIB _ typ) -> layoutNamesAndType (Just "pattern") [name] typ #endif _ -> briDocByExactNoComment lsig -- TODO where - layoutNamesAndType names typ = docWrapNode lsig $ do + layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do + let keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -139,8 +149,8 @@ layoutSig lsig@(L _loc sig) = case sig of .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging - then docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr + then docSeq $ + [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] , docSetBaseY $ docLines [ docCols ColTyOpPrefix @@ -151,7 +161,7 @@ layoutSig lsig@(L _loc sig) = case sig of ] else layoutLhsAndType hasComments - (appSep . docWrapNodeRest lsig $ docLit nameStr) + (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) "::" typeDoc @@ -231,8 +241,18 @@ layoutBind lbind@(L _ bind) = case bind of clauseDocs mWhereArg hasComments +#if MIN_VERSION_ghc(8,8,0) + PatSynBind _ (PSB _ patID lpat rpat dir) -> do +#elif MIN_VERSION_ghc(8,6,0) + PatSynBind _ (PSB _ patID lpat rpat dir) -> do +#else + PatSynBind (PSB patID _ lpat rpat dir) -> do +#endif + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID + lpat + dir + rpat _ -> Right <$> unknownNodeError "" lbind - layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -709,6 +729,92 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine +-- | Layout a pattern synonym binding +layoutPatSynBind + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> HsPatSynDir GhcPs + -> LPat GhcPs + -> ToBriDocM BriDocNumbered +layoutPatSynBind name patSynDetails patDir rpat = do + let patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" + mWhereDocs <- layoutPatSynWhere patDir + runFilteredAlternative $ do + addAlternative $ + docLines $ + [ docSeq $ fmap appSep + [ patDoc + , layoutLPatSyn name patSynDetails + , binderDoc, body] + <> case mWhereDocs of + Just _ -> [whereDoc] + Nothing -> [] + ] <> case mWhereDocs of + Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] + Nothing -> [] + + addAlternative $ + docLines $ + [ docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc] + , docEnsureIndent BrIndentRegular . docSeq + $ appSep body : case mWhereDocs of + Just _ -> [whereDoc] + Nothing -> [] + ] <> case mWhereDocs of + Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] + Nothing -> [] + +-- | Helper method for the left hand side of a pattern synonym +layoutLPatSyn + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (PrefixCon vars) = do +#else +layoutLPatSyn name (PrefixPatSyn vars) = do +#endif + docName <- lrdrNameToTextAnn name + names <- mapM lrdrNameToTextAnn vars + docSeq . fmap appSep $ docLit docName : (docLit <$> names) +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (InfixCon left right) = do +#else +layoutLPatSyn name (InfixPatSyn left right) = do +#endif + leftDoc <- lrdrNameToTextAnn left + docName <- lrdrNameToTextAnn name + rightDoc <- lrdrNameToTextAnn right + docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (RecCon recArgs) = do +#else +layoutLPatSyn name (RecordPatSyn recArgs) = do +#endif + docName <- lrdrNameToTextAnn name + args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs + docSeq . fmap docLit + $ [docName, Text.pack " { " ] + <> intersperse (Text.pack ", ") args + <> [Text.pack " }"] + +-- | Helper method to get the where clause from of explicitly bidirectional +-- pattern synonyms +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [BriDocNumbered]) +layoutPatSynWhere hs = case hs of +#if MIN_VERSION_ghc(8,6,0) + ExplicitBidirectional (MG _ (L _ lbinds) _) -> do +#else + ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do +#endif + binderDoc <- docLit $ Text.pack "=" + Just <$> mapM (layoutPatternBind Nothing binderDoc) lbinds + _ -> pure Nothing -------------------------------------------------------------------------------- -- TyClDecl -- 2.30.2 From 9236673d66644ebc8f49e897a7b47bf61214c434 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 13 Mar 2020 01:23:17 +0100 Subject: [PATCH 02/17] Fix newtype indent in associated type family (#207) --- src-literatetests/10-tests.blt | 18 ++++++++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 1 + 2 files changed, 19 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d1138..88f3598 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1514,6 +1514,24 @@ instance MyClass Int where , intData2 :: Int } +#test instance-with-newtype-family-and-deriving + +{-# LANGUAGE TypeFamilies #-} + +module Lib where + +instance Foo () where + newtype Bar () = Baz () + deriving (Eq, Ord, Show) + bar = Baz + +#test instance-with-newtype-family-and-record + +instance Foo Int where + newtype Bar Int = BarInt + { unBarInt :: Int + } + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index fbbcafd..d457920 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1037,6 +1037,7 @@ layoutClsInst lcid@(L _ cid) = docLines | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "newtype" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') -- 2.30.2 From 231c2f5e94b2d242de9990f11673e466418a445c Mon Sep 17 00:00:00 2001 From: Neil Mitchell Date: Sat, 14 Mar 2020 16:28:52 +0000 Subject: [PATCH 03/17] Permit extra-1.7 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 731166f..334dacd 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -107,7 +107,7 @@ library { , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.12 , aeson >=1.0.1.0 && <1.5 - , extra >=1.4.10 && <1.7 + , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.6 -- 2.30.2 From 2d07900005fd3535bcaae91e05cad9dc49be5fb5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:50:42 +0100 Subject: [PATCH 04/17] Rewrite non-recommended usage of docLines --- .../Brittany/Internal/Layouters/Decl.hs | 49 ++++++++++++------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 265aeb7..0f57455 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Decl ( layoutDecl @@ -746,28 +749,38 @@ layoutPatSynBind name patSynDetails patDir rpat = do mWhereDocs <- layoutPatSynWhere patDir runFilteredAlternative $ do addAlternative $ - docLines $ - [ docSeq $ fmap appSep + -- pattern .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docSeq $ [ patDoc + , docSeparator , layoutLPatSyn name patSynDetails - , binderDoc, body] - <> case mWhereDocs of - Just _ -> [whereDoc] + , docSeparator + , binderDoc + , docSeparator + , body + ] ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docSeq ds)] Nothing -> [] - ] <> case mWhereDocs of - Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] - Nothing -> [] addAlternative $ - docLines $ - [ docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc] - , docEnsureIndent BrIndentRegular . docSeq - $ appSep body : case mWhereDocs of - Just _ -> [whereDoc] - Nothing -> [] - ] <> case mWhereDocs of - Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] + -- pattern .. = + -- .. + -- pattern .. <- + -- .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docPar + (docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]) + (docLines $ + [ docSeq $ body : case mWhereDocs of + Just _ -> [docSeparator, whereDoc] Nothing -> [] + ] <> case mWhereDocs of + Just x -> [docSeq x] + Nothing -> [] + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -805,7 +818,7 @@ layoutLPatSyn name (RecordPatSyn recArgs) = do -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [BriDocNumbered]) +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of #if MIN_VERSION_ghc(8,6,0) ExplicitBidirectional (MG _ (L _ lbinds) _) -> do @@ -813,7 +826,7 @@ layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (layoutPatternBind Nothing binderDoc) lbinds + Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- -- 2.30.2 From b546b514b00b2141c430c6eebb1fb46a43659637 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:43:45 +0100 Subject: [PATCH 05/17] Add a testcase for PatternSynonym decls (needs fixing) --- src-literatetests/14-extensions.blt | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 9805816..6c97935 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -126,6 +126,26 @@ pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- pattern J :: a -> Maybe a pattern J x = Just x +#test pattern synonym multiple cases +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x + +#test pattern synonym multiple cases with comments +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x -- negative comment + Signed Zero = 0 -- zero comment + Signed (Pos x) = x -- positive comment + +#test Pattern synonym types multiple names +{-# LANGUAGE PatternSynonyms #-} +pattern J, K :: a -> Maybe a + #test Pattern synonym type sig wrapped {-# LANGUAGE PatternSynonyms #-} pattern LongMatcher -- 2.30.2 From eec946830bc12f8a2618692367df799fece77a86 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:58:47 +0100 Subject: [PATCH 06/17] Fix failing testcase on bidirectional pattern synonyms --- .../Brittany/Internal/Layouters/Decl.hs | 30 +++++++++---------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 0f57455..d4f7baa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -753,16 +753,16 @@ layoutPatSynBind name patSynDetails patDir rpat = do -- .. -- .. docAddBaseY BrIndentRegular $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - , docSeparator - , body - ] ++ case mWhereDocs of - Just ds -> [docSeparator, docPar whereDoc (docSeq ds)] - Nothing -> [] + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + , docSeparator + , body + ] ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docLines ds)] + Nothing -> [] addAlternative $ -- pattern .. = @@ -774,12 +774,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do docAddBaseY BrIndentRegular $ docPar (docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]) (docLines $ - [ docSeq $ body : case mWhereDocs of - Just _ -> [docSeparator, whereDoc] - Nothing -> [] - ] <> case mWhereDocs of - Just x -> [docSeq x] - Nothing -> [] + case mWhereDocs of + Nothing -> [body] + Just ds -> + [ docSeq [body, docSeparator, whereDoc] ] ++ ds ) -- | Helper method for the left hand side of a pattern synonym -- 2.30.2 From 3631f6aec3edcb2c3a80311d128200de81f2504e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:59:05 +0100 Subject: [PATCH 07/17] Add another testcase for bidirectional pattern synonyms --- src-literatetests/14-extensions.blt | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 6c97935..d2ec606 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -126,7 +126,7 @@ pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- pattern J :: a -> Maybe a pattern J x = Just x -#test pattern synonym multiple cases +#test pattern synonym bidirectional multiple cases {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} pattern Signed x <- (asSigned -> x) where @@ -134,7 +134,16 @@ pattern Signed x <- (asSigned -> x) where Signed Zero = 0 Signed (Pos x) = x -#test pattern synonym multiple cases with comments +#test pattern synonym bidirectional multiple cases long +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- + (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x + +#test pattern synonym bidirectional multiple cases with comments {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} pattern Signed x <- (asSigned -> x) where -- 2.30.2 From 2ce3fb178c9132d47f422f8e5b91ffcbbfd8c485 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 22:04:34 +0100 Subject: [PATCH 08/17] Share some more bridoc nodes, clean up code --- .../Brittany/Internal/Layouters/Decl.hs | 31 +++++++++---------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index d4f7baa..9394ebd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -747,23 +747,24 @@ layoutPatSynBind name patSynDetails patDir rpat = do body = colsWrapPat =<< layoutPat rpat whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir + headDoc <- fmap pure $ docSeq $ + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do addAlternative $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - , docSeparator - , body - ] ++ case mWhereDocs of + docAddBaseY BrIndentRegular $ docSeq + ( [headDoc, docSeparator, body] + ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - + ) addAlternative $ -- pattern .. = -- .. @@ -772,12 +773,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do -- .. -- .. docAddBaseY BrIndentRegular $ docPar - (docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]) - (docLines $ - case mWhereDocs of - Nothing -> [body] - Just ds -> - [ docSeq [body, docSeparator, whereDoc] ] ++ ds + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) ) -- | Helper method for the left hand side of a pattern synonym -- 2.30.2 From ae0e397fac76c0c2118ba59981c522845d22672e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 22 Mar 2020 22:44:13 +0100 Subject: [PATCH 09/17] Disable one test-case for ghc-8.0 (unsupported syntax) --- src-literatetests/14-extensions.blt | 1 + 1 file changed, 1 insertion(+) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index d2ec606..81dde02 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -152,6 +152,7 @@ pattern Signed x <- (asSigned -> x) where Signed (Pos x) = x -- positive comment #test Pattern synonym types multiple names +#min-ghc 8.2 {-# LANGUAGE PatternSynonyms #-} pattern J, K :: a -> Maybe a -- 2.30.2 From df2ee177b29bebc06700e21cc5d8778037f659ff Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 23 Feb 2020 23:09:03 +0100 Subject: [PATCH 10/17] Fix comments in instance/type instances (#282) --- src-literatetests/15-regressions.blt | 8 +++ .../Brittany/Internal/Layouters/Decl.hs | 59 +++++++++---------- 2 files changed, 37 insertions(+), 30 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e4c1b7c..a6a0274 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -869,3 +869,11 @@ createRedirectedProcess processConfig = do , std_err = CreatePipe } foo + +#test issue 282 + +instance HasDependencies SomeDataModel where + -- N.B. Here is a bunch of explanatory context about the relationship + -- between these data models or whatever. + type Dependencies SomeDataModel + = (SomeOtherDataModelId, SomeOtherOtherDataModelId) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index e6466ac..13d0853 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -72,7 +72,7 @@ layoutDecl d@(L loc decl) = case decl of Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d @@ -84,7 +84,7 @@ layoutDecl d@(L loc decl) = case decl of Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif @@ -941,39 +941,39 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do -layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl -layoutTyFamInstDecl inClass (L loc tfid) = do +layoutTyFamInstDecl + :: Data.Data.Data a + => Bool + -> Located a + -> TyFamInstDecl GhcPs + -> ToBriDocM BriDocNumbered +layoutTyFamInstDecl inClass outerNode tfid = do let #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 + 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 + innerNode = outerNode #elif MIN_VERSION_ghc(8,6,0) - linst = L loc (TyFamInstD NoExt tfid) - feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,4,0) - linst = L loc (TyFamInstD tfid) - feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,2,0) - linst = L loc (TyFamInstD tfid) - lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid + innerNode@(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 + innerNode@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #endif - docWrapNodePrior linst $ do + docWrapNodePrior outerNode $ do nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword lfeqn AnnOpenP + needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass then docLit $ Text.pack "type" @@ -987,9 +987,7 @@ layoutTyFamInstDecl inClass (L loc tfid) = do ++ processTyVarBndrsSingleline bndrDocs ) lhs = - docWrapNode lfeqn - . appSep - . docWrapNodeRest linst + docWrapNode innerNode . docSeq $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] @@ -998,8 +996,8 @@ layoutTyFamInstDecl inClass (L loc tfid) = do ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] hasComments <- (||) - <$> hasAnyRegularCommentsConnected lfeqn - <*> hasAnyRegularCommentsRest linst + <$> hasAnyRegularCommentsConnected outerNode + <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc @@ -1085,8 +1083,8 @@ layoutClsInst lcid@(L _ cid) = docLines layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc _) = - L loc <$> layoutTyFamInstDecl True ltfid + layoutAndLocateTyFamInsts ltfid@(L loc tfid) = + L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) @@ -1168,13 +1166,12 @@ layoutLhsAndType -> 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] + addAlternativeCond (not hasComments) $ docSeq + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB @@ -1183,4 +1180,6 @@ layoutLhsAndType hasComments lhs sep typeDoc = do -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix - [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] + [ appSep $ docLitS sep + , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc + ] -- 2.30.2 From 061c39b4e9c41bdb23ca4eab302001fafbef50bf Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Mar 2020 23:32:10 +0100 Subject: [PATCH 11/17] Fix a semi-hidden missing indentation bug --- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 4 +++- src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs | 5 ++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index e6466ac..9022613 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -534,7 +534,9 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] ] ] ++ wherePartMultiLine diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 3fd5f8a..3aa3b5c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -51,7 +51,10 @@ layoutStmt lstmt@(L _ stmt) = do [ docCols ColBindStmt [ appSep patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] + , docSeq + [ appSep $ docLit $ Text.pack "<-" + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc + ] ] , docCols ColBindStmt -- 2.30.2 From 8778dcf2f4ffb0a3017dff766e7fbe7d649b812e Mon Sep 17 00:00:00 2001 From: Soares Chen Date: Mon, 6 Apr 2020 10:21:38 +0000 Subject: [PATCH 12/17] Create Main module for Brittany --- brittany.cabal | 61 +--- src-brittany/Main.hs | 482 +------------------------ src/Language/Haskell/Brittany/Main.hs | 484 ++++++++++++++++++++++++++ 3 files changed, 493 insertions(+), 534 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Main.hs diff --git a/brittany.cabal b/brittany.cabal index a4e0c76..0bd1271 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,3 +1,4 @@ +cabal-version: 2.2 name: brittany version: 0.12.1.1 synopsis: Haskell source code formatter @@ -8,7 +9,7 @@ description: { . The implementation is documented in more detail . } -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner @@ -16,7 +17,6 @@ copyright: Copyright (C) 2016-2019 Lennart Spitzner Copyright (C) 2019 PRODA LTD category: Language build-type: Simple -cabal-version: 1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: { @@ -53,6 +53,7 @@ library { srcinc exposed-modules: { Language.Haskell.Brittany + Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal Language.Haskell.Brittany.Internal.Prelude Language.Haskell.Brittany.Internal.PreludeUtils @@ -145,60 +146,12 @@ executable brittany buildable: True } main-is: Main.hs - other-modules: { - Paths_brittany - } - -- other-extensions: - build-depends: - { brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , filepath >=1.4.1.0 && <1.5 - } hs-source-dirs: src-brittany - include-dirs: srcinc + build-depends: + { base + , brittany + } default-language: Haskell2010 - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } ghc-options: { -Wall -fno-spec-constr diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 77515ce..0312f6b 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -1,484 +1,6 @@ -{-# LANGUAGE DataKinds #-} - module Main where - - -#include "prelude.inc" - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate - as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Data.Map as Map -import qualified Data.Monoid - -import GHC ( GenLocated(L) ) -import Outputable ( Outputable(..) - , showSDocUnsafe - ) - -import Text.Read ( Read(..) ) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Control.Monad ( zipWithM ) -import Data.CZipWith - -import qualified Debug.Trace as Trace - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Obfuscation - -import qualified Text.PrettyPrint as PP - -import DataTreePrint -import UI.Butcher.Monadic - -import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Paths_brittany - - - -data WriteMode = Display | Inplace - -instance Read WriteMode where - readPrec = val "display" Display <|> val "inplace" Inplace - where val iden v = ReadPrec.lift $ ReadP.string iden >> return v - -instance Show WriteMode where - show Display = "display" - show Inplace = "inplace" - +import qualified Language.Haskell.Brittany.Main as BrittanyMain main :: IO () -main = mainFromCmdParserWithHelpDesc mainCmdParser - -helpDoc :: PP.Doc -helpDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDocW - [ "Reformats one or more haskell modules." - , "Currently affects only the module head (imports/exports), type" - , "signatures and function bindings;" - , "everything else is left unmodified." - , "Based on ghc-exactprint, thus (theoretically) supporting all" - , "that ghc does." - ] - , parDoc $ "Example invocations:" - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" - ] - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] - ] - , parDocW - [ "This program is written carefully and contains safeguards to ensure" - , "the output is syntactically valid and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs," - , "and ensuring that the transformation never changes semantics of the" - , "transformed source is currently not possible." - , "Please do check the output and do not let brittany override your large" - , "codebase without having backups." - ] - , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW - [ "This program is free software released under the AGPLv3." - , "For details use the --license flag." - ] - , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc - $ "Please report bugs at" - ++ " https://github.com/lspitzner/brittany/issues" - ] - -licenseDoc :: PP.Doc -licenseDoc = PP.vcat $ List.intersperse - (PP.text "") - [ 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," - , "version 3, as published by the Free Software Foundation." - ] - , parDocW - [ "This program is distributed in the hope that it will be useful," - , "but WITHOUT ANY WARRANTY; without even the implied warranty of" - , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , "GNU Affero General Public License for more details." - ] - , parDocW - [ "You should have received a copy of the GNU Affero General Public" - , "License along with this program. If not, see" - , "." - ] - ] - - -mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () -mainCmdParser helpDesc = do - addCmdSynopsis "haskell source pretty printer" - addCmdHelp $ helpDoc - -- addCmd "debugArgs" $ do - addHelpCommand helpDesc - addCmd "license" $ addCmdImpl $ print $ licenseDoc - -- addButcherDebugCommand - reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser - suppressOutput <- addSimpleBoolFlag - "" - ["suppress-output"] - (flagHelp $ parDoc - "suppress the regular output, i.e. the transformed haskell source" - ) - _verbosity <- addSimpleCountFlag - "v" - ["verbose"] - (flagHelp $ parDoc "[currently without effect; TODO]") - checkMode <- addSimpleBoolFlag - "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.text "and print file path(s) of files that have changes to stdout" - ] - ) - ) - writeMode <- addFlagReadParam - "" - ["write-mode"] - "(display|inplace)" - ( flagHelp - (PP.vcat - [ PP.text "display: output for any input(s) goes to stdout" - , PP.text "inplace: override respective input file (without backup!)" - ] - ) - Data.Monoid.<> flagDefault Display - ) - inputParams <- addParamNoFlagStrings - "PATH" - (paramHelpStr "paths to input/inout haskell source files") - reorderStop - addCmdImpl $ void $ do - when printLicense $ do - print licenseDoc - System.Exit.exitSuccess - when printVersion $ do - do - putStrLn $ "brittany version " ++ showVersion version - 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 - liftIO - $ putStrLn - $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } - $ ppHelpShallow helpDesc - System.Exit.exitSuccess - - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths - - configsToLoad <- liftIO $ if null configPaths - then - maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- - runMaybeT - (if noUserConfig - then readConfigs cmdlineConfig configsToLoad - else readConfigsWithUserConfig cmdlineConfig configsToLoad - ) - >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) - $ trace (showConfigYaml config) - $ return () - - 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) - 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) - - -data ChangeStatus = Changes | NoChanges - deriving (Eq) - --- | The main IO parts for the default mode of operation, and after commandline --- and config stuff is processed. -coreIO - :: (String -> IO ()) -- ^ error output function. In parallel operation, you - -- may want serialize the different outputs and - -- consequently not directly print to stderr. - -> Config -- ^ global program config. - -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so - -- currently not part of program config. - -> Bool -- ^ whether we are (just) in check mode. - -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. - -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. - -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = - ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - 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 - (parseResult, originalContents) <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id - inputString <- liftIO $ System.IO.hGetContents System.IO.stdin - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) - return (parseRes, Text.pack inputString) - Just p -> liftIO $ do - 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 - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) - return (parseRes, inputText) - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of - Left (err, input) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack - (errsWarns, outSText, hasChanges) <- do - if - | disableFormatting -> do - pure ([], originalContents, False) - | exactprintOnly -> do - let r = Text.pack $ ExactPrint.exactPrint parsedSource anns - pure ([], r, r /= originalContents) - | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - 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 - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 - when (not $ null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{} : _) -> do - putErrorLn - $ "ERROR: brittany pretty printer" - ++ " returned syntactically invalid result." - (ErrorInput str : _) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{} : _) -> do - putErrorLn - $ "WARNING: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) - when - ( config - & _conf_debug - & _dconf_dump_ast_unknown - & confUnpack - ) - $ do - putErrorLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - putErrorLn - " -> falling back on exactprint for this element of the module" - warns@(LayoutWarning{} : _) -> do - putErrorLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{} : _) -> do - putErrorLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input : _) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let - hasErrors = - case config & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = - config - & _conf_errorHandling - & _econf_produceOutputOnErrors - & confUnpack - shouldOutput = - not suppressOutput - && not checkMode - && (not hasErrors || outputOnErrs) - - when shouldOutput - $ addTraceSep (_conf_debug config) - $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges - unless isIdentical $ Text.IO.writeFile p $ outSText - - when (checkMode && hasChanges) $ case inputPathM of - Nothing -> pure () - Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p - - when hasErrors $ ExceptT.throwE 70 - return (if hasChanges then Changes else NoChanges) - where - addTraceSep conf = - if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] - then trace "----" - else id +main = BrittanyMain.main diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs new file mode 100644 index 0000000..c2f2254 --- /dev/null +++ b/src/Language/Haskell/Brittany/Main.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Main (main) where + + + +#include "prelude.inc" + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate + as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Data.Map as Map +import qualified Data.Monoid + +import GHC ( GenLocated(L) ) +import Outputable ( Outputable(..) + , showSDocUnsafe + ) + +import Text.Read ( Read(..) ) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Control.Monad ( zipWithM ) +import Data.CZipWith + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany + + + +data WriteMode = Display | Inplace + +instance Read WriteMode where + readPrec = val "display" Display <|> val "inplace" Inplace + where val iden v = ReadPrec.lift $ ReadP.string iden >> return v + +instance Show WriteMode where + show Display = "display" + show Inplace = "inplace" + + +main :: IO () +main = mainFromCmdParserWithHelpDesc mainCmdParser + +helpDoc :: PP.Doc +helpDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDocW + [ "Reformats one or more haskell modules." + , "Currently affects only the module head (imports/exports), type" + , "signatures and function bindings;" + , "everything else is left unmodified." + , "Based on ghc-exactprint, thus (theoretically) supporting all" + , "that ghc does." + ] + , parDoc $ "Example invocations:" + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" + ] + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" + ] + ] + , parDocW + [ "This program is written carefully and contains safeguards to ensure" + , "the output is syntactically valid and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs," + , "and ensuring that the transformation never changes semantics of the" + , "transformed source is currently not possible." + , "Please do check the output and do not let brittany override your large" + , "codebase without having backups." + ] + , parDoc $ "There is NO WARRANTY, to the extent permitted by law." + , parDocW + [ "This program is free software released under the AGPLv3." + , "For details use the --license flag." + ] + , parDoc $ "See https://github.com/lspitzner/brittany" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" + ] + +licenseDoc :: PP.Doc +licenseDoc = PP.vcat $ List.intersperse + (PP.text "") + [ 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," + , "version 3, as published by the Free Software Foundation." + ] + , parDocW + [ "This program is distributed in the hope that it will be useful," + , "but WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU Affero General Public License for more details." + ] + , parDocW + [ "You should have received a copy of the GNU Affero General Public" + , "License along with this program. If not, see" + , "." + ] + ] + + +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ helpDoc + -- addCmd "debugArgs" $ do + addHelpCommand helpDesc + addCmd "license" $ addCmdImpl $ print $ licenseDoc + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser + suppressOutput <- addSimpleBoolFlag + "" + ["suppress-output"] + (flagHelp $ parDoc + "suppress the regular output, i.e. the transformed haskell source" + ) + _verbosity <- addSimpleCountFlag + "v" + ["verbose"] + (flagHelp $ parDoc "[currently without effect; TODO]") + checkMode <- addSimpleBoolFlag + "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.text "and print file path(s) of files that have changes to stdout" + ] + ) + ) + writeMode <- addFlagReadParam + "" + ["write-mode"] + "(display|inplace)" + ( flagHelp + (PP.vcat + [ PP.text "display: output for any input(s) goes to stdout" + , PP.text "inplace: override respective input file (without backup!)" + ] + ) + Data.Monoid.<> flagDefault Display + ) + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") + reorderStop + addCmdImpl $ void $ do + when printLicense $ do + print licenseDoc + System.Exit.exitSuccess + when printVersion $ do + do + putStrLn $ "brittany version " ++ showVersion version + 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 + liftIO + $ putStrLn + $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } + $ ppHelpShallow helpDesc + System.Exit.exitSuccess + + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths + + configsToLoad <- liftIO $ if null configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- + runMaybeT + (if noUserConfig + then readConfigs cmdlineConfig configsToLoad + else readConfigsWithUserConfig cmdlineConfig configsToLoad + ) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (config & _conf_debug & _dconf_dump_config & confUnpack) + $ trace (showConfigYaml config) + $ return () + + 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) + 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) + + +data ChangeStatus = Changes | NoChanges + deriving (Eq) + +-- | The main IO parts for the default mode of operation, and after commandline +-- and config stuff is processed. +coreIO + :: (String -> IO ()) -- ^ error output function. In parallel operation, you + -- may want serialize the different outputs and + -- consequently not directly print to stderr. + -> Config -- ^ global program config. + -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so + -- currently not part of program config. + -> Bool -- ^ whether we are (just) in check mode. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. +coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = + ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + 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 + (parseResult, originalContents) <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id + inputString <- liftIO $ System.IO.hGetContents System.IO.stdin + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) + return (parseRes, Text.pack inputString) + Just p -> liftIO $ do + 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 + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + return (parseRes, inputText) + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn left + ExceptT.throwE 60 + Right (anns, parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + of + Left (err, input) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf + when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return + $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + 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 + out' <- if moduleConf & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out', out' /= originalContents) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 + when (not $ null errsWarns) $ do + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{} : _) -> do + putErrorLn + $ "ERROR: brittany pretty printer" + ++ " returned syntactically invalid result." + (ErrorInput str : _) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{} : _) -> do + putErrorLn + $ "WARNING: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast@(L loc _) -> do + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) + when + ( config + & _conf_debug + & _dconf_dump_ast_unknown + & confUnpack + ) + $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + putErrorLn + " -> falling back on exactprint for this element of the module" + warns@(LayoutWarning{} : _) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{} : _) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input : _) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let + hasErrors = + case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = + config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & confUnpack + shouldOutput = + not suppressOutput + && not checkMode + && (not hasErrors || outputOnErrs) + + when shouldOutput + $ addTraceSep (_conf_debug config) + $ case outputPathM of + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges + unless isIdentical $ Text.IO.writeFile p $ outSText + + when (checkMode && hasChanges) $ case inputPathM of + Nothing -> pure () + Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p + + when hasErrors $ ExceptT.throwE 70 + return (if hasChanges then Changes else NoChanges) + where + addTraceSep conf = + if or + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id -- 2.30.2 From 5c64928972c6bed09ae6d44be4070114b595335e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 21 Apr 2020 01:34:31 +0200 Subject: [PATCH 13/17] Fix problem of do notation as left argument of an operator --- src-literatetests/15-regressions.blt | 7 ++++ .../Brittany/Internal/Layouters/Expr.hs | 34 +++++++++++-------- 2 files changed, 27 insertions(+), 14 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index a6a0274..7fa47e0 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -877,3 +877,10 @@ instance HasDependencies SomeDataModel where -- between these data models or whatever. type Dependencies SomeDataModel = (SomeOtherDataModelId, SomeOtherOtherDataModelId) + +#test stupid-do-operator-combination + +func = + do + y + >>= x diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index bc43fe2..660355c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -426,6 +426,9 @@ layoutExpr lexpr@(L _ expr) = do (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True #endif + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line addAlternative @@ -442,16 +445,17 @@ layoutExpr lexpr@(L _ expr) = do -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight -- ] -- two-line - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft -- TODO: this is not forced to single-line, which has - -- certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - ( docForceSingleline + addAlternative $ do + let + expDocOpAndRight = docForceSingleline $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - ) + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + -- TODO: in both cases, we don't force expDocLeft to be + -- single-line, which has certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. -- one-line + par addAlternativeCond allowPar $ docSeq @@ -460,11 +464,13 @@ layoutExpr lexpr@(L _ expr) = do , docForceParSpacing expDocRight ] -- more lines - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) + addAlternative $ do + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ NegApp _ op _ -> do #else -- 2.30.2 From 8c57372bde1f108d8cd8acc79aef0c631ffcbd46 Mon Sep 17 00:00:00 2001 From: Andy Date: Tue, 5 May 2020 10:46:59 +0200 Subject: [PATCH 14/17] Readme: Supports 8.8 --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index df7b22e..6fe5976 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`. +- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. -- 2.30.2 From 2da8bd5e74c0e0dfff1e5dc65d7d3cc145667388 Mon Sep 17 00:00:00 2001 From: Soares Chen Date: Wed, 6 May 2020 13:37:03 +0200 Subject: [PATCH 15/17] Revert change to cabal version --- brittany.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 0bd1271..d99ad17 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,4 +1,3 @@ -cabal-version: 2.2 name: brittany version: 0.12.1.1 synopsis: Haskell source code formatter @@ -9,7 +8,7 @@ description: { . The implementation is documented in more detail . } -license: AGPL-3.0-only +license: AGPL-3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner @@ -17,6 +16,7 @@ copyright: Copyright (C) 2016-2019 Lennart Spitzner Copyright (C) 2019 PRODA LTD category: Language build-type: Simple +cabal-version: 1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: { -- 2.30.2 From 9b8ed90a8fd10dcefb06221691c87886504de46c Mon Sep 17 00:00:00 2001 From: Joe Kachmar Date: Mon, 20 Jul 2020 22:44:02 -0400 Subject: [PATCH 16/17] Allows aeson-1.5.* --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index d99ad17..dc0e796 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -107,7 +107,7 @@ library { , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.12 - , aeson >=1.0.1.0 && <1.5 + , aeson >=1.0.1.0 && <1.6 , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 -- 2.30.2 From 64417c59f4ecb8233b309f69726538325bdc6854 Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Sun, 22 Mar 2020 13:06:04 +0800 Subject: [PATCH 17/17] nondecreasing export list formatting --- src-literatetests/10-tests.blt | 11 ++++------- src-literatetests/15-regressions.blt | 3 +-- src-literatetests/30-tests-context-free.blt | 9 +++------ .../Haskell/Brittany/Internal/Layouters/Module.hs | 11 +++++++---- 4 files changed, 15 insertions(+), 19 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d1138..be8ce52 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1001,8 +1001,7 @@ module Main , test7 , test8 , test9 - ) -where + ) where #test exports-with-comments module Main @@ -1016,8 +1015,7 @@ module Main -- Test 5 , test5 -- Test 6 - ) -where + ) where #test simple-export-with-things module Main (Test(..)) where @@ -1035,7 +1033,7 @@ module Main ( Test(Test, a, b) , foo -- comment2 ) -- comment3 -where + where #test export-with-empty-thing module Main (Test()) where @@ -1286,8 +1284,7 @@ module Test , test9 , test10 -- Test 10 - ) -where + ) where -- Test import Data.List ( nub ) -- Test diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e4c1b7c..e09e41b 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -831,8 +831,7 @@ module Main , DataTypeII(DataConstructor) -- * Haddock heading , name - ) -where + ) where #test type level list diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index ba84a7c..18649a1 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -675,8 +675,7 @@ module Main , test7 , test8 , test9 - ) -where + ) where #test exports-with-comments module Main @@ -690,8 +689,7 @@ module Main -- Test 5 , test5 -- Test 6 - ) -where + ) where #test simple-export-with-things module Main (Test(..)) where @@ -913,8 +911,7 @@ module Test , test8 , test9 , test10 - ) -where + ) where -- Test import Data.List (nub) -- Test diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index cb82c75..f899e08 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -49,6 +49,7 @@ layoutModule lmod@(L _ mod') = case mod' of , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty Just x -> layoutLLIEs True x + , docSeparator , docLit $ Text.pack "where" ] addAlternative @@ -56,11 +57,13 @@ layoutModule lmod@(L _ mod') = case mod' of [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x + (docSeq [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + , docSeparator + , docLit $ Text.pack "where" + ] ) - , docLit $ Text.pack "where" ] ] : map layoutImport imports -- 2.30.2