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