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   = ("(",")")