Symantic/CLI/Fixity.hs

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