From 01e31b4256135d594ddc75cb36ef494d0a7ba875 Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sun, 14 Oct 2018 14:28:43 -0400 Subject: [PATCH] Add type fam instance formatting --- src-literatetests/10-tests.blt | 41 ++++++ .../Brittany/Internal/LayouterBasics.hs | 54 +++++--- .../Brittany/Internal/Layouters/Decl.hs | 129 +++++++++++------- 3 files changed, 159 insertions(+), 65 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 15a021e..63e93c0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1141,3 +1141,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/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 6352662..977e8e8 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,40 @@ 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 isRegular <$> astConnectedComments ast + where isRegular = (== 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 isRegular (extractRestComments ann) + where isRegular = (== Nothing) . ExactPrint.Types.commentOrigin . fst + 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..ec3f06f 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,23 @@ 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 + addAlternativeCond (not hasComments) + $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] + addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols + ColTyOpPrefix + [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] -- 2.30.2