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