module Symantic.Utils.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 Data.Semigroup import Data.String (String, IsString(..)) import Text.Show (Show(..)) -- * Type 'Fixity' data Fixity = Fixity1 Unifix | Fixity2 Infix deriving (Eq, Show) -- ** Type 'Unifix' data Unifix = Prefix { unifix_precedence :: Precedence } | Postfix { unifix_precedence :: Precedence } deriving (Eq, Show) -- ** Type 'Infix' data Infix = Infix { infix_associativity :: Maybe Associativity , infix_precedence :: 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 a 'Pair'. isPairNeeded :: (Infix, Side) -> Infix -> Bool isPairNeeded (po, lr) op = infix_precedence op < infix_precedence po || infix_precedence op == infix_precedence po && not associate where associate = case (lr, infix_associativity po) of (_, Just AssocB{}) -> True (SideL, Just AssocL) -> True (SideR, Just AssocR) -> True _ -> False -- | If 'isPairNeeded' is 'True', -- enclose the given 'IsString' by given 'Pair', -- otherwise returns the same 'IsString'. pairIfNeeded :: Semigroup s => IsString s => Pair -> (Infix, Side) -> Infix -> s -> s pairIfNeeded (o,c) po op s = if isPairNeeded po op then fromString o <> s <> fromString c else s -- * 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_precedence instance PrecedenceOf Infix where precedence = infix_precedence -- * 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) -- ** Type 'Pair' type Pair = (String, String) pairAngle :: Pair pairBrace :: Pair pairBracket :: Pair pairParen :: Pair pairAngle = ("<",">") pairBrace = ("{","}") pairBracket = ("[","]") pairParen = ("(",")")