]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Semantics/Viewer/Fixity.hs
doc: update `ChangeLog.md`
[haskell/symantic-base.git] / src / Symantic / Semantics / Viewer / Fixity.hs
1 module Symantic.Semantics.Viewer.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 (IsString (..), String)
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 = Infix
27 { infix_associativity :: Maybe Associativity
28 , infix_precedence :: Precedence
29 }
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 =>
72 IsString s =>
73 Pair ->
74 (Infix, Side) ->
75 Infix ->
76 s ->
77 s
78 pairIfNeeded (o, c) po op s =
79 if isPairNeeded po op
80 then fromString o <> s <> fromString c
81 else s
82
83 -- * Type 'Precedence'
84 type Precedence = Int
85
86 -- ** Class 'PrecedenceOf'
87 class PrecedenceOf a where
88 precedence :: a -> Precedence
89 instance PrecedenceOf Fixity where
90 precedence (Fixity1 uni) = precedence uni
91 precedence (Fixity2 inf) = precedence inf
92 instance PrecedenceOf Unifix where
93 precedence = unifix_precedence
94 instance PrecedenceOf Infix where
95 precedence = infix_precedence
96
97 -- * Type 'Associativity'
98 data Associativity
99 = -- | Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@
100 AssocL
101 | -- | Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
102 AssocR
103 | -- | Associate to both sides, but to 'Side' when reading.
104 AssocB Side
105 deriving (Eq, Show)
106
107 -- ** Type 'Side'
108 data Side
109 = -- | Left
110 SideL
111 | -- | Right
112 SideR
113 deriving (Eq, Show)
114
115 -- ** Type 'Pair'
116 type Pair = (String, String)
117 pairAngle :: Pair
118 pairBrace :: Pair
119 pairBracket :: Pair
120 pairParen :: Pair
121 pairAngle = ("<", ">")
122 pairBrace = ("{", "}")
123 pairBracket = ("[", "]")
124 pairParen = ("(", ")")