[Haskell-cafe] Precedence and associativity in a pretty-printer

[Ryan Ingram]

On 1/22/08, Benja Fallenstein <benja.fallenstein at gmail.com> wrote:
> Take a look at how Haskell's derived Show instances do it? :-)
>
> http://www.haskell.org/onlinereport/derived.html#sect10.4

I hate how Haskell handles precedence:
1) Arbitrary magic numbers for precedence, which isn't very natural.
2) Impossible to define operators that have higher precedence than
function application.
3) Impossible to define unary operators.
4) Because of (1), impossible to define an operator with higher
precedence than + but lower precedence than *, or similar.

When I was working through SPJ's "functional languages" book, (see
http://research.microsoft.com/~simonpj/Papers/pj-lester-book/) I was
determined to do a better job.  It's not that hard to define a partial
ordering between operators instead of using fixed categories for
precedences, so that's what I did.

So, given an environment which gives you a partial ordering between
operators and fixty declarations (left, right, or nofix), you can
write out expressions pretty easily:

type Name = String
data Operator = OpFunAp | Op Name

data PartialOrdering = PoLT | PoGT | PoEQ | PoNC deriving Eq
data Fixity = FixLeft | FixRight | FixNone deriving Eq

-- type FixityEnv = exercise for the reader
--   with operations:
-- contains :: FixityEnv -> Operator -> Bool
-- comparePrec :: FixityEnv -> Operator -> Operator -> PartialOrdering
-- fixity :: FixityEnv -> Operator -> Fixity

-- unary operators are also an exercise for the reader
-- you could also improve this to use ShowS and (.)
-- instead of String and (++) to avoid quadratic slowdown.

data FixityContext = FcNone | FcLeft Operator | FcRight Operator

parens :: Bool -> String -> String
parens False s = s
parens True s = "(" ++ s ++ ")"

print :: FixityEnv -> FixityContext -> Exp -> String
print env ctx (Ap (Ap (Sym operator) left) right)
    | env `contains` (Op operator) = printBinOp env ctxt operator left right
print env ctx (Ap left right) = printAp env ctxt left right
print env ctx (Sym name) = parens (env `contains` Op name) name

printBinOp :: FixityEnv -> FixityContext -> Name -> Exp -> Exp -> String
printBinOp env ctxt op left right =
    parens (needsParens env ctxt (Op op)) $ concat [
        print env (FcLeft $ Op op) left,
        " " ++ op ++ " ",
        print env (FcRight $ Op op) right ]

printAp :: FixityEnv -> FixityContext -> Exp -> Exp -> String
printAp env ctxt op left right =
    parens (needsParens env ctxt OpFunAp) $ concat [
        print env (FcLeft OpFunAp) left,
        " ",
        print env (FcRight OpFunAp) right ]

needsParens :: FixityEnv -> FixityContext -> Operator -> Bool
needsParens _ FcNone _ = False
needsParens env (FcLeft ctxt) op
    | comparePrec env ctxt op == PoLT = False
    | comparePrec env ctxt op == PoGT = True
    | comparePrec env ctxt op == PoNC = True
    -- otherwise the two operators have the same precedence
    | fixity ctxt /= fixity op = True
    | fixity ctxt == FixLeft = False
    | otherwise = True
needsParens env (FcRight ctxt) op
    | comparePrec env ctxt op == PoLT = False
    | comparePrec env ctxt op == PoGT = True
    | comparePrec env ctxt op == PoNC = True
    -- otherwise the two operators have the same precedence
    | fixity ctxt /= fixity op = True
    | fixity ctxt == FixRight = False
    | otherwise = True