+-- | Symantics to handle 'Prefix', 'Postfix' or 'Infix' operators,
+-- of different 'Precedence's and possibly with left and/or right 'Associativity'.
module Language.Symantic.Grammar.Operators where
import Control.Applicative (Applicative(..))
-import Control.Monad
-import Data.Foldable hiding (any)
-import Prelude hiding (any)
+import Control.Monad (void)
+import Data.Foldable
+import Language.Symantic.Grammar.Fixity
import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal
import Language.Symantic.Grammar.Regular
import Language.Symantic.Grammar.ContextFree
-- * Class 'Gram_Op'
+-- | Symantics for operators.
class
- ( Alt g
- , Alter g
- , App g
- , Gram_CF g
+ ( Gram_Char g
+ , Gram_String g
, Gram_Rule g
- , Gram_Terminal g
+ , Gram_Alt g
+ , Gram_Try g
+ , Gram_App g
+ , Gram_AltApp g
+ , Gram_CF g
) => Gram_Op g where
operators
:: CF g a -- ^ expression
-> CF g (Infix , a -> a -> a) -- ^ infix operator
-> CF g (Unifix, a -> a) -- ^ postfix operator
-> CF g (Either Error_Fixity a)
- operators g prG iG poG =
- (evalOpTree <$>)
- <$> go g prG iG poG
+ operators g prefixG infixG postfixG =
+ (evalOpTree <$>) <$> go g prefixG infixG postfixG
where
go
:: CF g a
go = rule4 "operators" $ \aG preG inG postG ->
(\pres a posts ->
let nod_a =
- foldr insert_unifix
- (foldl' (flip insert_unifix) (OpNode0 a) posts)
+ foldr insertUnifix
+ (foldl' (flip insertUnifix) (OpTree0 a) posts)
pres
in \case
- Just (in_, b) -> insert_infix nod_a in_ b
+ Just (in_, b) -> insertInfix nod_a in_ b
Nothing -> Right nod_a)
- <$> many preG
+ <$> many (try preG)
<*> aG
- <*> many postG
- <*> option Nothing (curry Just <$> inG <*> go aG preG inG postG)
-
- insert_unifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
- insert_unifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
- case nod_b of
- OpNode0{} -> OpNode1 uni_a op_a nod_b
- OpNode1 Prefix{} _op_b _nod -> OpNode1 uni_a op_a nod_b
- OpNode1 uni_b@(Postfix prece_b) op_b nod ->
- case prece_b `compare` prece_a of
- GT -> OpNode1 uni_a op_a nod_b
- EQ -> OpNode1 uni_a op_a nod_b
- LT -> OpNode1 uni_b op_b $ insert_unifix a nod
- OpNode2 inf_b op_b l r ->
- case infix_prece inf_b `compare` prece_a of
- GT -> OpNode1 uni_a op_a nod_b
- EQ -> OpNode1 uni_a op_a nod_b
- LT -> OpNode2 inf_b op_b (insert_unifix a l) r
- insert_unifix a@(uni_a@(Postfix prece_a), op_a) nod_b =
- case nod_b of
- OpNode0{} -> OpNode1 uni_a op_a nod_b
- OpNode1 uni_b@(Prefix prece_b) op_b nod ->
- case prece_b `compare` prece_a of
- GT -> OpNode1 uni_a op_a nod_b
- EQ -> OpNode1 uni_a op_a nod_b
- LT -> OpNode1 uni_b op_b $ insert_unifix a nod
- OpNode1 Postfix{} _op_b _nod -> OpNode1 uni_a op_a nod_b
- OpNode2 inf_b op_b l r ->
- case infix_prece inf_b `compare` prece_a of
- GT -> OpNode1 uni_a op_a nod_b
- EQ -> OpNode1 uni_a op_a nod_b
- LT -> OpNode2 inf_b op_b l (insert_unifix a r)
-
- insert_infix
- :: OpTree a
- -> (Infix, a -> a -> a)
- -> Either Error_Fixity (OpTree a)
- -> Either Error_Fixity (OpTree a)
- insert_infix nod_a in_@(inf_a, op_a) e_nod_b = do
- nod_b <- e_nod_b
- case nod_b of
- OpNode0{} -> Right $ OpNode2 inf_a op_a nod_a nod_b
- OpNode1 uni_b op_b nod ->
- case unifix_prece uni_b `compare` infix_prece inf_a of
- EQ -> Right $ OpNode2 inf_a op_a nod_a nod_b
- GT -> Right $ OpNode2 inf_a op_a nod_a nod_b
- LT -> do
- n <- insert_infix nod_a in_ (Right nod)
- Right $ OpNode1 uni_b op_b n
- OpNode2 inf_b op_b l r ->
- case infix_prece inf_b `compare` infix_prece inf_a of
- GT -> Right $ OpNode2 inf_a op_a nod_a nod_b
- LT -> do
- n <- insert_infix nod_a in_ (Right l)
- Right $ OpNode2 inf_b op_b n r
- EQ ->
- let ass = \case
- AssocL -> L
- AssocR -> R
- AssocB lr -> lr in
- case (ass <$> infix_assoc inf_b, ass <$> infix_assoc inf_a) of
- (Just L, Just L) -> do
- n <- insert_infix nod_a in_ (Right l)
- Right $ OpNode2 inf_b op_b n r
- (Just R, Just R) ->
- Right $ OpNode2 inf_a op_a nod_a nod_b
- _ -> Left $ Error_Fixity_Infix_not_combinable inf_a inf_b
- -- NOTE: non-associating infix ops
- -- of the same precedence cannot be mixed.
+ <*> many (try postG)
+ <*> option Nothing (curry Just <$> try inG <*> go aG preG inG postG)
infixrG :: CF g a -> CF g (a -> a -> a) -> CF g a
infixrG = rule2 "infixr" $ \g opG ->
(\a -> \case
Just (op, b) -> a `op` b
Nothing -> a)
<$> g
- <*> option Nothing (curry Just <$> opG <*> infixrG g opG)
+ <*> option Nothing (try $ curry Just <$> opG <*> infixrG g opG)
infixlG :: CF g a -> CF g (a -> a -> a) -> CF g a
infixlG = rule2 "infixl" $ \g opG ->
-- NOTE: infixl uses the same grammar than infixr,
Just (op, kb) -> \k -> kb (k a `op`)
Nothing -> ($ a))
<$> g
- <*> option Nothing (curry Just <$> opG <*> go g opG)
+ <*> option Nothing (try $ curry Just <$> opG <*> go g opG)
deriving instance Gram_Op g => Gram_Op (CF g)
-instance Gram_Op RuleDef
+instance Gram_Op RuleEBNF
instance Gram_Op EBNF
-- ** Type 'Error_Fixity'
data Error_Fixity
= Error_Fixity_Infix_not_combinable Infix Infix
- | Error_Fixity_NeedPostfixOrInfix
- | Error_Fixity_NeedPrefix
- | Error_Fixity_NeedPostfix
- | Error_Fixity_NeedInfix
- deriving (Eq, Show)
-
--- ** Type 'NeedFixity'
-data NeedFixity
- = NeedPrefix
- | NeedPostfix
- | NeedPostfixOrInfix
- deriving (Eq, Ord, Show)
-
--- ** Type 'Fixity'
-data Fixity a
- = FixityPrefix Unifix (a -> a)
- | FixityPostfix Unifix (a -> a)
- | FixityInfix Infix (a -> a -> a)
-
--- ** Type 'Unifix'
-data Unifix
- = Prefix { unifix_prece :: Precedence }
- | Postfix { unifix_prece :: Precedence }
+ {-
+ Error_Fixity_NeedPostfixOrInfix
+ Error_Fixity_NeedPrefix
+ Error_Fixity_NeedPostfix
+ Error_Fixity_NeedInfix
+ -}
deriving (Eq, Show)
-- ** Type 'OpTree'
+-- | Tree of operators.
+--
+-- Useful to recombine operators according to their 'Precedence'.
data OpTree a
- = OpNode0 a
- | OpNode1 Unifix (a -> a) (OpTree a)
- | OpNode2 Infix (a -> a -> a) (OpTree a) (OpTree a)
+ = OpTree0 a
+ | OpTree1 Unifix (a -> a) (OpTree a)
+ | OpTree2 Infix (a -> a -> a) (OpTree a) (OpTree a)
+instance Show a => Show (OpTree a) where
+ showsPrec n (OpTree0 a) =
+ showParen (n > 10) $ showString "OpTree0 "
+ . showsPrec 11 a
+ showsPrec n (OpTree1 f _ a) =
+ showParen (n > 10) $ showString "OpTree1 "
+ . showsPrec 11 f
+ . showChar ' ' . showsPrec 11 a
+ showsPrec n (OpTree2 f _ a b) =
+ showParen (n > 10) $ showString "OpTree2 "
+ . showsPrec 11 f
+ . showChar ' ' . showsPrec 11 a
+ . showChar ' ' . showsPrec 11 b
+
+-- | Insert an 'Unifix' operator into an 'OpTree'.
+insertUnifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
+insertUnifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
+ case nod_b of
+ OpTree0{} -> OpTree1 uni_a op_a nod_b
+ OpTree1 Prefix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
+ OpTree1 uni_b@(Postfix prece_b) op_b nod ->
+ case prece_b `compare` prece_a of
+ GT -> OpTree1 uni_a op_a nod_b
+ EQ -> OpTree1 uni_a op_a nod_b
+ LT -> OpTree1 uni_b op_b $ insertUnifix a nod
+ OpTree2 inf_b op_b l r ->
+ case infix_prece inf_b `compare` prece_a of
+ GT -> OpTree1 uni_a op_a nod_b
+ EQ -> OpTree1 uni_a op_a nod_b
+ LT -> OpTree2 inf_b op_b (insertUnifix a l) r
+insertUnifix a@(uni_a@(Postfix prece_a), op_a) nod_b =
+ case nod_b of
+ OpTree0{} -> OpTree1 uni_a op_a nod_b
+ OpTree1 uni_b@(Prefix prece_b) op_b nod ->
+ case prece_b `compare` prece_a of
+ GT -> OpTree1 uni_a op_a nod_b
+ EQ -> OpTree1 uni_a op_a nod_b
+ LT -> OpTree1 uni_b op_b $ insertUnifix a nod
+ OpTree1 Postfix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
+ OpTree2 inf_b op_b l r ->
+ case infix_prece inf_b `compare` prece_a of
+ GT -> OpTree1 uni_a op_a nod_b
+ EQ -> OpTree1 uni_a op_a nod_b
+ LT -> OpTree2 inf_b op_b l (insertUnifix a r)
+
+-- | Insert an 'Infix' operator into an 'OpTree'.
+insertInfix
+ :: OpTree a
+ -> (Infix, a -> a -> a)
+ -> Either Error_Fixity (OpTree a)
+ -> Either Error_Fixity (OpTree a)
+insertInfix nod_a in_@(inf_a, op_a) e_nod_b = do
+ nod_b <- e_nod_b
+ case nod_b of
+ OpTree0{} -> Right $ OpTree2 inf_a op_a nod_a nod_b
+ OpTree1 uni_b op_b nod ->
+ case unifix_prece uni_b `compare` infix_prece inf_a of
+ EQ -> Right $ OpTree2 inf_a op_a nod_a nod_b
+ GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
+ LT -> do
+ n <- insertInfix nod_a in_ (Right nod)
+ Right $ OpTree1 uni_b op_b n
+ OpTree2 inf_b op_b l r ->
+ case infix_prece inf_b `compare` infix_prece inf_a of
+ GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
+ LT -> do
+ n <- insertInfix nod_a in_ (Right l)
+ Right $ OpTree2 inf_b op_b n r
+ EQ ->
+ let ass = \case
+ AssocL -> SideL
+ AssocR -> SideR
+ AssocB lr -> lr in
+ case (ass <$> infix_assoc inf_b, ass <$> infix_assoc inf_a) of
+ (Just SideL, Just SideL) -> do
+ n <- insertInfix nod_a in_ (Right l)
+ Right $ OpTree2 inf_b op_b n r
+ (Just SideR, Just SideR) ->
+ Right $ OpTree2 inf_a op_a nod_a nod_b
+ _ -> Left $ Error_Fixity_Infix_not_combinable inf_a inf_b
+ -- NOTE: non-associating infix ops
+ -- of the same precedence cannot be mixed.
-- | Collapse an 'OpTree'.
evalOpTree :: OpTree a -> a
-evalOpTree (OpNode0 a) = a
-evalOpTree (OpNode1 _uni op n) = op $ evalOpTree n
-evalOpTree (OpNode2 _inf op l r) = evalOpTree l `op` evalOpTree r
+evalOpTree (OpTree0 a) = a
+evalOpTree (OpTree1 _uni op n) = op $ evalOpTree n
+evalOpTree (OpTree2 _inf op l r) = evalOpTree l `op` evalOpTree r
-gram_operators :: (Gram_Op g, Gram_RuleDef g) => [CF g ()]
+gram_operators :: (Gram_Op g, Gram_RuleEBNF g) => [CF g ()]
gram_operators =
- [ void $ operators (rule_arg "expr") (rule_arg "prefix") (rule_arg "infix") (rule_arg "postfix")
+ [ void $ operators (argEBNF "expr") (argEBNF "prefix") (argEBNF "infix") (argEBNF "postfix")
]
sourcephile / git / haskell / symantic.git / blobdiff