FixityResolution: resolve.hs

data Op     = Op String Prec Fixity          deriving Eq
data Fixity = Leftfix | Rightfix | Nonfix    deriving Eq
data Exp    = Var Var | OpApp Exp Op Exp     deriving Eq
type Prec   = Int
type Var    = String

data Tok = TVar Var | TOp Op

parse :: [Tok] -> Exp
parse (TVar x : rest) = fst (parse1 (Var x) (-1) Nonfix rest)

parse1 :: Exp -> Int -> Fixity -> [Tok] -> (Exp, [Tok])
parse1 e p f [] = (e, [])
parse1 e p f inp@(TOp op@(Op _ p' f') : TVar x : rest) 
  | p' == p && (f /= f' || f == Nonfix)
  = error "ambiguous infix expression"
  | p' < p  ||  p' == p && (f == Leftfix || f' == Nonfix)
  = (e, inp)
  | otherwise
  = let (r,rest') = parse1 (Var x) p' f' rest in
    parse1 (OpApp e op r) p f rest'

-- Printing

instance Show Exp where
  showsPrec _ (Var x) = showString x
  showsPrec p e@(OpApp l (Op op _ _) r) = 
        showParen (p > 0) $ showsPrec 9 l . showString op . showsPrec 9 r

-- Testing

plus   = TOp (Op "+" 6 Leftfix)
times  = TOp (Op "*" 7 Leftfix)
divide = TOp (Op "/" 7 Leftfix)
gt     = TOp (Op ">" 4 Nonfix)
ex     = TOp (Op "^" 8 Rightfix)

lookupop '+' = plus
lookupop '*' = times
lookupop '/' = divide
lookupop '>' = gt
lookupop '^' = ex

fromstr [x]     = [TVar [x]]
fromstr (x:y:z) = TVar [x] : lookupop y : fromstr z

test1 = fromstr "a+b+c"
test2 = fromstr "a+b+c*d"
test3 = fromstr "a/b/c"
test4 = fromstr "a/b+c"
test5 = fromstr "a/b*c"
test6 = fromstr "1^2^3+4"
test7 = fromstr "a/1^2^3"
test8 = fromstr "a*b/c"