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 (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
  = -- | 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 (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
  = -- | Left
    SideL
  | -- | Right
    SideR
  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
")")