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

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