1 module Prec
    2 
    3 ( glue
    4 )
    5 
    6 where
    7 
    8 import Maybes
    9 
   10 import Syntax
   11 import Ids
   12 
   13 
   14 import Trace
   15 
   16 -------------------------------------------------------------------
   17 
   18 
   19 glue :: [Either Exp Id] -> Exp
   20 
   21 -- handle precedences of operators, input looks like
   22 -- [ Left 3, Right (+), Left 4, Right (*), Left 7, Right (-), Left 5 ]
   23 
   24 glue [Left x] = x
   25 
   26 -- glue [Left x , Right op , Left y] = App op [x, y]
   27 
   28 glue (Left x : rest) = pop (handle rest ([x], []))
   29 
   30 
   31 pop :: ([Exp],[Id]) -> Exp
   32 -- pop stacks completely
   33 pop ([x],          []      ) = x
   34 pop (x : y : rest, op : ops) = pop (App op [y, x] : rest, ops)
   35 
   36 
   37 handle :: [Either Exp Id] -> ([Exp],[Id]) -> ([Exp],[Id])
   38 
   39 handle [] (args, ops) = (args, ops)
   40 handle inp @ (Right nop : Left arg : rest) (args, ops {- @ ~(op : _) -} ) = 
   41     let
   42          np = the (idprec nop); p = the (idprec op)
   43          (op : _) = ops        -- lazily (hbc doesn't like ~ patterns)
   44     in
   45         
   46 --      trace ("\nhandle.inp : " ++ show inp) $
   47 --      trace ("\nhandle.args : " ++ show args) $
   48 --      trace ("\nhandle.ops : " ++ show ops) $
   49 
   50         if not (null ops) && not (exists (idprec nop))
   51         then error ("operator has no precedence: " ++ idname nop)
   52 
   53         else if null ops || np > p     -- push it
   54         then handle rest (arg : args, nop : ops)
   55 
   56         else if np < p -- pop it
   57         then handle inp  ( App op [args !! 1, args !! 0] : drop 2 args
   58                            , tail ops)
   59 
   60 
   61         -- here, precedence levels coincide
   62         -- therefore operators must be identical
   63         else if nop /= op 
   64         then error ("same precedences: " ++ idname nop ++ ", " ++ idname op)
   65 
   66         -- now they are the same
   67         else case idbind op of
   68             Nn -> error ("not associative at all: " ++ idname op)
   69             Rght -> -- push it
   70                 handle rest (arg : args, nop : ops)
   71             Lft -> -- pop it
   72                 handle inp ( App op [args !! 1, args !! 0] : drop 2 args
   73                            , tail ops)
   74 
   75 
   76 handle inp (args, ops) = 
   77     error ("strange case for handle: "
   78         ++ "\nhandle.inp : " ++ show inp
   79         ++ "\nhandle.args : " ++ show args
   80         ++ "\nhandle.ops : " ++ show ops)