Skip to content

Instantly share code, notes, and snippets.

@bynect

bynect/oper.hs

Created July 16, 2025 22:12
Show Gist options
  • Save bynect/215f7f1ed1117fc5a6b5b0c3314e493c to your computer and use it in GitHub Desktop.
Save bynect/215f7f1ed1117fc5a6b5b0c3314e493c to your computer and use it in GitHub Desktop.
Download ZIP
Operator fixup (experimental)
Raw
oper.hs
{- vim: set sw=2 ts=2 et: -}
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad.Fail
data Expr = Var String
| Infixes [String] Expr Expr
| Infix String Expr Expr
| Prefix String Expr
| Postfix String Expr
deriving (Eq, Show)
data OpAssoc = LeftAssoc
| RightAssoc
| NonAssoc
deriving (Eq, Show)
data OpKind = OpPrefix
| OpPostfix
| OpInfix OpAssoc
deriving (Eq, Show)
type OpPrec = Int
type OpInfo = (OpPrec, OpKind)
type OpMap = Map String OpInfo
{-
There should always be at least one infix operator between two expressions.
Prefix can be followed by prefix and preceded by infix.
Postfix can be followed by infix or postfix and preceded by postfix.
Infix can be preceded by postfix and followed by prefix.
Example:
expr op1 op2 op3 op4 expr
op1 can be either postfix or infix;
op2 can be either postfix, infix or prefix;
op3 can be either postfix, infix or prefix;
op4 can be either infix or prefix.
-}
fixup :: Expr -> OpMap -> Either String Expr
fixup e om = case e of
Var x -> Right e
Infixes ops e1 e2 -> fixup_ops ops e1 e2 om >>= flip fixup om
Infix op e1 e2 | Just oi <- Map.lookup op om -> do
e1 <- fixup e1 om
e2 <- fixup e2 om
case snd oi of
OpInfix _ -> Right $ Infix op e1 e2
_ -> Left $ op ++ " is not infix"
| otherwise -> Left $ op ++ " is not bound"
Prefix op e | Just oi <- Map.lookup op om -> do
e <- fixup e om
case snd oi of
OpPrefix -> Right $ Prefix op e
_ -> Left $ op ++ " is not prefix"
| otherwise -> Left $ op ++ " is not bound"
Postfix op e | Just oi <- Map.lookup op om -> do
e <- fixup e om
case snd oi of
OpPostfix -> Right $ Postfix op e
_ -> Left $ op ++ " is not postfix"
| otherwise -> Left $ op ++ " is not bound"
fixup_ops :: [String] -> Expr -> Expr -> OpMap -> Either String Expr
fixup_ops ops e1 e2 om = do
e1 <- fixup e1 om
e2 <- fixup e2 om
(post, inf, pre) <- go ops ([], Nothing, [])
case inf of
Just op -> Right $ Infix op (foldl (flip Postfix) e1 post) (foldr Prefix e2 pre)
_ -> Left "no infix operator used in expression"
where
go :: [String] -> ([String], Maybe String, [String]) -> Either String ([String], Maybe String, [String])
go (op:ops) (post, inf, pre) | Just oi <- Map.lookup op om = case snd oi of
OpInfix _ | Nothing <- inf -> go ops (post, Just op, pre)
| otherwise -> Left $ op ++ " is infix, but infix is alredy in the expression"
OpPostfix | Nothing <- inf -> go ops (post ++ [op], Nothing, pre)
| otherwise -> Left $ op ++ " is postfix, but it is used after an infix"
OpPrefix | Just _ <- inf -> go ops (post, inf, pre ++ [op])
| otherwise -> Left $ op ++ " is prefix, but it is used before an infix"
go (op:_) _ = Left $ op ++ " is not bound"
go [] acc = Right acc
{-
Prefix operators are always right associative
Postfix operators are always left associative
-}
get_assoc :: OpKind -> OpAssoc
get_assoc (OpInfix a) = a
get_assoc OpPrefix = RightAssoc
get_assoc OpPostfix = LeftAssoc
{-
fixup_fixity :: Expr -> OpMap -> Either String Expr
fixup_fixity e om = case e of
Infix op e1 e2 -> go op e1 e2 Infix
Prefix op e -> go op e () (\op e () -> Prefix op e)
Postfix op e -> go op e () (\op e () -> Postfix op e)
where
go :: String -> Expr -> a -> (String -> Expr -> a -> Expr) -> Either String Expr
go op e1 e2 f = case e1 of
Infix op' e3 e4 | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ "unresolvable fixity"
else if p < p' || (p == p' && a == RightAssoc)
-- e1 e2
-- vvvvv v
-- a + b * c
-- ^ ^
-- | \ e4
-- e3
-- Infix op e3 (Infix op' e4 e2)
then fixup_fixity (f op' e4 e2) om >>= \e -> Right $ Infix op e3 e
else Right $ f op e1 e2
Prefix op' e3 | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ "unresolvable fixity"
else if p < p' || (p == p' && a == RightAssoc)
-- e1
-- vvvvvv
-- !b + a
-- ^^^^^
-- e3
then fixup_fixity (f op' e3 e2) om >>= \e -> Right $ Prefix op e
else Right $ f op e1 e2
_ -> Right $ f op e1 e2
-}
{-
case e' of
(Binop (Binop c op1 fx1 d _) op2 fx2 e _) -> do
fx1' <- lookupFixity fx1 op1
fx2' <- lookupFixity fx2 op2
let ~[prec1, prec2] = getPrecedence <$> [fx1', fx2']
let ~[assoc1, assoc2] = getAssoc <$> [fx1', fx2']
if prec1 == prec2 && assoc1 /= assoc2
then lift (Left (IrresolvableInfix tag))
else if prec1 < prec2 || (prec1 == prec2 && assoc1 == RAssoc)
then Binop c op1 fx1' <$> resolveExpr (Binop d op2 fx2' e tag) <*> return tag
else return e'-}
-- Infix op (Infix op' e3 e4) e2
-- Infix op e3 (Infix op' e4 e2)
{-
e1 e2
v vvvvv
a + b * c
^ ^
e3 e4
-}
{-
Note: For this to work, everything has to be parsed with same precedence and a right-associativity
Todo: What about explicitly parenthesized expressions? Are those resolved nevertheless?
Note: The main machinery used in this algorithm is left-shifting operator application.
See the comment below.
If the default parsing was left-associative then we would have to right-shift instead.
This piece of code:
-- e1 op e2@(e3 op' e4) ==> (e1 op' e3) op e4
else if p > p' || (p == p' && a' == LeftAssoc)
then resolve (Infix op e1 e3) om >>= \e -> Right $ Infix op' e e4
should be changed to:
-- e1@(e3 op' e4) op e2 ==> e3 op (e4 op' e2)
else if p > p' || (p == p' && a' == RightAssoc)
then resolve (Infix op e4 e2) om >>= \e -> Right $ Infix op' e3 e
-}
-- TODO: Add shifting for postfix and prefix operator (based on precedence)
resolve :: Expr -> OpMap -> Either String Expr
resolve (Infix op e1 e2) om = do
e1 <- resolve e1 om
e2 <- resolve e2 om
case e2 of
Infix op' e3 e4 | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
else if p > p' || (p == p' && a' == LeftAssoc)
-- e1 op (e3 op' e4)
-- ==>
-- (e1 op' e3) op e4
--
-- Infix op e1 (Infix op' e3 e4)
-- ==>
-- Infix op (Infix op' e1 e3) e4
then resolve (Infix op e1 e3) om >>= \e -> Right $ Infix op' e e4
else Right $ Infix op e1 e2
Postfix op' e3 | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
else if p > p' || (p == p' && a' /= RightAssoc)
-- Infix op e1 (Postfix op' e3)
-- ==>
-- Postfix op' (Infix op e1 e3)
then resolve (Infix op e1 e3) om >>= \e -> Right $ Postfix op' e
else Right $ Infix op e1 e2
_ -> Right $ Infix op e1 e2
resolve (Prefix op e) om = do
e <- resolve e om
case e of
Infix op' e1 e2 | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
else if p > p' || (p == p' && a' /= RightAssoc)
-- Prefix op (Infix op' e1 e2)
-- ==>
-- Infix op' (Prefix op e1) e2
then resolve (Prefix op e1) om >>= \e -> Right $ Infix op' e e2
else Right $ Prefix op e
Postfix op' e | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
--else if p > p' || (p == p' && a' == LeftAssoc)
else if p > p' || (p == p' && a' /= RightAssoc)
-- Prefix op (Postfix op' e)
-- ==>
-- Postfix op' (Prefix op e)
then resolve (Prefix op e) om >>= \e -> Right $ Postfix op' e
else Right $ Prefix op e
Prefix op' e | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
else if p > p' || (p == p' && a' /= RightAssoc)
-- Prefix op (Prefix op' e)
-- ==>
-- Prefix op' (Prefix op e)
then resolve (Prefix op e) om >>= \e -> Right $ Prefix op' e
else Right $ Prefix op e
_ -> Right $ Prefix op e
resolve (Postfix op e) om = do
e <- resolve e om
case e of
Infix op' e1 e2 | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
else if p > p' || (p == p' && a' /= RightAssoc)
-- Postfix op (Infix op' e1 e2)
-- ==>
-- Postfix op' (Prefix op e1) e2
then resolve (Postfix op e1) om >>= \e -> Right $ Infix op' e e2
else Right $ Postfix op e
-- Prefix is not needed here due to the way prefix are parsed
Postfix op' e | Just (p, k) <- Map.lookup op om,
Just (p', k') <- Map.lookup op' om -> do
let [a, a'] = map get_assoc [k, k']
if p == p' && a /= a'
then Left $ op ++ " and " ++ op' ++ " are not compatible"
else if p > p' || (p == p' && a' /= RightAssoc)
-- Postfix op (Postfix op' e)
-- ==>
-- Postfix op' (Postfix op e)
then resolve (Postfix op e) om >>= \e -> Right $ Postfix op' e
else Right $ Postfix op e
_ -> Right $ Postfix op e
resolve e om = Right e
{-
!a.b
(! (. a b))
!a + b
(+ (! a) b)
!a.b + c
(+ (! (. a b)) c)
a.b.c.d
((a.b).c).d
(. (. (. a b) c) d)
-}
sexpr :: Expr -> String
sexpr e = case e of
Var x -> x
Infixes ops e1 e2 -> foldl (\acc op -> acc ++ op ++ " ") "([" ops ++ "] " ++ sexpr e1 ++ " " ++ sexpr e2 ++ ")"
Infix op e1 e2 -> "(" ++ op ++ " " ++ sexpr e1 ++ " " ++ sexpr e2 ++ ")"
Prefix op e -> "(" ++ op ++ " " ++ sexpr e ++ ")"
Postfix op e -> "(" ++ op ++ " " ++ sexpr e ++ ")"
main :: IO ()
main = do
putStrLn . sexpr $ e
case fixup e om of
Left e -> putStrLn e
Right e -> do
putStrLn . sexpr $ e
case resolve e om of
Right e -> putStrLn . sexpr $ e
Left e -> putStrLn e
where
-- (!a? + ~b^) * c?
--e = Infix "*" (Prefix "!" (Infixes ["?", "-", "~"] (Var "a") (Postfix "^" (Var "b")))) (Postfix "?" (Var "c"))
-- !a? + ~b^ * c?
-- ((!a)?) + (((~b)^) * (c?))
-- (+ (? (! a)) (* (^ (~ b)) (? c)))
--
-- (! (+ (? a) (~ (* (^ b) (? c)))))
--e = Prefix "!" (Infixes ["?", "+", "~"] (Var "a") (Infixes ["^", "*"] (Var "b") (Postfix "?" (Var "c"))))
-- a + b * c - d
-- (a + (b * c)) - d
-- (- (+ a (* b c)) d)
--e = Infix "+" (Var "a") (Infix "*" (Var "b") (Infix "-" (Var "c") (Var "d")))
-- !a.x + b * c - d
-- ((!(a.x)) + (b * c)) - d
-- (- (+ (! (. a x)) (* b c) d)
--e = Prefix "!" (Infix "." (Var "a") (Infix "+" (Var "x") (Infix "*" (Var "b") (Infix "-" (Var "c") (Var "d")))))
-- a.x? ? + b * c - d
-- ((((a.x)?)?) + (b * c)) - d
-- (- (+ (? (? (. a x))) (* b c) d)
--e = Infix "." (Var "a") (Infixes ["?", "?", "+"] (Var "x") (Infix "*" (Var "b") (Infix "-" (Var "c") (Var "d"))))
-- & ^a * b?
-- (& (^ (* a (? b))))
-- ==>
-- (* (& (^ a)) (? b))
--e = Prefix "&" (Prefix "^" (Infix "*" (Var "a") (Postfix "?" (Var "b"))))
-- & ^a * b? - &c * d?
-- (& (^ (* a (? (- b (& (* c (? d))))))))
-- ==>
-- (- (* (& (^ a)) (? b)) (* (& c) (? d)))
{-e = Prefix "&" (Prefix "^" (Infix "*" (Var "a") (Infixes ["?", "-", "&"] (Var "b") (Infix "*" (Var "c") (Postfix "?" (Var "d"))))))
om = Map.fromList
[ ("+", (10, OpInfix LeftAssoc))
, ("-", (10, OpInfix LeftAssoc))
, ("*", (11, OpInfix LeftAssoc))
, ("^", (20, OpPrefix))
, ("?", (18, OpPostfix))
, (".", (20, OpInfix LeftAssoc))
, ("&", (15, OpPrefix))
, ("~", (13, OpPrefix))
, ("!", (15, OpPrefix)) ]-}
-- * ++ p --
e = Prefix "*" (Prefix "++" (Postfix "--" (Var "p")))
om = Map.fromList
[ ("*", (10, OpPrefix))
, ("++", (10, OpPrefix))
, ("--", (11, OpPostfix)) ]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment