src/Symantic/Parser/Grammar/Fixity.hs

   1 module Symantic.Parser.Grammar.Fixity where
   2
   3 import Data.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 (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_precedence :: Precedence }
  22  |   Postfix { unifix_precedence :: Precedence }
  23  deriving (Eq, Show)
  24
  25 -- ** Type 'Infix'
  26 data Infix
  27  =   Infix
  28  {   infix_associativity :: Maybe Associativity
  29  ,   infix_precedence    :: 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 a 'Pair'.
  54 isPairNeeded :: (Infix, Side) -> Infix -> Bool
  55 isPairNeeded (po, lr) op =
  56   infix_precedence op < infix_precedence po
  57   || infix_precedence op == infix_precedence po
  58   && not associate
  59   where
  60   associate =
  61     case (lr, infix_associativity po) of
  62      (_, Just AssocB{})   -> True
  63      (SideL, Just AssocL) -> True
  64      (SideR, Just AssocR) -> True
  65      _ -> False
  66
  67 -- | If 'isPairNeeded' is 'True',
  68 -- enclose the given 'IsString' by given 'Pair',
  69 -- otherwise returns the same 'IsString'.
  70 pairIfNeeded ::
  71  Semigroup s => IsString s =>
  72  Pair -> (Infix, Side) -> Infix ->
  73  s -> s
  74 pairIfNeeded (o,c) po op s =
  75   if isPairNeeded po op
  76   then fromString o <> s <> fromString c
  77   else s
  78
  79 -- * Type 'Precedence'
  80 type Precedence = Int
  81
  82 -- ** Class 'PrecedenceOf'
  83 class PrecedenceOf a where
  84   precedence :: a -> Precedence
  85 instance PrecedenceOf Fixity where
  86   precedence (Fixity1 uni) = precedence uni
  87   precedence (Fixity2 inf) = precedence inf
  88 instance PrecedenceOf Unifix where
  89   precedence = unifix_precedence
  90 instance PrecedenceOf Infix where
  91   precedence = infix_precedence
  92
  93 -- * Type 'Associativity'
  94 data Associativity
  95  =   AssocL      -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
  96  |   AssocR      -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
  97  |   AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.
  98  deriving (Eq, Show)
  99
 100 -- ** Type 'Side'
 101 data Side
 102  =   SideL -- ^ Left
 103  |   SideR -- ^ Right
 104  deriving (Eq, Show)
 105
 106 -- ** Type 'Pair'
 107 type Pair = (String, String)
 108 pairAngle   :: Pair
 109 pairBrace   :: Pair
 110 pairBracket :: Pair
 111 pairParen   :: Pair
 112 pairAngle   = ("<",">")
 113 pairBrace   = ("{","}")
 114 pairBracket = ("[","]")
 115 pairParen   = ("(",")")