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