symantic-grammar/Language/Symantic/Grammar/Fixity.hs

   1 module Language.Symantic.Grammar.Fixity where
   2
   3 import Data.Bool as 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(..))
  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_prece :: Precedence }
  22  |   Postfix { unifix_prece :: Precedence }
  23  deriving (Eq, Show)
  24
  25 -- ** Type 'Infix'
  26 data Infix
  27  =   Infix
  28  {   infix_assoc :: Maybe Associativity
  29  ,   infix_prece :: Precedence
  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 parenthesis.
  54 needsParenInfix :: (Infix, Side) -> Infix -> Bool
  55 needsParenInfix (po, lr) op =
  56         infix_prece op < infix_prece po
  57         || infix_prece op == infix_prece po
  58         && Bool.not associate
  59         where
  60         associate =
  61                 case (lr, infix_assoc po) of
  62                  (_, Just AssocB{})   -> True
  63                  (SideL, Just AssocL) -> True
  64                  (SideR, Just AssocR) -> True
  65                  _ -> False
  66
  67 -- | If 'needsParenInfix' is 'True',
  68 -- enclose the given 'IsString' by parenthesis,
  69 -- otherwise returns the same 'IsString'.
  70 parenInfix
  71  :: (Semigroup s, IsString s)
  72  => (Infix, Side) -> Infix -> s -> s
  73 parenInfix po op s =
  74         if needsParenInfix po op
  75         then fromString "(" <> s <> fromString ")"
  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)