module Symantic.Parser.Grammar.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 (Fixity -> Fixity -> Bool
(Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool) -> Eq Fixity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fixity -> Fixity -> Bool
$c/= :: Fixity -> Fixity -> Bool
== :: Fixity -> Fixity -> Bool
$c== :: Fixity -> Fixity -> Bool
Eq, Precedence -> Fixity -> ShowS
[Fixity] -> ShowS
Fixity -> String
(Precedence -> Fixity -> ShowS)
-> (Fixity -> String) -> ([Fixity] -> ShowS) -> Show Fixity
forall a.
(Precedence -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fixity] -> ShowS
$cshowList :: [Fixity] -> ShowS
show :: Fixity -> String
$cshow :: Fixity -> String
showsPrec :: Precedence -> Fixity -> ShowS
$cshowsPrec :: Precedence -> Fixity -> ShowS
Show)

-- ** Type 'Unifix'
data Unifix
 =   Prefix  { Unifix -> Precedence
unifix_precedence :: Precedence }
 |   Postfix { unifix_precedence :: Precedence }
 deriving (Unifix -> Unifix -> Bool
(Unifix -> Unifix -> Bool)
-> (Unifix -> Unifix -> Bool) -> Eq Unifix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unifix -> Unifix -> Bool
$c/= :: Unifix -> Unifix -> Bool
== :: Unifix -> Unifix -> Bool
$c== :: Unifix -> Unifix -> Bool
Eq, Precedence -> Unifix -> ShowS
[Unifix] -> ShowS
Unifix -> String
(Precedence -> Unifix -> ShowS)
-> (Unifix -> String) -> ([Unifix] -> ShowS) -> Show Unifix
forall a.
(Precedence -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unifix] -> ShowS
$cshowList :: [Unifix] -> ShowS
show :: Unifix -> String
$cshow :: Unifix -> String
showsPrec :: Precedence -> Unifix -> ShowS
$cshowsPrec :: Precedence -> Unifix -> ShowS
Show)

-- ** Type 'Infix'
data Infix
 =   Infix
 {   Infix -> Maybe Associativity
infix_associativity :: Maybe Associativity
 ,   Infix -> Precedence
infix_precedence    :: Precedence
 } deriving (Infix -> Infix -> Bool
(Infix -> Infix -> Bool) -> (Infix -> Infix -> Bool) -> Eq Infix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Infix -> Infix -> Bool
$c/= :: Infix -> Infix -> Bool
== :: Infix -> Infix -> Bool
$c== :: Infix -> Infix -> Bool
Eq, Precedence -> Infix -> ShowS
[Infix] -> ShowS
Infix -> String
(Precedence -> Infix -> ShowS)
-> (Infix -> String) -> ([Infix] -> ShowS) -> Show Infix
forall a.
(Precedence -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Infix] -> ShowS
$cshowList :: [Infix] -> ShowS
show :: Infix -> String
$cshow :: Infix -> String
showsPrec :: Precedence -> Infix -> ShowS
$cshowsPrec :: Precedence -> Infix -> ShowS
Show)

infixL :: Precedence -> Infix
infixL :: Precedence -> Infix
infixL = Maybe Associativity -> Precedence -> Infix
Infix (Associativity -> Maybe Associativity
forall a. a -> Maybe a
Just Associativity
AssocL)

infixR :: Precedence -> Infix
infixR :: Precedence -> Infix
infixR = Maybe Associativity -> Precedence -> Infix
Infix (Associativity -> Maybe Associativity
forall a. a -> Maybe a
Just Associativity
AssocR)

infixB :: Side -> Precedence -> Infix
infixB :: Side -> Precedence -> Infix
infixB = Maybe Associativity -> Precedence -> Infix
Infix (Maybe Associativity -> Precedence -> Infix)
-> (Side -> Maybe Associativity) -> Side -> Precedence -> Infix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Associativity -> Maybe Associativity
forall a. a -> Maybe a
Just (Associativity -> Maybe Associativity)
-> (Side -> Associativity) -> Side -> Maybe Associativity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Side -> Associativity
AssocB

infixN :: Precedence -> Infix
infixN :: Precedence -> Infix
infixN = Maybe Associativity -> Precedence -> Infix
Infix Maybe Associativity
forall a. Maybe a
Nothing

infixN0 :: Infix
infixN0 :: Infix
infixN0 = Precedence -> Infix
infixN Precedence
0

infixN5 :: Infix
infixN5 :: Infix
infixN5 = Precedence -> Infix
infixN Precedence
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 :: (Infix, Side) -> Infix -> Bool
isPairNeeded (Infix
po, Side
lr) Infix
op =
  Infix -> Precedence
infix_precedence Infix
op Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Infix -> Precedence
infix_precedence Infix
po
  Bool -> Bool -> Bool
|| Infix -> Precedence
infix_precedence Infix
op Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Infix -> Precedence
infix_precedence Infix
po
  Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
associate
  where
  associate :: Bool
associate =
    case (Side
lr, Infix -> Maybe Associativity
infix_associativity Infix
po) of
     (Side
_, Just AssocB{})   -> Bool
True
     (Side
SideL, Just Associativity
AssocL) -> Bool
True
     (Side
SideR, Just Associativity
AssocR) -> Bool
True
     (Side, Maybe Associativity)
_ -> Bool
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 :: forall s.
(Semigroup s, IsString s) =>
Pair -> (Infix, Side) -> Infix -> s -> s
pairIfNeeded (String
o,String
c) (Infix, Side)
po Infix
op s
s =
  if (Infix, Side) -> Infix -> Bool
isPairNeeded (Infix, Side)
po Infix
op
  then String -> s
forall a. IsString a => String -> a
fromString String
o s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
s s -> s -> s
forall a. Semigroup a => a -> a -> a
<> String -> s
forall a. IsString a => String -> a
fromString String
c
  else s
s

-- * Type 'Precedence'
type Precedence = Int

-- ** Class 'PrecedenceOf'
class PrecedenceOf a where
  precedence :: a -> Precedence
instance PrecedenceOf Fixity where
  precedence :: Fixity -> Precedence
precedence (Fixity1 Unifix
uni) = Unifix -> Precedence
forall a. PrecedenceOf a => a -> Precedence
precedence Unifix
uni
  precedence (Fixity2 Infix
inf) = Infix -> Precedence
forall a. PrecedenceOf a => a -> Precedence
precedence Infix
inf
instance PrecedenceOf Unifix where
  precedence :: Unifix -> Precedence
precedence = Unifix -> Precedence
unifix_precedence
instance PrecedenceOf Infix where
  precedence :: Infix -> Precedence
precedence = Infix -> 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 (Associativity -> Associativity -> Bool
(Associativity -> Associativity -> Bool)
-> (Associativity -> Associativity -> Bool) -> Eq Associativity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Associativity -> Associativity -> Bool
$c/= :: Associativity -> Associativity -> Bool
== :: Associativity -> Associativity -> Bool
$c== :: Associativity -> Associativity -> Bool
Eq, Precedence -> Associativity -> ShowS
[Associativity] -> ShowS
Associativity -> String
(Precedence -> Associativity -> ShowS)
-> (Associativity -> String)
-> ([Associativity] -> ShowS)
-> Show Associativity
forall a.
(Precedence -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Associativity] -> ShowS
$cshowList :: [Associativity] -> ShowS
show :: Associativity -> String
$cshow :: Associativity -> String
showsPrec :: Precedence -> Associativity -> ShowS
$cshowsPrec :: Precedence -> Associativity -> ShowS
Show)

-- ** Type 'Side'
data Side
 =   SideL -- ^ Left
 |   SideR -- ^ Right
 deriving (Side -> Side -> Bool
(Side -> Side -> Bool) -> (Side -> Side -> Bool) -> Eq Side
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Side -> Side -> Bool
$c/= :: Side -> Side -> Bool
== :: Side -> Side -> Bool
$c== :: Side -> Side -> Bool
Eq, Precedence -> Side -> ShowS
[Side] -> ShowS
Side -> String
(Precedence -> Side -> ShowS)
-> (Side -> String) -> ([Side] -> ShowS) -> Show Side
forall a.
(Precedence -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Side] -> ShowS
$cshowList :: [Side] -> ShowS
show :: Side -> String
$cshow :: Side -> String
showsPrec :: Precedence -> Side -> ShowS
$cshowsPrec :: Precedence -> Side -> ShowS
Show)

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