{- ---------------------------------------------------------------------------
Restructure expressions with infix operators according to associativity and
precedence.
-}
module Fixity(fixInfixList) where

import Extra(strPos)
import Syntax hiding (TokenId)
import SyntaxPos
import TokenId(TokenId(..), t_flip)
import IdKind(IdKind(..))
import State
import RenameLib


-- Just == Bind
-- Nothing == Stack

reorder es = getExp [] [] es

getExp ops exps (e:es) =
  case e of
    ExpConOp pos o ->
      fixTid Con o >>>= \ fix ->
        case fix of
	  (InfixPre a,l) -> getExp (stackPrefix fix (ExpCon pos o):ops) exps es
          _ -> error ("Mistake in an infix constructor application ("
                     ++show o++") at "++strPos (getPos e))
    ExpVarOp pos o ->
      fixTid Var o >>>= \ fix ->
        case fix of
	  (InfixPre a,l) -> getExp (stackPrefix fix (ExpVar pos o):ops) exps es
          _ -> error ("Mistake in an infix operator chain involving ("
                     ++show o++") at "++strPos (getPos e))
    _ ->
      getOp ops (e:exps) es
getExp ops [] [] =
   error ("Problem with infix section at unknown location.")
getExp ops (e:es) [] =
   error ("Problem with infix section at "++strPos (getPos e))

getOp ops exps [] = finish ops exps
getOp ops exps ees@(ExpConOp pos op:es) =
  harder pos ops Con op >>>= \ lr ->  
  case lr of
    Just (o,ops) -> getOp   ops          (rebuild o exps) ees
    Nothing      -> stackInfix (ExpCon pos op) >>>= \ fop -> getExp  (fop:ops) exps es
getOp ops exps ees@(ExpVarOp pos op:es) =
  harder pos ops Var op >>>= \ lr ->  
  case lr of
    Just  (o,ops) -> getOp   ops          (rebuild o exps) ees
    Nothing       -> stackInfix (ExpVar pos op) >>>= \ fop -> getExp  (fop:ops) exps es
getOp ops exps (e:es) =
   error ("Expected an infix operator at " ++ strPos (getPos e))
 

finish [] []   = error "finish empty" 
finish [] [e] = unitS e
finish [] _   = error "finish multiple expression"
finish (o:ops) es = finish ops (rebuild o es)

        
stackInfix op@(ExpVar _ o) = fixTid Var o >>>= \ fix -> unitS (fix,(op,2::Int))
stackInfix op@(ExpCon _ o) = fixTid Con o >>>= \ fix -> unitS (fix,(op,2::Int))

stackPrefix fix op = (fix,(op,1::Int))

--harder :: Pos -> [((InfixClass a,Int),(g,f))] -> IdKind -> e 
--		-> State (b,(e -> TokenId),c,d) RenameState (Maybe ((((InfixClass a),Int),(g,f)),[((InfixClass a,Int),(g,f))])) RenameState 

harder pos [] kind op' = unitS Nothing
harder pos (ipop@((inf,pri),(op,_)):ops) kind op' =
  fixTid kind op' >>>= \ (inf',pri') ->
  if pri > pri' then
    unitS (Just (ipop,ops))
  else if pri == pri' then
    case inf of
      InfixDef   -> unitS (Just (ipop,ops))
      InfixL     -> unitS (Just (ipop,ops))
      InfixPre _ -> unitS (Just (ipop,ops))
      InfixR     -> unitS (Nothing)
      Infix      -> renameError ("Infix operator at " ++ strPos pos ++ " is non-associative.") (Just (ipop,ops))
  else unitS Nothing

rebuild (_,(op,2)) (e1:e2:es) = ExpApplication (getPos op) [op,e2,e1]:es
rebuild ((InfixPre fun,_) ,(op,_)) (e1:es) =
        ExpApplication (getPos op) [ExpVar (getPos op) fun,e1]:es
rebuild (_,(op,n)) es =
        error ("Not enough arguments at " ++ strPos (getPos op))

{-
Main function of the module.
-}
fixInfixList :: [Exp TokenId] -> RenameMonad (Exp TokenId)

fixInfixList [] = error "I: fixInfix []"
fixInfixList ees@(ExpVarOp pos op:es) =
  fixTid Var op >>>= \ fix ->
        case fix of
	  (InfixPre a,l) -> reorder ees
	  _ -> reorder es >>>= \ exp -> 
               invertCheck pos op fix exp >>>
               unitS (ExpApplication pos 
                       [ExpVar pos t_flip, ExpVar pos op, exp])
               -- desugaring with flip better than lambda for reading a trace
fixInfixList ees@(ExpConOp pos op:es) =
  fixTid Con op >>>= \ fix ->
        case fix of
	  (InfixPre a,l) -> reorder ees
	  _ -> reorder es >>>= \ exp -> 
               invertCheck pos op fix exp >>>
               unitS (ExpApplication pos 
                       [ExpVar pos t_flip, ExpCon pos op, exp]) 
               -- desugaring with flip better than lambda for reading a trace
fixInfixList ees =
  case last ees of
    ExpConOp pos op -> reorder (init ees) >>>= \ exp -> 
                       fixTid Con op >>>= \ fix ->
                       invertCheck pos op fix exp >>>
                       unitS (ExpApplication pos [ExpCon pos op,exp])
    ExpVarOp pos op -> reorder (init ees) >>>= \ exp -> 
                       fixTid Var op >>>= \ fix ->
                       invertCheck pos op fix exp >>>
                       unitS (ExpApplication pos [ExpVar pos op,exp])
    _ -> reorder ees

-- 'invertCheck' checks for priority inversion in an operator section.
invertCheck pos1 op1 (fix1,pri1) exp =
  case exp of
    ExpApplication _ (ExpVar pos2 op2: es) -> check Var pos2 op2
    ExpApplication _ (ExpCon pos2 op2: es) -> check Con pos2 op2
    _ -> unitS0
  where
    check kind pos2 op2 =
      fixTid kind op2 >>>= \(fix2,pri2) ->
      if pri2 < pri1 then
        error ("Fixity problem:\n  "
              ++show op1++" used at "++strPos pos1++" has precedence "
              ++show pri1++",\n  "
              ++show op2++" used at "++strPos pos2++" has precedence "
              ++show pri2++".\n  "
              ++"The partially applied operator "++show op1
              ++" should have lower precedence\n  "
              ++"than the fully-applied operator "
              ++show op2++" used inside the section.\n")
      else unitS0

{- --------------------------------------------------------------------------}