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