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