Fixity.hs

module Symantic.CLI.Fixity where

import Data.Bool
import Data.Eq (Eq(..))
import Data.Function ((.))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Text.Show (Show(..))
import qualified Data.Bool as Bool

-- * Type 'Fixity'
data Fixity
 =   Fixity1 Unifix
 |   Fixity2 Infix
 deriving (Eq, Show)

-- ** Type 'Unifix'
data Unifix
 =   Prefix  { unifix_prece :: Precedence }
 |   Postfix { unifix_prece :: Precedence }
 deriving (Eq, Show)

-- ** Type 'Infix'
data Infix
 =   Infix
 {   infix_assoc :: Maybe Associativity
 ,   infix_prece :: Precedence
 } deriving (Eq, Show)

infixL :: Precedence -> Infix
infixL = Infix (Just AssocL)

infixR :: Precedence -> Infix
infixR = Infix (Just AssocR)

infixB :: Side -> Precedence -> Infix
infixB = Infix . Just . AssocB

infixN :: Precedence -> Infix
infixN = Infix Nothing

infixN0 :: Infix
infixN0 = infixN 0

infixN5 :: Infix
infixN5 = infixN 5

-- | Given 'Precedence' and 'Associativity' of its parent operator,
-- and the operand 'Side' it is in,
-- return whether an 'Infix' operator
-- needs to be enclosed by parenthesis.
needsParenInfix :: (Infix, Side) -> Infix -> Bool
needsParenInfix (po, lr) op =
	infix_prece op < infix_prece po
	|| infix_prece op == infix_prece po
	&& Bool.not associate
	where
	associate =
		case (lr, infix_assoc po) of
		 (_, Just AssocB{})   -> True
		 (SideL, Just AssocL) -> True
		 (SideR, Just AssocR) -> True
		 _ -> False

-- * Type 'Precedence'
type Precedence = Int

-- ** Class 'PrecedenceOf'
class PrecedenceOf a where
	precedence :: a -> Precedence
instance PrecedenceOf Fixity where
	precedence (Fixity1 uni) = precedence uni
	precedence (Fixity2 inf) = precedence inf
instance PrecedenceOf Unifix where
	precedence = unifix_prece
instance PrecedenceOf Infix where
	precedence = infix_prece

-- * Type 'Associativity'
data Associativity
 =   AssocL      -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
 |   AssocR      -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
 |   AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.
 deriving (Eq, Show)

-- ** Type 'Side'
data Side
 =   SideL -- ^ Left
 |   SideR -- ^ Right
 deriving (Eq, Show)