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