Support as-patterns in pattern synonyms with view patterns

[expipiplus1]

I guess a bit of a WIP, Maybe needs neatening and tests

See #174

[expipiplus1]

View patterns too, a tiny change on top of as-patterns.

[RyanGlScott]

Thanks for the patch! I haven't had a chance to look at the finer details of how this works, but the general idea looks right.

Two possible ideas for making the generated code a bit more compact:

1. This:

   pattern P x <- (id -> x)

   Currently desugars to this:

   pattern P x_1 <- (\arg_2 -> case arg_2 of
                                   viewed_3 -> case GHC.Base.id viewed_3 of
                                                   x_1 -> x_1 -> x_1)

   The first case expression isn't necessary, as it just binds a simple viewed_3. Nor is arg_2 used anywhere in the remainder of the expression. I think it should be possible to check if the very first pattern to be bound (viewed_3, in this example) is a bare DVarP, and if so, elide the intermediate case expression.

2. Regarding your "uncomfortable unpacking/repacking" comment at Pattern guards are not a sufficient replacement for view patterns #174 (comment), what if instead of desugaring this:

   data Foo a b = Foo a b
   
   pattern P x a b <- x@(Foo a b)

   To this (cleaned up slightly):

   pattern P x_1 a_2 b_3 <- ((\x_1 -> case x_1 of Foo a_2 b_3 -> (x_1, a_2, b_3)) -> (x_1, a_2, b_3))

   We instead desugared to something like this?

   pattern P x_1 a_2 b_3 <- ((\x_1 -> (x_1, x_1)) -> (x_1, Foo a_2 b_3))

   That is, if a pattern doesn't contain any view patterns or as-patterns as subpatterns, then match on it in the pattern to the right of the -> instead of matching on it in the expression to the left of the ->. This avoids having to unpack it in the expression on the left only to repack it again for the benefit of the pattern on the right.

I haven't thought deeply about how to implement these ideas, so I'm not sure if they work well with the current approach to desugaring patterns.

[expipiplus1]

ok, I think I've addressed the comments, as well as added view pattern support everywhere (it fell out very naturally)

I've keps dsPatX around for a deprecation cycle if we care about that.

[expipiplus1]

err, actually I think there's a bug here I still need to sort!

[expipiplus1]

The bug here is that now dsPatOverExp return a less fallible pattern, having moved most of the matching on as-patterns into the subsequent let expression. The consequence of this is apparent in the following:

do 
  let xs = [1,2]
  x@1 <- xs
  pure x

This used to desugar to the equivalent of:

do 
  let xs = [1,2]
  1 <- xs
  let x = 1
  pure x

But now it desugars to the equivalent of:

do
  let xs  = [1,2]
  x <- xs
  let 1 = x
  pure x

Apart from it being incorrect, I do prefer the second one as there isn't any pattern -> expression transmutation happening.

[RyanGlScott]

OK. I could take a look, but there is currently a build failure in the patch, as caught by CI:

[ 9 of 14] Compiling Language.Haskell.TH.Desugar.Core ( Language/Haskell/TH/Desugar/Core.hs, /__w/th-desugar/th-desugar/dist-newstyle/build/x86_64-linux/ghc-9.2.2/th-desugar-1.14/build/Language/Haskell/TH/Desugar/Core.o, /__w/th-desugar/th-desugar/dist-newstyle/build/x86_64-linux/ghc-9.2.2/th-desugar-1.14/build/Language/Haskell/TH/Desugar/Core.dyn_o )

Language/Haskell/TH/Desugar/Core.hs:806:22: error:
    Variable not in scope:
      dsPatWithViewPatterns :: Pat -> q (DPat, t0 (DPat, DExp))
    |
806 |   (pat', subPats) <- dsPatWithViewPatterns pat
    |                      ^^^^^^^^^^^^^^^^^^^^^

Language/Haskell/TH/Desugar/Core.hs:950:19: error:
    Variable not in scope:
      dsPatWithViewPatterns :: Pat -> q (DPat, [(DPat, DExp)])
    |
950 |   (pat', vars) <- dsPatWithViewPatterns pat
    |                   ^^^^^^^^^^^^^^^^^^^^^

[expipiplus1]

Ah, I didn't mean that I had uncovered an existing bug; I've introduced a new one. Before the "extra patterns" were designed/assumed to be infallible, but now they're not which leads to problems in do notation.

It shouldn't be the end of the world to fix, although it's tempting just to reinstate the old "no view patterns" behaviour.

[RyanGlScott]

It shouldn't be the end of the world to fix, although it's tempting just to reinstate the old "no view patterns" behaviour.

OK. For what it's worth, I would be fine with reinstating the old behavior, opening a separate issue to track the remaining tasks.

[expipiplus1]

Ok, I reverted to the previous behaviour and opened #177

[RyanGlScott]

Thank you so much for your continued work on this!

As one last suggestion, do you feel up to adding some test cases exercising this new functionality?

[RyanGlScott]

This changes the way that let bindings are desugared, which is more ambitious than the title of the PR would suggest. I haven't thought deeply about this change, but could this potentially run into issues similar to the ones documented in #177? Or is this change fine because let bindings don't treat fallible patterns the same way that do-notation does?

[expipiplus1]

Good catch, it does actually change the meaning, however neither are always correct!

I've opened #178

[expipiplus1]

I'll keep the existing behaviour for now.

[expipiplus1]

Thank you for taking the time for a thorough review @RyanGlScott!

For the tests, it would be really nice to be able to describe them like so

test_t175 :: [Assertion]
test_t175 =
  fmap (uncurry (@=?))
  $(do
    Syn.lift =<< (traverse
      (\(a, e) -> (,) <$> (sweeten @_ @[DDec] <$> (desugar =<< a)) <*> e)
      [ ( [d| pattern P = (id -> ()) |]
        , [d| pattern P = (\x -> case id x of () -> () -> ()) |]
        )
      , ( [d| pattern P x <- x@3 |]
        , [d| pattern P x <- (\x -> case x of 3 -> x -> x) |]
        )
      , ([d| pattern P = ()|], [d| pattern P = ()|])
      ])
   )

But with something instead of @=? which checks up to alpha-equivalence. I couldn't find anything in th-desugar for this kind of test. Would this be something worth adding or is there a simpler test-setup you'd recommend?

[RyanGlScott]

Most of the unit tests are located here:

th-desugar/Test/Run.hs

Lines 77 to 154 in 92c07bd

	tests :: Test
	tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections)
	, "lampats" ~: $test2_lampats @=? $(dsSplice test2_lampats)
	, "lamcase" ~: $test3_lamcase @=? $(dsSplice test3_lamcase)
	-- Must fix nested pattern-matching for this to work. Argh.
	-- , "tuples" ~: $test4_tuples @=? $(dsSplice test4_tuples)
	, "ifs" ~: $test5_ifs @=? $(dsSplice test5_ifs)
	, "ifs2" ~: $test6_ifs2 @=? $(dsSplice test6_ifs2)
	, "let" ~: $test7_let @=? $(dsSplice test7_let)
	, "case" ~: $test8_case @=? $(dsSplice test8_case)
	, "do" ~: $test9_do @=? $(dsSplice test9_do)
	, "comp" ~: $test10_comp @=? $(dsSplice test10_comp)
	, "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp)
	, "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2)
	, "sig" ~: $test13_sig @=? $(dsSplice test13_sig)
	, "record" ~: $test14_record @=? $(dsSplice test14_record)
	, "litp" ~: $test15_litp @=? $(dsSplice test15_litp)
	, "tupp" ~: $test16_tupp @=? $(dsSplice test16_tupp)
	, "infixp" ~: $test17_infixp @=? $(dsSplice test17_infixp)
	, "tildep" ~: $test18_tildep @=? $(dsSplice test18_tildep)
	, "bangp" ~: $test19_bangp @=? $(dsSplice test19_bangp)
	, "asp" ~: $test20_asp @=? $(dsSplice test20_asp)
	, "wildp" ~: $test21_wildp @=? $(dsSplice test21_wildp)
	, "listp" ~: $test22_listp @=? $(dsSplice test22_listp)
	#if __GLASGOW_HASKELL__ >= 801
	, "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp)
	#endif
	, "fun" ~: $test24_fun @=? $(dsSplice test24_fun)
	, "fun2" ~: $test25_fun2 @=? $(dsSplice test25_fun2)
	, "forall" ~: $test26_forall @=? $(dsSplice test26_forall)
	, "kisig" ~: $test27_kisig @=? $(dsSplice test27_kisig)
	, "tupt" ~: $test28_tupt @=? $(dsSplice test28_tupt)
	, "listt" ~: $test29_listt @=? $(dsSplice test29_listt)
	, "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted)
	, "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint)
	, "tylit" ~: $test32_tylit @=? $(dsSplice test32_tylit)
	, "tvbs" ~: $test33_tvbs @=? $(dsSplice test33_tvbs)
	, "let_as" ~: $test34_let_as @=? $(dsSplice test34_let_as)
	, "pred" ~: $test37_pred @=? $(dsSplice test37_pred)
	, "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2)
	, "eq" ~: $test39_eq @=? $(dsSplice test39_eq)
	, "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards)
	#if __GLASGOW_HASKELL__ >= 801
	, "typeapps" ~: $test41_typeapps @=? $(dsSplice test41_typeapps)
	, "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs)
	, "ubx_sums" ~: $test43_ubx_sums @=? $(dsSplice test43_ubx_sums)
	#endif
	, "let_pragma" ~: $test44_let_pragma @=? $(dsSplice test44_let_pragma)
	-- , "empty_rec" ~: $test45_empty_record_con @=? $(dsSplice test45_empty_record_con)
	-- This one can't be tested by this means, because it contains an "undefined"
	#if __GLASGOW_HASKELL__ >= 803
	, "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label)
	#endif
	, "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match)
	#if __GLASGOW_HASKELL__ >= 805
	, "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints)
	#endif
	#if __GLASGOW_HASKELL__ >= 807
	, "implicit_params" ~: $test49_implicit_params @=? $(dsSplice test49_implicit_params)
	, "vka" ~: $test50_vka @=? $(dsSplice test50_vka)
	#endif
	#if __GLASGOW_HASKELL__ >= 809
	, "tuple_sections" ~: $test51_tuple_sections @=? $(dsSplice test51_tuple_sections)
	#endif
	#if __GLASGOW_HASKELL__ >= 900
	, "qual_do" ~: $test52_qual_do @=? $(dsSplice test52_qual_do)
	#endif
	#if __GLASGOW_HASKELL__ >= 901
	, "vta_in_con_pats" ~: $test53_vta_in_con_pats @=? $(dsSplice test53_vta_in_con_pats)
	#endif
	#if __GLASGOW_HASKELL__ >= 902
	, "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot)
	#endif
	#if __GLASGOW_HASKELL__ >= 903
	, "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma)
	, "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases)
	#endif
	]

Where each test_* function is located here:

th-desugar/Test/Splices.hs

Lines 136 to 352 in 92c07bd

	test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |]
	test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]
	test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |]
	test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |]
	test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |]
	test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |]
	test7_let = [| let { x :: Double; x = 5; f :: Double -> Double; f x = x + 1 } in f (x * 2) + x |]
	test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |]
	test9_do = [| show $ do { foo <- Just "foo"
	; let fool = foo ++ "l"
	; L.elemIndex 'o' fool
	; x <- L.elemIndex 'l' fool
	; return (x + 10) } |]
	test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |]
	test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |]
	test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |]
	test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |]
	data Record = MkRecord1 { field1 :: Bool, field2 :: Int }
	| MkRecord2 { field2 :: Int, field3 :: Char }
	test14_record = [| let r1 = [MkRecord1 { field2 = 5, field1 = False }, MkRecord2 { field2 = 6, field3 = 'q' }]
	r2 = map (\r -> r { field2 = 18 }) r1
	r3 = (head r2) { field1 = True } in
	map (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool
	MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (r3 : r2) |]
	test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |]
	test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |]
	data InfixType = Int :+: Bool
	deriving (Show, Eq)
	test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]
	test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |]
	test19_bangp = [| map (\ !() -> 5) [()] |]
	test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |]
	test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |]
	test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |]
	#if __GLASGOW_HASKELL__ >= 801
	test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]
	#endif
	test24_fun = [| let f (Just x) = x
	f Nothing = Nothing in
	f (Just (Just 10)) |]
	test25_fun2 = [| let f (Just x)
	| x > 0 = x
	| x < 0 = x + 10
	f Nothing = 0
	f _ = 18 in
	map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |]
	test26_forall = [| let f :: Num a => a -> a
	f x = x + 10 in
	(f 5, f 3.0) |]
	test27_kisig = [| let f :: Proxy (a :: Bool) -> ()
	f _ = () in
	(f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |]
	test28_tupt = [| let f :: (a,b) -> a
	f (a,_) = a in
	map f [(1,'a'),(2,'b')] |]
	test29_listt = [| let f :: [[a]] -> a
	f = head . head in
	map f [ [[1]], [[2]] ] |]
	test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> ()
	f _ _ = () in
	f Proxy Proxy |]
	test31_constraint = [| let f :: Proxy (c :: Kind.Type -> Constraint) -> ()
	f _ = () in
	[f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |]
	test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> ()
	f _ _ = () in
	f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |]
	test33_tvbs = [| let f :: forall a (b :: Kind.Type -> Kind.Type). Monad b => a -> b a
	f = return in
	[f 1, f 2] :: [Maybe Int] |]
	test34_let_as = [| let a@(x, y) = (5, 6) in
	show x ++ show y ++ show a |]
	type Pair a = (a, a)
	test35_expand = [| let f :: Pair a -> a
	f = fst in
	f |]
	type Constant a b = b
	test36_expand = [| let f :: Constant Int (,) Bool Char -> Char
	f = snd in
	f |]
	test40_wildcards = [| let f :: (Show a, _) => a -> a -> _
	f x y = if x == y then show x else "bad" in
	f True False :: String |]
	#if __GLASGOW_HASKELL__ >= 801
	test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool
	f g = g (undefined @_ @a) in
	f (const True) |]
	test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String
	f (_ :: b) (x :: String) = show (read x :: b)
	in f True "True" |]
	test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool
	f (# b | #) = not b
	f (# | c #) = c == "c" in
	f (# | "a" #) |]
	#endif
	test44_let_pragma = [| let x :: Int
	x = 1
	{-# INLINE x #-}
	in x |]
	test45_empty_record_con = [| let j :: Maybe Int
	j = Just{}
	in case j of
	Nothing -> j
	Just{} -> j |]
	#if __GLASGOW_HASKELL__ >= 803
	data Label (l :: Symbol) = Get
	class Has a l b | a l -> b where
	from :: a -> Label l -> b
	data Point = Point Int Int deriving Show
	instance Has Point "x" Int where from (Point x _) _ = x
	instance Has Point "y" Int where from (Point _ y) _ = y
	instance Has a l b => IsLabel l (a -> b) where
	fromLabel x = from x (Get :: Label l)
	test46_overloaded_label = [| let p = Point 3 4 in
	#x p - #y p |]
	#endif
	test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |]
	#if __GLASGOW_HASKELL__ >= 805
	test48_quantified_constraints =
	[| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool
	f = (==)
	in f (Proxy @Int) (Proxy @Int) |]
	#endif
	#if __GLASGOW_HASKELL__ >= 807
	test49_implicit_params = [| let f :: (?x :: Int, ?y :: Int) => (Int, Int)
	f =
	let ?x = ?y
	?y = ?x
	in (?x, ?y)
	in (let ?x = 42
	?y = 27
	in f) |]
	test50_vka = [| let hrefl :: (:~~:) @Bool @Bool 'True 'True
	hrefl = HRefl
	in hrefl |]
	#endif
	#if __GLASGOW_HASKELL__ >= 809
	test51_tuple_sections =
	[| let f1 :: String -> Char -> (String, Int, Char)
	f1 = (,5,)
	f2 :: String -> Char -> (# String, Int, Char #)
	f2 = (#,5,#)
	in case (#,#) (f1 "a" 'a') (f2 "b" 'b') of
	(#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |]
	#endif
	#if __GLASGOW_HASKELL__ >= 900
	test52_qual_do =
	[| P.do x <- [1, 2]
	y@1 <- [x]
	[1, 2]
	P.return y |]
	#endif
	#if __GLASGOW_HASKELL__ >= 901
	test53_vta_in_con_pats =
	[| let f :: Maybe Int -> Int
	f (Just @Int x) = x
	f (Nothing @Int) = 42
	in f (Just @Int 27) |]
	#endif
	#if __GLASGOW_HASKELL__ >= 902
	data ORD1 = MkORD1 { unORD1 :: Int }
	data ORD2 = MkORD2 { unORD2 :: ORD1 }
	test54_overloaded_record_dot =
	[| let ord1 :: ORD1
	ord1 = MkORD1 1
	ord2 :: ORD2
	ord2 = MkORD2 ord1
	in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |]
	#endif
	#if __GLASGOW_HASKELL__ >= 903
	test55_opaque_pragma =
	[| let f :: String -> String
	f x = x
	{-# OPAQUE f #-}
	in f "Hello, World!" |]
	test56_lambda_cases =
	[| (\cases (Just x) (Just y) -> x ++ y
	_ _ -> "") (Just "Hello") (Just "World") |]
	#endif

The problem with this approach is that it tests things by splicing in expressions. However, it's not entirely straightforward to define an expression containing a pattern synonym definition. You can't do something like let { pattern P = (id -> ()) } in f P = 42, as pattern synonyms must be defined at the top level.

One way we could accomplish this would be to define the pattern synonym definitions elsewhere, and then define expressions in terms of those pattern synonyms. We would need two copies of each pattern synonym: one using the original pattern synonym syntax, and another using the desugared syntax. We could define them in separate modules (similar to how we have both Test/Decs.hs and Test/DsDecs.hs) and import them qualified to avoid name clashes.

Testing alpha-equivalence would be another way to accomplish this, but nothing in th-desugar quite implements that. The closest that we have is the eqTH function, which checks that two things are Equal to each other after removing the numeric suffixes from each type variable.

[RyanGlScott]

How is this going, @expipiplus1? Do you need help with anything?

[expipiplus1]

Other life things have gotten in the way a bit! I would like to finalize this, but it's not at the top of my plate at the moment, sorry.

I think there's also a bug, along the lines of: (foo -> Left x) being transformed to (\a -> case foo a of Left x -> x) (something like that, where fallible matches on the rhs of a view pattern were transformed into infallible (runtime pattern match error) case analysis in the lhs. So very annoyingly we need to add a catch all case to these and handle everything in Maybe resultTuple (or some unboxed variant to avoid any allocation).

[RyanGlScott]

Thanks for the update! (I was worried that this was in a finished state and only being delayed due to figuring out how to add tests, in which case I could pick it up from there.)