symantic-grammar/Language/Symantic/Grammar/Operators.hs

   1 -- | Symantics to handle 'Prefix', 'Postfix' or 'Infix' operators,
   2 -- of different 'Precedence's and possibly with left and/or right 'Associativity'.
   3 module Language.Symantic.Grammar.Operators where
   4
   5 import Control.Applicative (Applicative(..))
   6 import Control.Monad (void)
   7 import Data.Foldable
   8
   9 import Language.Symantic.Grammar.Fixity
  10 import Language.Symantic.Grammar.EBNF
  11 import Language.Symantic.Grammar.Terminal
  12 import Language.Symantic.Grammar.Regular
  13 import Language.Symantic.Grammar.ContextFree
  14
  15 -- * Class 'Gram_Op'
  16 -- | Symantics for operators.
  17 class
  18  ( Gram_Char g
  19  , Gram_String g
  20  , Gram_Rule g
  21  , Gram_Alt g
  22  , Gram_Try g
  23  , Gram_App g
  24  , Gram_AltApp g
  25  , Gram_CF g
  26  ) => Gram_Op g where
  27         operators
  28          :: CF g a -- ^ expression
  29          -> CF g (Unifix, a -> a) -- ^ prefix operator
  30          -> CF g (Infix , a -> a -> a) -- ^ infix operator
  31          -> CF g (Unifix, a -> a) -- ^ postfix operator
  32          -> CF g (Either Error_Fixity a)
  33         operators g prefixG infixG postfixG =
  34                 (evalOpTree <$>) <$> go g prefixG infixG postfixG
  35                 where
  36                 go
  37                  :: CF g a
  38                  -> CF g (Unifix, a -> a)
  39                  -> CF g (Infix , a -> a -> a)
  40                  -> CF g (Unifix, a -> a)
  41                  -> CF g (Either Error_Fixity (OpTree a))
  42                 go = rule4 "operators" $ \aG preG inG postG ->
  43                         (\pres a posts ->
  44                                 let nod_a =
  45                                         foldr insertUnifix
  46                                          (foldl' (flip insertUnifix) (OpTree0 a) posts)
  47                                          pres
  48                                 in \case
  49                                  Just (in_, b) -> insertInfix nod_a in_ b
  50                                  Nothing -> Right nod_a)
  51                          <$> many (try preG)
  52                          <*> aG
  53                          <*> many (try postG)
  54                          <*> option Nothing (curry Just <$> try inG <*> go aG preG inG postG)
  55         infixrG :: CF g a -> CF g (a -> a -> a) -> CF g a
  56         infixrG = rule2 "infixr" $ \g opG ->
  57                 (\a -> \case
  58                  Just (op, b) -> a `op` b
  59                  Nothing -> a)
  60                  <$> g
  61                  <*> option Nothing (try $ curry Just <$> opG <*> infixrG g opG)
  62         infixlG :: CF g a -> CF g (a -> a -> a) -> CF g a
  63         infixlG = rule2 "infixl" $ \g opG ->
  64                 -- NOTE: infixl uses the same grammar than infixr,
  65                 -- but build the parsed value by applying
  66                 -- the operator in the opposite way.
  67                 ($ id) <$> go g opG
  68                 where
  69                 go :: CF g a -> CF g (a -> a -> a) -> CF g ((a -> a) -> a)
  70                 go g opG =
  71                         (\a -> \case
  72                          Just (op, kb) -> \k -> kb (k a `op`)
  73                          Nothing -> ($ a))
  74                          <$> g
  75                          <*> option Nothing (try $ curry Just <$> opG <*> go g opG)
  76 deriving instance Gram_Op g => Gram_Op (CF g)
  77 instance Gram_Op RuleEBNF
  78 instance Gram_Op EBNF
  79
  80 -- ** Type 'Error_Fixity'
  81 data Error_Fixity
  82  =   Error_Fixity_Infix_not_combinable Infix Infix
  83  {-
  84      Error_Fixity_NeedPostfixOrInfix
  85      Error_Fixity_NeedPrefix
  86      Error_Fixity_NeedPostfix
  87      Error_Fixity_NeedInfix
  88  -}
  89  deriving (Eq, Show)
  90
  91 -- ** Type 'OpTree'
  92 -- | Tree of operators.
  93 --
  94 -- Useful to recombine operators according to their 'Precedence'.
  95 data OpTree a
  96  =   OpTree0 a
  97  |   OpTree1 Unifix (a -> a)      (OpTree a)
  98  |   OpTree2 Infix  (a -> a -> a) (OpTree a) (OpTree a)
  99 instance Show a => Show (OpTree a) where
 100         showsPrec n (OpTree0 a) =
 101                 showParen (n > 10) $ showString "OpTree0 "
 102                  . showsPrec 11 a
 103         showsPrec n (OpTree1 f _ a) =
 104                 showParen (n > 10) $ showString "OpTree1 "
 105                  . showsPrec 11 f
 106                  . showChar ' ' . showsPrec 11 a
 107         showsPrec n (OpTree2 f _ a b) =
 108                 showParen (n > 10) $ showString "OpTree2 "
 109                  . showsPrec 11 f
 110                  . showChar ' ' . showsPrec 11 a
 111                  . showChar ' ' . showsPrec 11 b
 112
 113 -- | Insert an 'Unifix' operator into an 'OpTree'.
 114 insertUnifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
 115 insertUnifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
 116         case nod_b of
 117          OpTree0{} -> OpTree1 uni_a op_a nod_b
 118          OpTree1 Prefix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
 119          OpTree1 uni_b@(Postfix prece_b) op_b nod ->
 120                 case prece_b `compare` prece_a of
 121                  GT -> OpTree1 uni_a op_a nod_b
 122                  EQ -> OpTree1 uni_a op_a nod_b
 123                  LT -> OpTree1 uni_b op_b $ insertUnifix a nod
 124          OpTree2 inf_b op_b l r ->
 125                 case infix_prece inf_b `compare` prece_a of
 126                  GT -> OpTree1 uni_a op_a nod_b
 127                  EQ -> OpTree1 uni_a op_a nod_b
 128                  LT -> OpTree2 inf_b op_b (insertUnifix a l) r
 129 insertUnifix a@(uni_a@(Postfix prece_a), op_a) nod_b =
 130         case nod_b of
 131          OpTree0{} -> OpTree1 uni_a op_a nod_b
 132          OpTree1 uni_b@(Prefix prece_b) op_b nod ->
 133                 case prece_b `compare` prece_a of
 134                  GT -> OpTree1 uni_a op_a nod_b
 135                  EQ -> OpTree1 uni_a op_a nod_b
 136                  LT -> OpTree1 uni_b op_b $ insertUnifix a nod
 137          OpTree1 Postfix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
 138          OpTree2 inf_b op_b l r ->
 139                 case infix_prece inf_b `compare` prece_a of
 140                  GT -> OpTree1 uni_a op_a nod_b
 141                  EQ -> OpTree1 uni_a op_a nod_b
 142                  LT -> OpTree2 inf_b op_b l (insertUnifix a r)
 143
 144 -- | Insert an 'Infix' operator into an 'OpTree'.
 145 insertInfix
 146  :: OpTree a
 147  -> (Infix, a -> a -> a)
 148  -> Either Error_Fixity (OpTree a)
 149  -> Either Error_Fixity (OpTree a)
 150 insertInfix nod_a in_@(inf_a, op_a) e_nod_b = do
 151         nod_b <- e_nod_b
 152         case nod_b of
 153          OpTree0{} -> Right $ OpTree2 inf_a op_a nod_a nod_b
 154          OpTree1 uni_b op_b nod ->
 155                 case unifix_prece uni_b `compare` infix_prece inf_a of
 156                  EQ -> Right $ OpTree2 inf_a op_a nod_a nod_b
 157                  GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
 158                  LT -> do
 159                         n <- insertInfix nod_a in_ (Right nod)
 160                         Right $ OpTree1 uni_b op_b n
 161          OpTree2 inf_b op_b l r ->
 162                 case infix_prece inf_b `compare` infix_prece inf_a of
 163                  GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
 164                  LT -> do
 165                         n <- insertInfix nod_a in_ (Right l)
 166                         Right $ OpTree2 inf_b op_b n r
 167                  EQ ->
 168                         let ass = \case
 169                                  AssocL -> SideL
 170                                  AssocR -> SideR
 171                                  AssocB lr -> lr in
 172                         case (ass <$> infix_assoc inf_b, ass <$> infix_assoc inf_a) of
 173                          (Just SideL, Just SideL) -> do
 174                                 n <- insertInfix nod_a in_ (Right l)
 175                                 Right $ OpTree2 inf_b op_b n r
 176                          (Just SideR, Just SideR) ->
 177                                 Right $ OpTree2 inf_a op_a nod_a nod_b
 178                          _ -> Left $ Error_Fixity_Infix_not_combinable inf_a inf_b
 179                                  -- NOTE: non-associating infix ops
 180                                  -- of the same precedence cannot be mixed.
 181
 182 -- | Collapse an 'OpTree'.
 183 evalOpTree :: OpTree a -> a
 184 evalOpTree (OpTree0 a) = a
 185 evalOpTree (OpTree1 _uni op n) = op $ evalOpTree n
 186 evalOpTree (OpTree2 _inf op l r) = evalOpTree l `op` evalOpTree r
 187
 188 gram_operators :: (Gram_Op g, Gram_RuleEBNF g) => [CF g ()]
 189 gram_operators =
 190  [ void $ operators (argEBNF "expr") (argEBNF "prefix") (argEBNF "infix") (argEBNF "postfix")
 191  ]