imports{

import Helium.Syntax.UHA_Utils
import Helium.Syntax.UHA_Syntax 
import Helium.Syntax.UHA_Range
import Helium.Parser.OperatorTable
import Helium.Utils.Utils
import Helium.StaticAnalysis.Messages.Messages

import qualified Data.Map as M
}

INCLUDE "UHA_Syntax.ag"

{

data ResolveError = 
    Ambiguous Assoc Name Assoc Name

instance HasMessage ResolveError where
    getRanges (Ambiguous _ n1 _ n2) = 
        [ getNameRange n1, getNameRange n2 ]
    
    getMessage (Ambiguous assoc1 op1 assoc2 op2) = 
        let 
            assocString AssocRight = "right-associative"
            assocString AssocLeft  = "left-associative"
            assocString AssocNone  = "non-associative"

            firstLine =
                    "Ambiguous use of "
                ++  assocString (assoc1)
                ++  " operator "
                ++  show op1
            secondLine = 
                    " with "
                ++  assocString (assoc2)
                ++  " operator "
                ++  show op2
        in [ MessageOneLiner ( MessageString $ firstLine ++ secondLine ) ]
        
resolveOperators :: OperatorTable -> Module -> (Module, [ResolveError])
resolveOperators opTable m = 
    let res = wrap_Module (sem_Module m) (Inh_Module { opTable_Inh_Module = opTable, resolveErrors_Inh_Module = [] })
    in (self_Syn_Module res, resolveErrors_Syn_Module res)

expression :: OperatorTable -> Expression -> Expression    
expression opTable e = -- !!! errors ignored
    let res = wrap_Expression (sem_Expression e) (Inh_Expression { opTable_Inh_Expression = opTable, resolveErrors_Inh_Expression = [] })
    in self_Syn_Expression res

operatorsFromModule :: Module -> OperatorTable
operatorsFromModule m =
    M.fromList (concatMap declToOps (collectInfixdecls m))
  where
    declToOps (Declaration_Fixity _ f (MaybeInt_Just p) os) = 
        [ (o, (p, fixityToAssoc f)) | o <- os ]
    declToOps _ = error "not supported"    
    fixityToAssoc f = case f of
        Fixity_Infixl _ -> AssocLeft
        Fixity_Infixr _ -> AssocRight
        Fixity_Infix  _ -> AssocNone

collectInfixdecls :: Module -> [Declaration]
collectInfixdecls 
    (Module_Module _ _ _ (Body_Body _ _ ds)) = filter isInfixdecl ds
    where
        isInfixdecl (Declaration_Fixity _ _ _ _) = True
        isInfixdecl _ = False
collectInfixdecls (Module_Module _ _ _ (Body_Hole _ _)) = error "not supported"        
}

ATTR Module Body Declarations Declaration FunctionBindings RightHandSide
     FunctionBinding LeftHandSide MaybeDeclarations GuardedExpressions
     GuardedExpression Expression Patterns Pattern Alternatives Alternative
     Qualifiers Qualifier Statements Statement MaybeExpression Expressions
     RecordExpressionBinding RecordPatternBinding RecordPatternBindings
     RecordExpressionBindings
    [ opTable : OperatorTable 
    | resolveErrors : { [ResolveError] } 
    | 
    ]                

SEM Pattern 
    | List lhs.resolveErrors = @errs ++ @patterns.resolveErrors
           loc . (self, errs) = 
                    case @range.self of
                        Range_Range Position_Unknown Position_Unknown -> 
                            resolvePattern @lhs.opTable @patterns.self
                        _ -> 
                            (Pattern_List @range.self @patterns.self, [])
           
SEM Expression
    | List lhs . resolveErrors = @errs ++ @expressions.resolveErrors
           loc . (self, errs) = 
                    case @range.self of
                        Range_Range Position_Unknown Position_Unknown -> 
                            resolveExpression @lhs.opTable @expressions.self
                        _ -> (Expression_List @range.self @expressions.self, [])
            
{            
type State expr = 
    ( [Name] -- operator stack
    , [expr] -- expression/pattern stack
    , [ResolveError]
    )

resolveExpression :: OperatorTable -> [Expression] -> (Expression, [ResolveError])
resolveExpression opTable es = resolve opTable es (getOp, applyMinus, applyBinary) ([], [], []) 
  where
    getOp (Expression_Variable (Range_Range Position_Unknown Position_Unknown) n) = Just n
    getOp (Expression_Constructor (Range_Range Position_Unknown Position_Unknown) n) = Just n
    getOp _ = Nothing
    
    applyMinus :: Name -> Expression -> Expression
    applyMinus n e
        | n == intUnaryMinusName =
            Expression_Negate      (mergeRanges (getNameRange n) (getExprRange e)) e
        | n == floatUnaryMinusName = 
            Expression_NegateFloat (mergeRanges (getNameRange n) (getExprRange e)) e
        | otherwise = internalError 
            "ResolveOperators.hs" "resolveExpression.applyMinus" "unknown unary operator"        
            
    applyBinary :: Name -> Expression -> Expression -> Expression
    applyBinary n e1 e2 =
        Expression_InfixApplication 
            (mergeRanges (getExprRange e1) (getExprRange e2)) 
            (MaybeExpression_Just e1) 
            ((if isConstructor n then Expression_Constructor else Expression_Variable) (getNameRange n) n)
            (MaybeExpression_Just e2)
        
resolvePattern :: OperatorTable -> [Pattern] -> (Pattern, [ResolveError])
resolvePattern opTable ps = resolve opTable ps (getOp, applyMinus, applyBinary) ([], [], []) 
  where
    getOp (Pattern_Variable (Range_Range Position_Unknown Position_Unknown) n) = Just n
    getOp _ = Nothing
    
    applyMinus :: Name -> Pattern -> Pattern
    applyMinus n (Pattern_Literal r l) 
        | n == intUnaryMinusName =
            Pattern_Negate (mergeRanges (getNameRange n) r) l
        | n == floatUnaryMinusName = 
            Pattern_NegateFloat (mergeRanges (getNameRange n) r) l            
        | otherwise = internalError 
                "ResolveOperators.hs" "resolvePattern.applyMinus" "unknown unary operator"        
    applyMinus _ _ =
        internalError "ResolveOperators" "resolvePattern" "in patterns unary minus is only allowed in front of literals"         
        
    applyBinary :: Name -> Pattern -> Pattern -> Pattern
    applyBinary n p1 p2 =
        Pattern_InfixConstructor 
            (mergeRanges (getPatRange p1) (getPatRange p2)) 
            p1 n p2

resolve :: 
    OperatorTable -> 
    [expr] -> 
    ( expr -> Maybe Name -- get operator name (if it is one)
    , Name -> expr -> expr -- apply minus
    , Name -> expr -> expr -> expr -- apply binary
    ) 
    -> State expr -> (expr, [ResolveError])
resolve opTable exprs fs@(getOp, applyMinus, applyBinary) state = 
    case exprs of 
        [] -> cleanup state
        (expr:restExprs) ->
            let newState = 
                    case getOp expr of
                        Nothing   -> pushExpr expr state
                        Just name -> pushOp opTable name state
            in
                resolve opTable restExprs fs newState
  where
--    popOp :: State expr -> State expr
    popOp (op:ops, restExprs, errs) 
        | isUnary op =
            case restExprs of
                (expr:rest) -> (ops, applyMinus op expr : rest, errs)
                _ -> internalError "ResolveOperators" "popOp" "1"
        | otherwise =
            case restExprs of
                (expr2:expr1:rest) -> (ops, applyBinary op expr1 expr2 : rest, errs)
                _ -> internalError "ResolveOperators" "popOp" "2"
    popOp _ = error "pattern match failure in Parser.ResolveOperators.popOp"            
--    pushOp :: Name -> State expr -> State expr
    pushOp operTable op theState@(top:ops, restExprs, errs) =
        case strongerOp operTable top op of
            Left True -> pushOp operTable op (popOp theState)
            Left False -> (op:top:ops, restExprs, errs)
            Right err -> (op:top:ops, restExprs, err : errs) -- arbitrary choice
    pushOp _ op ([], restExprs, errs) =
        ([op], restExprs, errs)
--    cleanup :: State expr -> expr
    cleanup theState@(_:_, _, _)       = cleanup (popOp theState)
    cleanup (_, [expr], errs) = (expr, errs)
    cleanup _ = internalError "ResolveOperators" "cleanup" "invalid state"
    

pushExpr :: expr -> State expr -> State expr
pushExpr expr (ops, exprs, errs) =
    (ops, expr:exprs, errs)
                
strongerOp :: OperatorTable -> Name -> Name -> Either Bool ResolveError
strongerOp opTable op1 op2
    | isBinary op1 && isBinary op2 =
        if prio1 == prio2 then
            if assoc1 == AssocLeft && assoc2 == AssocLeft then
                Left True
            else if assoc1 == AssocRight && assoc2 == AssocRight then
                Left False
            else
                Right (Ambiguous assoc1 op1 assoc2 op2)
        else
            Left (prio1 > prio2)
    | isUnary  op1 && isBinary op2 = 
        Left (prio1 >= prio2)
    | isUnary  op2 = 
        Left False
    | otherwise = internalError "ResolveOperators" "strongerOp" "unable to determine which operator binds stronger"
  where
    assoc1 = assoc opTable op1
    assoc2 = assoc opTable op2
    prio1 = prio opTable op1
    prio2 = prio opTable op2

isUnary :: Name -> Bool
isUnary name = name `elem` [ intUnaryMinusName, floatUnaryMinusName ]

isBinary :: Name -> Bool
isBinary = not . isUnary

}