src/Symantic/Semantics/Viewer/Fixity.hs

   1 module Symantic.Semantics.Viewer.Fixity where
   2
   3 import Data.Bool
   4 import Data.Eq (Eq (..))
   5 import Data.Function ((.))
   6 import Data.Int (Int)
   7 import Data.Maybe (Maybe (..))
   8 import Data.Ord (Ord (..))
   9 import Data.Semigroup
  10 import Data.String (IsString (..), String)
  11 import Text.Show (Show (..))
  12
  13 -- * Type 'Fixity'
  14 data Fixity
  15   = Fixity1 Unifix
  16   | Fixity2 Infix
  17   deriving (Eq, Show)
  18
  19 -- ** Type 'Unifix'
  20 data Unifix
  21   = Prefix {unifix_precedence :: Precedence}
  22   | Postfix {unifix_precedence :: Precedence}
  23   deriving (Eq, Show)
  24
  25 -- ** Type 'Infix'
  26 data Infix = Infix
  27   { infix_associativity :: Maybe Associativity
  28   , infix_precedence :: Precedence
  29   }
  30   deriving (Eq, Show)
  31
  32 infixL :: Precedence -> Infix
  33 infixL = Infix (Just AssocL)
  34
  35 infixR :: Precedence -> Infix
  36 infixR = Infix (Just AssocR)
  37
  38 infixB :: Side -> Precedence -> Infix
  39 infixB = Infix . Just . AssocB
  40
  41 infixN :: Precedence -> Infix
  42 infixN = Infix Nothing
  43
  44 infixN0 :: Infix
  45 infixN0 = infixN 0
  46
  47 infixN5 :: Infix
  48 infixN5 = infixN 5
  49
  50 -- | Given 'Precedence' and 'Associativity' of its parent operator,
  51 -- and the operand 'Side' it is in,
  52 -- return whether an 'Infix' operator
  53 -- needs to be enclosed by a 'Pair'.
  54 isPairNeeded :: (Infix, Side) -> Infix -> Bool
  55 isPairNeeded (po, lr) op =
  56   infix_precedence op < infix_precedence po
  57     || infix_precedence op == infix_precedence po
  58     && not associate
  59   where
  60     associate =
  61       case (lr, infix_associativity po) of
  62         (_, Just AssocB{}) -> True
  63         (SideL, Just AssocL) -> True
  64         (SideR, Just AssocR) -> True
  65         _ -> False
  66
  67 -- | If 'isPairNeeded' is 'True',
  68 -- enclose the given 'IsString' by given 'Pair',
  69 -- otherwise returns the same 'IsString'.
  70 pairIfNeeded ::
  71   Semigroup s =>
  72   IsString s =>
  73   Pair ->
  74   (Infix, Side) ->
  75   Infix ->
  76   s ->
  77   s
  78 pairIfNeeded (o, c) po op s =
  79   if isPairNeeded po op
  80     then fromString o <> s <> fromString c
  81     else s
  82
  83 -- * Type 'Precedence'
  84 type Precedence = Int
  85
  86 -- ** Class 'PrecedenceOf'
  87 class PrecedenceOf a where
  88   precedence :: a -> Precedence
  89 instance PrecedenceOf Fixity where
  90   precedence (Fixity1 uni) = precedence uni
  91   precedence (Fixity2 inf) = precedence inf
  92 instance PrecedenceOf Unifix where
  93   precedence = unifix_precedence
  94 instance PrecedenceOf Infix where
  95   precedence = infix_precedence
  96
  97 -- * Type 'Associativity'
  98 data Associativity
  99   = -- | Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
 100     AssocL
 101   | -- | Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
 102     AssocR
 103   | -- | Associate to both sides, but to 'Side' when reading.
 104     AssocB Side
 105   deriving (Eq, Show)
 106
 107 -- ** Type 'Side'
 108 data Side
 109   = -- | Left
 110     SideL
 111   | -- | Right
 112     SideR
 113   deriving (Eq, Show)
 114
 115 -- ** Type 'Pair'
 116 type Pair = (String, String)
 117 pairAngle :: Pair
 118 pairBrace :: Pair
 119 pairBracket :: Pair
 120 pairParen :: Pair
 121 pairAngle = ("<", ">")
 122 pairBrace = ("{", "}")
 123 pairBracket = ("[", "]")
 124 pairParen = ("(", ")")