Hdoc/RNC/Fixity.hs

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