From 66fd44058d28e579a9141ce051adb96963260bb7 Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sat, 6 Oct 2018 19:01:13 -0400 Subject: [PATCH 1/2] Add instance formatting for simple case --- src-literatetests/10-tests.blt | 108 +++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 147 +++++++++++++++--- stack-8.4.3.yaml | 4 + 3 files changed, 237 insertions(+), 22 deletions(-) create mode 100644 stack-8.4.3.yaml diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index db6cbde..1597c4b 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -905,3 +905,111 @@ import qualified Data.List as L -- Test import Test ( test ) + +############################################################################### +############################################################################### +############################################################################### +#group class.instance +############################################################################### +############################################################################### +############################################################################### + +#test simple-instance + +instance MyClass Int where + myMethod x = x + 1 + +#test simple-method-signature + +instance MyClass Int where + myMethod :: Int -> Int + myMethod x = x + 1 + +#test simple-long-method-signature + +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + +#test simple-two-methods + +instance MyClass Int where + myMethod x = x + 1 + myMethod2 x = x + 1 + +#test simple-two-signatures + +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + + myMethod2 :: Int -> Int + myMethod2 x = x + 1 + +#test simple-instance-comment + +-- | This instance should be commented on +instance MyClass Int where + + -- | This method is also comment-worthy + myMethod x = x + 1 + +#test instance-with-type-family + +instance MyClass Int where + type MyType = Int + + myMethod :: MyType -> Int + myMethod x = x + 1 + +#test instance-with-type-family-below-method + +instance MyClass Int where + + type MyType = String + + myMethod :: MyType -> Int + myMethod x = x + 1 + + type MyType = Int + +#test instance-with-data-family + +instance MyClass Int where + + -- | This data is very important + data MyData = IntData + { intData :: String + , intData2 :: Int + } + + myMethod :: MyData -> Int + myMethod = intData2 + +#test instance-with-data-family-below-method + +instance MyClass Int where + -- | This data is important + data MyData = Test Int Int + + myMethod :: MyData -> Int + myMethod = intData2 + + -- | This data is also important + data MyData2 = IntData + { intData :: String + -- ^ Interesting field + , intData2 :: Int + } diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 4d0440f..6ca5075 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -27,7 +27,7 @@ import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils import GHC ( runGhc, GenLocated(L), moduleNameString ) -import SrcLoc ( SrcSpan, noSrcSpan ) +import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name import BasicTypes ( InlinePragma(..) @@ -42,7 +42,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Bag ( mapBagM ) +import Bag ( mapBagM, bagToList, emptyBag ) @@ -65,16 +65,42 @@ layoutDecl d@(L loc decl) = case decl of (foldedAnnKeys d) False (Text.pack str) + InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - TypeSig names (HsWC _ (HsIB _ typ _)) -> docWrapNode lsig $ do + TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ #else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do + TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ #endif + InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> + docWrapNode lsig $ do + nameStr <- lrdrNameToTextAnn name + specStr <- specStringCompat lsig spec + let phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ +#else /* ghc-8.0 */ + ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ +#endif + _ -> briDocByExactNoComment lsig -- TODO + where + layoutNamesAndType names typ = docWrapNode lsig $ do nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -112,24 +138,7 @@ layoutSig lsig@(L _loc sig) = case sig of ] ) ] - InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - _ -> briDocByExactNoComment lsig -- TODO + specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String @@ -585,3 +594,97 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + +-- | Layout an @instance@ declaration +-- +-- Layout signatures and bindings using the corresponding layouters from the +-- top-level. Layout the instance head, type family instances, and data family +-- instances using ExactPrint. +layoutClsInst :: ToBriDoc ClsInstDecl +layoutClsInst lcid@(L _ cid) = docLines + [ layoutInstanceHead + , docEnsureIndent BrIndentRegular + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) + ] + where + layoutInstanceHead :: ToBriDocM BriDocNumbered + layoutInstanceHead = + briDocByExactNoComment $ InstD . ClsInstD . removeChildren <$> lcid + + removeChildren :: ClsInstDecl p -> ClsInstDecl p + removeChildren c = c + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + } + + -- | Like 'docLines', but sorts the lines based on location + docSortedLines + :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered + docSortedLines l = + allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l + + layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig + + layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind lbind@(L loc _) = + L loc <$> (joinBinds =<< layoutBind lbind) + + joinBinds + :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered + joinBinds = \case + Left ns -> docLines $ return <$> ns + Right n -> return n + + 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 + + layoutAndLocateDataFamInsts + :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateDataFamInsts ldfid@(L loc _) = + L loc <$> layoutDataFamInstDecl ldfid + + -- | Send to ExactPrint then remove unecessary whitespace + layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl ldfid = + fmap stripWhitespace <$> briDocByExactNoComment ldfid + + -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations + stripWhitespace :: BriDocF f -> BriDocF f + stripWhitespace (BDFExternal ann anns b t) = + BDFExternal ann anns b $ stripWhitespace' t + stripWhitespace b = b + + -- | We strip the first newline from each @data@/@type@ declaration. If the + -- @data@/@type@ is the first declaration in the instance, then we also have + -- to strip whitespace from the start of the comments and the first line of + -- the declaration. This is brittle and should be replaced by proper + -- layouting + -- as soon as possible. + stripWhitespace' :: Text -> Text + stripWhitespace' t = + let + isTypeOrData t' = + Text.pack "type" + `Text.isPrefixOf` t' + || Text.pack "data" + `Text.isPrefixOf` t' + (comments, dat : rest) = + break (isTypeOrData . Text.stripStart) (Text.lines (Text.tail t)) + in Text.init + $ Text.unlines + $ fmap Text.stripStart comments + ++ (Text.stripStart dat : rest) diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml new file mode 100644 index 0000000..f925568 --- /dev/null +++ b/stack-8.4.3.yaml @@ -0,0 +1,4 @@ +resolver: lts-12.12 + +extra-deps: + - ghc-exactprint-0.5.8.1 -- 2.30.2 From 38216cdc02fa13bf2beca957f0ab49b8cb10cb4c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 11 Oct 2018 20:14:29 +0200 Subject: [PATCH 2/2] Add longer doc/Refactor stripWhitespace' --- .../Brittany/Internal/Layouters/Decl.hs | 66 ++++++++++++++----- 1 file changed, 48 insertions(+), 18 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 6ca5075..2ece967 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -668,23 +668,53 @@ layoutClsInst lcid@(L _ cid) = docLines BDFExternal ann anns b $ stripWhitespace' t stripWhitespace b = b - -- | We strip the first newline from each @data@/@type@ declaration. If the - -- @data@/@type@ is the first declaration in the instance, then we also have - -- to strip whitespace from the start of the comments and the first line of - -- the declaration. This is brittle and should be replaced by proper - -- layouting - -- as soon as possible. + -- | This fixes two issues of output coming from Exactprinting + -- associated (data) type decls. Firstly we place the output into docLines, + -- so one newline coming from Exactprint is superfluous, so we drop the + -- first (empty) line. The second issue is Exactprint indents the first + -- member in a strange fashion: + -- + -- input: + -- + -- > instance MyClass Int where + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- output of just exactprinting the associated data type syntax node + -- + -- > + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- To fix this, we strip whitespace from the start of the comments and the + -- first line of the declaration, stopping when we see "data" or "type" at + -- the start of a line. I.e., this function yields + -- + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- Downside apart from being a hacky and brittle fix is that this removes + -- possible additional indentation from comments before the first member. + -- + -- But the whole thing is just a temporary measure until brittany learns + -- to layout data/type decls. stripWhitespace' :: Text -> Text stripWhitespace' t = - let - isTypeOrData t' = - Text.pack "type" - `Text.isPrefixOf` t' - || Text.pack "data" - `Text.isPrefixOf` t' - (comments, dat : rest) = - break (isTypeOrData . Text.stripStart) (Text.lines (Text.tail t)) - in Text.init - $ Text.unlines - $ fmap Text.stripStart comments - ++ (Text.stripStart dat : rest) + Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t + where + go [] = [] + go (line1 : lineR) = case Text.stripStart line1 of + st | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR + isTypeOrData t' = + (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "data" `Text.isPrefixOf` t') -- 2.30.2