From dfa3fef56c0de2539931e0be4049a27b087aab7e Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Tue, 25 Feb 2020 22:04:48 +0000 Subject: [PATCH 1/7] 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 2d07900005fd3535bcaae91e05cad9dc49be5fb5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:50:42 +0100 Subject: [PATCH 2/7] 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 3/7] 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 4/7] 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 5/7] 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 6/7] 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 7/7] 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