helium-1.8: src/Helium/Parser/ResolveOperators.ag
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
}