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