From 18b3cfaf88d44ba6d2e1bfc27a3d43eb8381314b Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <evan@evan-borden.com>
Date: Mon, 15 Jan 2018 16:02:14 -0500
Subject: [PATCH 1/4] Fix infix constructor pattern matching for normal
constructors
Brittany was previously only support symbol based infix constructors. It
is common in some libraries (for example Esqueleto) to pattern match on
normal constructors as infix. Brittany was failing in this case by not
wrapping the constructor name in back ticks/spaces. Backticks and spaces
have been added in the case where the constructor contains any alpha
characters.
---
src-literatetests/10-tests.blt | 3 +++
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 5 ++++-
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt
index a3d8591..6659847 100644
--- a/src-literatetests/10-tests.blt
+++ b/src-literatetests/10-tests.blt
@@ -355,6 +355,9 @@ func (x:xr) = x
#pending
func (x:+:xr) = x
+#test normal infix constructor
+func (x `Foo` xr) = x
+
###############################################################################
###############################################################################
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index ebdd91d..2f881a0 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -13,6 +13,7 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
+import Data.Char (isAlpha)
import RdrName ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import HsSyn
@@ -80,7 +81,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
let nameDoc = lrdrNameToText lname
leftDoc <- colsWrapPat =<< layoutPat left
rightDoc <- colsWrapPat =<< layoutPat right
- middle <- docLit nameDoc
+ middle <- docLit $ if Text.any isAlpha nameDoc
+ then Text.pack " `" <> nameDoc <> Text.pack "` "
+ else nameDoc
return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
-- Abc{} -> expr
From 019d47bf7e7a4c4d7cca18b41f9319c6f518ff6e Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <evan@evan-borden.com>
Date: Mon, 15 Jan 2018 19:11:25 -0500
Subject: [PATCH 2/4] Change infix patterns to include spaces
This commit changes infix patterns to utilize `lrdrNameToTextAnn`. This
function allows the logic to avoid introspecting on the constructor
name.
Additionally this adds spaces to all infix operator pattern matches.
Previously infix symbols did not include spaces:
```
foo (x:xs) = _
```
Now they include a space
```
foo (x : xs) = _
```
---
src-literatetests/10-tests.blt | 4 ++--
src-literatetests/15-regressions.blt | 4 ++--
src-literatetests/tests-context-free.blt | 6 +++---
.../Haskell/Brittany/Internal/Layouters/Pattern.hs | 8 +++-----
4 files changed, 10 insertions(+), 12 deletions(-)
diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt
index 6659847..af873df 100644
--- a/src-literatetests/10-tests.blt
+++ b/src-literatetests/10-tests.blt
@@ -349,11 +349,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
func (A a) = a
#test list constructor
-func (x:xr) = x
+func (x : xr) = x
#test some other constructor symbol
#pending
-func (x:+:xr) = x
+func (x :+: xr) = x
#test normal infix constructor
func (x `Foo` xr) = x
diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt
index 0fbc830..5c31ab6 100644
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@@ -123,8 +123,8 @@ func = do
#test list comprehension comment placement
func =
[ (thing, take 10 alts) --TODO: select best ones
- | (thing, _got, alts@(_:_)) <- nosuchFooThing
- , gast <- award
+ | (thing, _got, alts@(_ : _)) <- nosuchFooThing
+ , gast <- award
]
#test if-then-else comment placement
diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt
index e8303cd..0d3d8cf 100644
--- a/src-literatetests/tests-context-free.blt
+++ b/src-literatetests/tests-context-free.blt
@@ -366,11 +366,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
func (A a) = a
#test list constructor
-func (x:xr) = x
+func (x : xr) = x
#test some other constructor symbol
#pending
-func (x:+:xr) = x
+func (x :+: xr) = x
###############################################################################
@@ -748,7 +748,7 @@ func = do
#test list comprehension comment placement
func =
[ (thing, take 10 alts) --TODO: select best ones
- | (thing, _got, alts@(_:_)) <- nosuchFooThing
+ | (thing, _got, alts@(_ : _)) <- nosuchFooThing
, gast <- award
]
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index 2f881a0..317fbe2 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -78,12 +78,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
return $ x1 Seq.<| xR
ConPatIn lname (InfixCon left right) -> do
-- a :< b -> expr
- let nameDoc = lrdrNameToText lname
- leftDoc <- colsWrapPat =<< layoutPat left
+ let nameDoc = lrdrNameToTextAnn lname
+ leftDoc <- appSep . colsWrapPat =<< layoutPat left
rightDoc <- colsWrapPat =<< layoutPat right
- middle <- docLit $ if Text.any isAlpha nameDoc
- then Text.pack " `" <> nameDoc <> Text.pack "` "
- else nameDoc
+ middle <- appSep . docLit =<< nameDoc
return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
-- Abc{} -> expr
From eb8f0de6c3b04505f2350137ce41308c25149c54 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <evan@evan-borden.com>
Date: Mon, 15 Jan 2018 19:15:51 -0500
Subject: [PATCH 3/4] Remove redundant import.
---
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 1 -
1 file changed, 1 deletion(-)
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index 317fbe2..c04790d 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -13,7 +13,6 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
-import Data.Char (isAlpha)
import RdrName ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import HsSyn
From 077b93db016123ba58aed9568fef05bfeb0dd7f8 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Fri, 9 Feb 2018 16:50:57 +0100
Subject: [PATCH 4/4] Minor refactor
---
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index c04790d..51bb03a 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -77,10 +77,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
return $ x1 Seq.<| xR
ConPatIn lname (InfixCon left right) -> do
-- a :< b -> expr
- let nameDoc = lrdrNameToTextAnn lname
- leftDoc <- appSep . colsWrapPat =<< layoutPat left
+ nameDoc <- lrdrNameToTextAnn lname
+ leftDoc <- appSep . colsWrapPat =<< layoutPat left
rightDoc <- colsWrapPat =<< layoutPat right
- middle <- appSep . docLit =<< nameDoc
+ middle <- appSep $ docLit nameDoc
return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
-- Abc{} -> expr