Add missing file

diff --git a/src/Symantic/Parser/Grammar/Fixity.hs b/src/Symantic/Parser/Grammar/Fixity.hs
new file mode 100644 (file)
index 0000000..70f1dbb
--- /dev/null
+++ b/src/Symantic/Parser/Grammar/Fixity.hs
@@ -0,0 +1,115 @@
+module Symantic.Parser.Grammar.Fixity where
+
+import Data.Bool
+import Data.Eq (Eq(..))
+import Data.Function ((.))
+import Data.Int (Int)
+import Data.Maybe (Maybe(..))
+import Data.Ord (Ord(..))
+import Data.Semigroup
+import Data.String (String, IsString(..))
+import Text.Show (Show(..))
+
+-- * Type 'Fixity'
+data Fixity
+ =   Fixity1 Unifix
+ |   Fixity2 Infix
+ deriving (Eq, Show)
+
+-- ** Type 'Unifix'
+data Unifix
+ =   Prefix  { unifix_precedence :: Precedence }
+ |   Postfix { unifix_precedence :: Precedence }
+ deriving (Eq, Show)
+
+-- ** Type 'Infix'
+data Infix
+ =   Infix
+ {   infix_associativity :: Maybe Associativity
+ ,   infix_precedence    :: Precedence
+ } deriving (Eq, Show)
+
+infixL :: Precedence -> Infix
+infixL = Infix (Just AssocL)
+
+infixR :: Precedence -> Infix
+infixR = Infix (Just AssocR)
+
+infixB :: Side -> Precedence -> Infix
+infixB = Infix . Just . AssocB
+
+infixN :: Precedence -> Infix
+infixN = Infix Nothing
+
+infixN0 :: Infix
+infixN0 = infixN 0
+
+infixN5 :: Infix
+infixN5 = infixN 5
+
+-- | Given 'Precedence' and 'Associativity' of its parent operator,
+-- and the operand 'Side' it is in,
+-- return whether an 'Infix' operator
+-- needs to be enclosed by a 'Pair'.
+isPairNeeded :: (Infix, Side) -> Infix -> Bool
+isPairNeeded (po, lr) op =
+  infix_precedence op < infix_precedence po
+  || infix_precedence op == infix_precedence po
+  && not associate
+  where
+  associate =
+    case (lr, infix_associativity po) of
+     (_, Just AssocB{})   -> True
+     (SideL, Just AssocL) -> True
+     (SideR, Just AssocR) -> True
+     _ -> False
+
+-- | If 'isPairNeeded' is 'True',
+-- enclose the given 'IsString' by given 'Pair',
+-- otherwise returns the same 'IsString'.
+pairIfNeeded ::
+ Semigroup s => IsString s =>
+ Pair -> (Infix, Side) -> Infix ->
+ s -> s
+pairIfNeeded (o,c) po op s =
+  if isPairNeeded po op
+  then fromString o <> s <> fromString c
+  else s
+
+-- * Type 'Precedence'
+type Precedence = Int
+
+-- ** Class 'PrecedenceOf'
+class PrecedenceOf a where
+  precedence :: a -> Precedence
+instance PrecedenceOf Fixity where
+  precedence (Fixity1 uni) = precedence uni
+  precedence (Fixity2 inf) = precedence inf
+instance PrecedenceOf Unifix where
+  precedence = unifix_precedence
+instance PrecedenceOf Infix where
+  precedence = infix_precedence
+
+-- * Type 'Associativity'
+data Associativity
+ =   AssocL      -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
+ |   AssocR      -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
+ |   AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.
+ deriving (Eq, Show)
+
+-- ** Type 'Side'
+data Side
+ =   SideL -- ^ Left
+ |   SideR -- ^ Right
+ deriving (Eq, Show)
+
+-- ** Type 'Pair'
+type Pair = (String, String)
+pairAngle   :: Pair
+pairBrace   :: Pair
+pairBracket :: Pair
+pairParen   :: Pair
+pairAngle   = ("<",">")
+pairBrace   = ("{","}")
+pairBracket = ("[","]")
+pairParen   = ("(",")")