module Language.Symantic.Grammar.Fixity where

import Data.Bool as 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(..))
import Text.Show (Show)

-- * 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

-- | If 'needsParenInfix' is 'True',
-- enclose the given 'IsString' by parenthesis,
-- otherwise returns the same 'IsString'.
parenInfix
 :: (Semigroup s, IsString s)
 => (Infix, Side) -> Infix -> s -> s
parenInfix po op s =
        if needsParenInfix po op
        then fromString "(" <> s <> fromString ")"
        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_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)