src/Symantic/Semantics/Viewer/Fixity.hs

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