]> Git — Sourcephile - haskell/symantic-xml.git/blob - Language/Symantic/RNC/Write/Fixity.hs
Upgrade to megaparsec-7
[haskell/symantic-xml.git] / Language / Symantic / RNC / Write / Fixity.hs
1 module Language.Symantic.RNC.Write.Fixity where
2
3 import Data.Bool
4 import Data.Eq (Eq(..))
5 import Data.Function ((.))
6 import Data.Int (Int)
7 import Data.Maybe (Maybe(..))
8 import Data.Ord (Ord(..))
9 import Data.Semigroup
10 import Data.String (String, IsString(..))
11 import Text.Show (Show(..))
12
13 -- * Type 'Fixity'
14 data Fixity
15 = Fixity1 Unifix
16 | Fixity2 Infix
17 deriving (Eq, Show)
18
19 -- ** Type 'Unifix'
20 data Unifix
21 = Prefix { unifix_precedence :: Precedence }
22 | Postfix { unifix_precedence :: Precedence }
23 deriving (Eq, Show)
24
25 -- ** Type 'Infix'
26 data Infix
27 = Infix
28 { infix_associativity :: Maybe Associativity
29 , infix_precedence :: Precedence
30 } deriving (Eq, Show)
31
32 infixL :: Precedence -> Infix
33 infixL = Infix (Just AssocL)
34
35 infixR :: Precedence -> Infix
36 infixR = Infix (Just AssocR)
37
38 infixB :: Side -> Precedence -> Infix
39 infixB = Infix . Just . AssocB
40
41 infixN :: Precedence -> Infix
42 infixN = Infix Nothing
43
44 infixN0 :: Infix
45 infixN0 = infixN 0
46
47 infixN5 :: Infix
48 infixN5 = infixN 5
49
50 -- | Given 'Precedence' and 'Associativity' of its parent operator,
51 -- and the operand 'Side' it is in,
52 -- return whether an 'Infix' operator
53 -- needs to be enclosed by a 'Pair'.
54 isPairNeeded :: (Infix, Side) -> Infix -> Bool
55 isPairNeeded (po, lr) op =
56 infix_precedence op < infix_precedence po
57 || infix_precedence op == infix_precedence po
58 && not associate
59 where
60 associate =
61 case (lr, infix_associativity po) of
62 (_, Just AssocB{}) -> True
63 (SideL, Just AssocL) -> True
64 (SideR, Just AssocR) -> True
65 _ -> False
66
67 -- | If 'isPairNeeded' is 'True',
68 -- enclose the given 'IsString' by given 'Pair',
69 -- otherwise returns the same 'IsString'.
70 pairIfNeeded ::
71 Semigroup s => IsString s =>
72 Pair -> (Infix, Side) -> Infix ->
73 s -> s
74 pairIfNeeded (o,c) po op s =
75 if isPairNeeded po op
76 then fromString o <> s <> fromString c
77 else s
78
79 -- * Type 'Precedence'
80 type Precedence = Int
81
82 -- ** Class 'PrecedenceOf'
83 class PrecedenceOf a where
84 precedence :: a -> Precedence
85 instance PrecedenceOf Fixity where
86 precedence (Fixity1 uni) = precedence uni
87 precedence (Fixity2 inf) = precedence inf
88 instance PrecedenceOf Unifix where
89 precedence = unifix_precedence
90 instance PrecedenceOf Infix where
91 precedence = infix_precedence
92
93 -- * Type 'Associativity'
94 data Associativity
95 = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@
96 | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
97 | AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.
98 deriving (Eq, Show)
99
100 -- ** Type 'Side'
101 data Side
102 = SideL -- ^ Left
103 | SideR -- ^ Right
104 deriving (Eq, Show)
105
106 -- ** Type 'Pair'
107 type Pair = (String, String)
108 pairParen, pairBrace :: Pair
109 pairParen = ("(",")")
110 pairBrace = ("{","}")