unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-11-13 09:55:35 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2654 from unisonweb/topic/fixGuardBreaks

Browse Source 
Fix line breaks in guards with long patterns
This commit is contained in:
Rúnar 2021-12-02 13:05:15 -05:00 committed by GitHub
commit 055e355433
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 235 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -307,11 +307,12 @@ pretty0
-- this let block provides to add a use statement. Not so bad.
(fmt S.ControlKeyword "let") `PP.hang` x
lhs = PP.group (fst (prettyPattern n (ac 0 Block im doc) 10 vs pat))
<> printGuard guard
`PP.hang` printGuard guard
printGuard Nothing = mempty
printGuard (Just g') = let (_,g) = ABT.unabs g' in
PP.group $ PP.spaced [(fmt S.DelimiterChar " |"), pretty0 n (ac 2 Normal im doc) g]
eq = fmt S.BindingEquals " ="
printGuard (Just g') =
let (_,g) = ABT.unabs g'
in (fmt S.DelimiterChar "| ") <> pretty0 n (ac 2 Normal im doc) g
eq = fmt S.BindingEquals "="
rhs =
let (im', uses) = calcImports im scrutinee in
uses $ [pretty0 n (ac (-1) Block im' doc) scrutinee]
@ -550,51 +551,52 @@ printCase
-> DocLiteralContext
-> [MatchCase' () (Term3 v PrintAnnotation)]
-> Pretty SyntaxText
printCase env im doc ms0 = PP.lines $ map each gridArrowsAligned where
printCase env im doc ms0 = PP.lines $ alignGrid grid where
ms = groupCases ms0
each (lhs, arrow, body) = PP.group $ (lhs <> arrow) `PP.hang` body
grid = go =<< ms
gridArrowsAligned = tidy <$> zip (PP.align' (f <$> grid)) grid where
f (a, b, _) = (a, Just b)
tidy ((a', b'), (_, _, c)) = (a', b', c)
justify rows =
zip (fmap fst . PP.align' $ fmap alignPatterns rows) $ fmap gbs rows
where
alignPatterns (p, _, _) = (p, Just "")
gbs (_, gs, bs) = zip gs bs
alignGrid = fmap alignCase . justify
alignCase (p, gbs) =
if not (null (drop 1 gbs)) then PP.hang p guardBlock
else p <> guardBlock
where
guardBlock = PP.lines
$ fmap (\(g, (a, b)) -> PP.hang (PP.group (g <> a)) b) justified
justified = PP.leftJustify $ fmap (\(g, b) -> (g, (arrow, b))) gbs
grid = go <$> ms
patLhs vs pats = case pats of
[pat] -> PP.group (fst (prettyPattern env (ac 0 Block im doc) (-1) vs pat))
pats -> PP.group . PP.sep ("," <> PP.softbreak) . (`evalState` vs) . for pats $ \pat -> do
pats -> PP.group . PP.sep ("," <> PP.softbreak)
. (`evalState` vs)
. for pats $ \pat -> do
vs <- State.get
let (p, rem) = prettyPattern env (ac 0 Block im doc) (-1) vs pat
State.put rem
pure p
arrow = fmt S.ControlKeyword "->"
goBody im' uses body = uses [pretty0 env (ac 0 Block im' doc) body]
printGuard (Just (ABT.AbsN' _ g)) =
-- strip off any Abs-chain around the guard, guard variables are rendered
-- like any other variable, ex: case Foo x y | x < y -> ...
PP.group $ PP.spaced [(fmt S.DelimiterChar " |"), pretty0 env (ac 2 Normal im doc) g]
printGuard Nothing = mempty
go (pats, vs, [(guard, body)]) =
[(lhs, arrow, goBody im' uses body)]
where
lhs = patLhs vs pats <> printGuard guard
(im', uses) = calcImports im body
-- If there's multiple guarded cases for this pattern, prints as:
-- MyPattern x y
-- | guard 1 -> 1
-- | otherguard x y -> 2
-- | otherwise -> 3
go (pats, vs, unzip -> (guards, bodies)) =
(patLhs vs pats, mempty, mempty)
: zip3 (PP.indentN 2 . printGuard <$> guards)
(repeat arrow)
(printBody <$> bodies)
where
printGuard Nothing = (fmt S.DelimiterChar "|") <> fmt S.ControlKeyword " otherwise"
(patLhs vs pats, printGuard <$> guards, printBody <$> bodies)
where
noGuards = all (== Nothing) guards
printGuard Nothing | noGuards = mempty
printGuard Nothing =
fmt S.DelimiterChar "|" <> " " <> fmt S.ControlKeyword "otherwise"
printGuard (Just (ABT.AbsN' _ g)) =
PP.group $ PP.spaced [(fmt S.DelimiterChar "|"), pretty0 env (ac 2 Normal im doc) g]
printBody b = let (im', uses) = calcImports im b
in goBody im' uses b
-- strip off any Abs-chain around the guard, guard variables are rendered
-- like any other variable, ex: case Foo x y | x < y -> ...
PP.spaceIfNeeded (fmt S.DelimiterChar "|") $
pretty0 env (ac 2 Normal im doc) g
printBody b = let (im', uses) = calcImports im b in goBody im' uses b
{- Render a binding, producing output of the form

32
parser-typechecker/src/Unison/Util/Pretty.hs
View File

@ -51,6 +51,7 @@ module Unison.Util.Pretty (
hangUngrouped,
softHang',
softHang,
softHangNoSpace',
indent,
indentAfterNewline,
indentN,
@ -58,6 +59,7 @@ module Unison.Util.Pretty (
indentNAfterNewline,
invert,
isMultiLine,
isEmpty,
leftPad,
lines,
linesNonEmpty,
@ -68,6 +70,7 @@ module Unison.Util.Pretty (
nest,
num,
newline,
leftJustify,
lineSkip,
nonEmpty,
numbered,
@ -89,6 +92,7 @@ module Unison.Util.Pretty (
shown,
softbreak,
spaceIfBreak,
spaceIfNeeded,
spaced,
spacedMap,
spacesIfBreak,
@ -157,6 +161,9 @@ data F s r
| Append (Seq r)
deriving (Eq, Show, Foldable, Traversable, Functor)
isEmpty :: Eq s => IsString s => Pretty s -> Bool
isEmpty s = out s == Empty || out s == Lit ""
mapLit :: (s -> t) -> F s r -> F t r
mapLit f (Lit s) = Lit (f s)
mapLit _ Empty = Empty
@ -346,6 +353,9 @@ newline = "\n"
lineSkip :: IsString s => Pretty s
lineSkip = newline <> newline
spaceIfNeeded :: Eq s => IsString s => Pretty s -> Pretty s -> Pretty s
spaceIfNeeded a b = if isEmpty a then b else a <> " " <> b
spaceIfBreak :: IsString s => Pretty s
spaceIfBreak = "" `orElse` " "
@ -628,6 +638,19 @@ wrapColumn2 rows = lines (align rows) where
| (l, r) <- rows
]
-- Pad with enough space on the right to make all rows the same width
leftJustify
:: (Eq s, Show s, LL.ListLike s Char, IsString s)
=> [(Pretty s, a)]
-> [(Pretty s, a)]
leftJustify rows = zip
(fmap fst . align' $ fmap
(\x -> (x, if isEmpty x then Nothing else Just ""))
ss
)
as
where (ss, as) = unzip rows
align
:: (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> [Pretty s]
align rows = (((uncurry (<>)) <$>) . align') (second Just <$> rows)
@ -708,6 +731,15 @@ softHang' :: (LL.ListLike s Char, IsString s)
softHang' from by p = group $
(from <> " " <> group p) `orElse` (from <> "\n" <> group (indent by p))
softHangNoSpace'
:: (LL.ListLike s Char, IsString s)
=> Pretty s
-> Pretty s
-> Pretty s
-> Pretty s
softHangNoSpace' from by p =
group $ (from <> group p) `orElse` (from <> "\n" <> group (indent by p))
-- Same as `hang`, except instead of indenting by two spaces, it indents by
-- the `by` argument.
hang'

6
parser-typechecker/tests/Unison/Test/TermPrinter.hs
View File

@ -235,9 +235,11 @@ test = scope "termprinter" $ tests
\ 12 -> x\n\
\ 13 -> y\n\
\ 14 -> z"
-- These used to align, but alignment looked very bad when guards were long.
-- -- R.Ó.B.
, tcBreaks 21 "match x with\n\
\ 12 | p x -> x\n\
\ 13 | q x -> y\n\
\ 12 | p x -> x\n\
\ 13 | q x -> y\n\
\ 14 | r x y -> z"
, tcBreaks 9 "match x with\n\
\ 112 ->\n\

28
unison-src/transcripts-round-trip/main.md
View File

@ -255,3 +255,31 @@ x = 2
.> add
```
## Guard patterns on long lines
```unison:hide
structural type SomethingUnusuallyLong = SomethingUnusuallyLong Text Text Text
foo = let
go x =
'match (a -> a) x with
SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij |
lijaefliejalfijelfj == aefilaeifhlei -> 0
SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij |
lijaefliejalfijelfj == liaehjffeafijij -> 1
go (SomethingUnusuallyLong "one" "two" "three")
```
```ucm
.> add
.> edit SomethingUnusuallyLong foo
.> undo
```
```ucm
.> load scratch.u
.> add
```

188
unison-src/transcripts-round-trip/main.output.md
View File

@ -34,15 +34,15 @@ x = 1 + 1
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #umob2h2nfc .old` to make an old namespace
`fork #oqt1jsjk91 .old` to make an old namespace
accessible again,
`reset-root #umob2h2nfc` to reset the root namespace and
`reset-root #oqt1jsjk91` to reset the root namespace and
its history to that of the
specified namespace.
1. #ec8bplo3a5 : add
2. #umob2h2nfc : builtins.mergeio
1. #hmq8ode0gs : add
2. #oqt1jsjk91 : builtins.mergeio
3. #sjg2v58vn2 : (initial reflogged namespace)
.> reset-root 2
@ -116,17 +116,17 @@ Without the above stanza, the `edit` will send the definition to the most recent
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #umob2h2nfc .old` to make an old namespace
`fork #oqt1jsjk91 .old` to make an old namespace
accessible again,
`reset-root #umob2h2nfc` to reset the root namespace and
`reset-root #oqt1jsjk91` to reset the root namespace and
its history to that of the
specified namespace.
1. #nf6v4skcpk : add
2. #umob2h2nfc : reset-root #umob2h2nfc
3. #ec8bplo3a5 : add
4. #umob2h2nfc : builtins.mergeio
1. #e5ctdurcur : add
2. #oqt1jsjk91 : reset-root #oqt1jsjk91
3. #hmq8ode0gs : add
4. #oqt1jsjk91 : builtins.mergeio
5. #sjg2v58vn2 : (initial reflogged namespace)
.> reset-root 2
@ -191,19 +191,19 @@ f x = let
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #umob2h2nfc .old` to make an old namespace
`fork #oqt1jsjk91 .old` to make an old namespace
accessible again,
`reset-root #umob2h2nfc` to reset the root namespace and
`reset-root #oqt1jsjk91` to reset the root namespace and
its history to that of the
specified namespace.
1. #6u70tqt1nb : add
2. #umob2h2nfc : reset-root #umob2h2nfc
3. #nf6v4skcpk : add
4. #umob2h2nfc : reset-root #umob2h2nfc
5. #ec8bplo3a5 : add
6. #umob2h2nfc : builtins.mergeio
1. #ql7sn0ps1v : add
2. #oqt1jsjk91 : reset-root #oqt1jsjk91
3. #e5ctdurcur : add
4. #oqt1jsjk91 : reset-root #oqt1jsjk91
5. #hmq8ode0gs : add
6. #oqt1jsjk91 : builtins.mergeio
7. #sjg2v58vn2 : (initial reflogged namespace)
.> reset-root 2
@ -273,21 +273,21 @@ h xs = match xs with
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #umob2h2nfc .old` to make an old namespace
`fork #oqt1jsjk91 .old` to make an old namespace
accessible again,
`reset-root #umob2h2nfc` to reset the root namespace and
`reset-root #oqt1jsjk91` to reset the root namespace and
its history to that of the
specified namespace.
1. #8cfe45q2aq : add
2. #umob2h2nfc : reset-root #umob2h2nfc
3. #6u70tqt1nb : add
4. #umob2h2nfc : reset-root #umob2h2nfc
5. #nf6v4skcpk : add
6. #umob2h2nfc : reset-root #umob2h2nfc
7. #ec8bplo3a5 : add
8. #umob2h2nfc : builtins.mergeio
1. #q6qaupqk4a : add
2. #oqt1jsjk91 : reset-root #oqt1jsjk91
3. #ql7sn0ps1v : add
4. #oqt1jsjk91 : reset-root #oqt1jsjk91
5. #e5ctdurcur : add
6. #oqt1jsjk91 : reset-root #oqt1jsjk91
7. #hmq8ode0gs : add
8. #oqt1jsjk91 : builtins.mergeio
9. #sjg2v58vn2 : (initial reflogged namespace)
.> reset-root 2
@ -353,23 +353,23 @@ foo n _ = n
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #umob2h2nfc .old` to make an old namespace
`fork #oqt1jsjk91 .old` to make an old namespace
accessible again,
`reset-root #umob2h2nfc` to reset the root namespace and
`reset-root #oqt1jsjk91` to reset the root namespace and
its history to that of the
specified namespace.
1. #lrkr6m9s84 : add
2. #umob2h2nfc : reset-root #umob2h2nfc
3. #8cfe45q2aq : add
4. #umob2h2nfc : reset-root #umob2h2nfc
5. #6u70tqt1nb : add
6. #umob2h2nfc : reset-root #umob2h2nfc
7. #nf6v4skcpk : add
8. #umob2h2nfc : reset-root #umob2h2nfc
9. #ec8bplo3a5 : add
10. #umob2h2nfc : builtins.mergeio
1. #75hol9q7nl : add
2. #oqt1jsjk91 : reset-root #oqt1jsjk91
3. #q6qaupqk4a : add
4. #oqt1jsjk91 : reset-root #oqt1jsjk91
5. #ql7sn0ps1v : add
6. #oqt1jsjk91 : reset-root #oqt1jsjk91
7. #e5ctdurcur : add
8. #oqt1jsjk91 : reset-root #oqt1jsjk91
9. #hmq8ode0gs : add
10. #oqt1jsjk91 : builtins.mergeio
11. #sjg2v58vn2 : (initial reflogged namespace)
.> reset-root 2
@ -432,25 +432,25 @@ foo =
most recent, along with the command that got us there. Try:
`fork 2 .old`
`fork #umob2h2nfc .old` to make an old namespace
`fork #oqt1jsjk91 .old` to make an old namespace
accessible again,
`reset-root #umob2h2nfc` to reset the root namespace and
`reset-root #oqt1jsjk91` to reset the root namespace and
its history to that of the
specified namespace.
1. #4bomvvof2t : add
2. #umob2h2nfc : reset-root #umob2h2nfc
3. #lrkr6m9s84 : add
4. #umob2h2nfc : reset-root #umob2h2nfc
5. #8cfe45q2aq : add
6. #umob2h2nfc : reset-root #umob2h2nfc
7. #6u70tqt1nb : add
8. #umob2h2nfc : reset-root #umob2h2nfc
9. #nf6v4skcpk : add
10. #umob2h2nfc : reset-root #umob2h2nfc
11. #ec8bplo3a5 : add
12. #umob2h2nfc : builtins.mergeio
1. #j2jte1lhh2 : add
2. #oqt1jsjk91 : reset-root #oqt1jsjk91
3. #75hol9q7nl : add
4. #oqt1jsjk91 : reset-root #oqt1jsjk91
5. #q6qaupqk4a : add
6. #oqt1jsjk91 : reset-root #oqt1jsjk91
7. #ql7sn0ps1v : add
8. #oqt1jsjk91 : reset-root #oqt1jsjk91
9. #e5ctdurcur : add
10. #oqt1jsjk91 : reset-root #oqt1jsjk91
11. #hmq8ode0gs : add
12. #oqt1jsjk91 : builtins.mergeio
13. #sjg2v58vn2 : (initial reflogged namespace)
.> reset-root 2
@ -759,3 +759,83 @@ x = 2
⊡ Ignored previously added definitions: docTest2
```
## Guard patterns on long lines
```unison
structural type SomethingUnusuallyLong = SomethingUnusuallyLong Text Text Text
foo = let
go x =
'match (a -> a) x with
SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij |
lijaefliejalfijelfj == aefilaeifhlei -> 0
SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij |
lijaefliejalfijelfj == liaehjffeafijij -> 1
go (SomethingUnusuallyLong "one" "two" "three")
```
```ucm
.> add
⍟ I've added these definitions:
structural type SomethingUnusuallyLong
foo : 'Nat
.> edit SomethingUnusuallyLong foo
☝️
I added these definitions to the top of
/Users/runar/work/unison/scratch.u
structural type SomethingUnusuallyLong
= SomethingUnusuallyLong Text Text Text
foo : 'Nat
foo =
go x =
'match (a -> a) x with
SomethingUnusuallyLong
lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij
| lijaefliejalfijelfj == aefilaeifhlei -> 0
| lijaefliejalfijelfj == liaehjffeafijij -> 1
go (SomethingUnusuallyLong "one" "two" "three")
You can edit them there, then do `update` to replace the
definitions currently in this namespace.
.> undo
Here are the changes I undid
Added definitions:
1. structural type SomethingUnusuallyLong
2. SomethingUnusuallyLong.SomethingUnusuallyLong : Text
-> Text
-> Text
-> #l6si6n2hsl
3. foo : 'Nat
```
```ucm
.> load scratch.u
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
structural type SomethingUnusuallyLong
foo : 'Nat
.> add
⍟ I've added these definitions:
structural type SomethingUnusuallyLong
foo : 'Nat
```

6
unison-src/transcripts/lambdacase.output.md
View File

@ -195,9 +195,9 @@ merge3 = cases
merge3 = cases
[], ys -> ys
xs, [] -> xs
h +: t, h2 +: t2
| h <= h2 -> h +: merge3 t (h2 +: t2)
| otherwise -> h2 +: merge3 (h +: t) t2
h +: t, h2 +: t2
| h <= h2 -> h +: merge3 t (h2 +: t2)
| otherwise -> h2 +: merge3 (h +: t) t2
```
This is the same definition written with multiple patterns and not using the `cases` syntax; notice it is considered an alias of `merge3` above.