Fixity.hs

module Symantic.Semantics.Viewer.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 (IsString (..), String)
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
  = -- | Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
    AssocL
  | -- | Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
    AssocR
  | -- | Associate to both sides, but to 'Side' when reading.
    AssocB Side
  deriving (Eq, Show)

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

-- ** Type 'Pair'
type Pair = (String, String)
pairAngle :: Pair
pairBrace :: Pair
pairBracket :: Pair
pairParen :: Pair
pairAngle = ("<", ">")
pairBrace = ("{", "}")
pairBracket = ("[", "]")
pairParen = ("(", ")")