1{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE NoStarIsType #-}
3
4module TH_unresolvedInfix_Lib where
5
6import Language.Haskell.TH
7import Language.Haskell.TH.Lib
8import Language.Haskell.TH.Quote
9
10infixl 6 :+
11infixl 7 :*
12
13data Tree = N
14  | Tree :+ Tree
15  | Tree :* Tree
16
17-- custom instance, including redundant parentheses
18instance Show Tree where
19  show N = "N"
20  show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")"
21  show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")"
22
23-- VarE versions
24infixl 6 +:
25infixl 7 *:
26(+:) = (:+)
27(*:) = (:*)
28
29n = conE (mkName "N")
30plus = conE (mkName ":+")
31times = conE (mkName ":*")
32
33a +? b = uInfixE a plus b
34a *? b = uInfixE a times b
35a +! b = infixApp a plus b
36a *! b = infixApp a times b
37
38plus2 = varE (mkName "+:")
39times2 = varE (mkName "*:")
40plus3 = conE ('(:+))
41
42
43--------------------------------------------------------------------------------
44--                                  Patterns                                  --
45--------------------------------------------------------------------------------
46-- The only way to test pattern splices is using QuasiQuotation
47mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined
48p = conP (mkName "N") []
49plus' = mkName ":+"
50times' = mkName ":*"
51
52a ^+? b = uInfixP a plus' b
53a ^*? b = uInfixP a times' b
54a ^+! b = infixP a plus' b
55a ^*! b = infixP a times' b
56
57-------------- Completely-unresolved patterns
58p1 = mkQQ ( p ^+? (p ^*? p) )
59p2 = mkQQ ( (p ^+? p) ^*? p )
60p3 = mkQQ ( p ^+? (p ^+? p) )
61p4 = mkQQ ( (p ^+? p) ^+? p )
62-------------- Completely-resolved patterns
63p5 = mkQQ ( p ^+! (p ^*! p) )
64p6 = mkQQ ( (p ^+! p) ^*! p )
65p7 = mkQQ ( p ^+! (p ^+! p) )
66p8 = mkQQ ( (p ^+! p) ^+! p )
67-------------- Mixed resolved/unresolved
68p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) )
69p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) )
70p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) )
71p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) )
72-------------- Parens
73p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p )
74p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )
75p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )
76
77--------------------------------------------------------------------------------
78--                                  Types                                     --
79--------------------------------------------------------------------------------
80
81infixl 6 +
82infixl 7 *
83data (+) a b = Plus a b
84data (*) a b = Times a b
85
86int = conT (mkName "Int")
87tyPlus = mkName "+"
88tyTimes = mkName "*"
89
90a $+? b = uInfixT a tyPlus b
91a $*? b = uInfixT a tyTimes b
92a $+! b = infixT a tyPlus b
93a $*! b = infixT a tyTimes b
94
95