ref: 7d146bd75d98bea509acfad35ee5515423892e47
dir: /src/MicroHs/Fixity.hs/
module MicroHs.Fixity(resolveFixity) where
import Prelude(); import MHSPrelude
import MicroHs.Expr
import MicroHs.Ident
-- Operators resolution
-- Input: A sequence of binary infix operators, prefix operators, and operands
-- b - infix op
-- p - prefix op
-- o - any op
-- e - operand
-- Three inputs: stack of operand, stack of operators, input sequence
-- [e ] [ ] [ ]
-- -> done
-- [e2, e1, ...] [by, ...] [bx, ...]
-- -> ambig, if prec bx == prec by && (assoc bx /= assoc by || assoc bx == None)
-- -> [e1 `by` e2, ...] [ ...] [bx, ...], if prec bx < prec by || prec bx == prec by && assoc bx == Left
-- -> [e2, e1, ...] [bx, by, ...] [ ...], otherwise
-- [...] [] [bx, e, ...]
-- -> [e, ... ] [bx ] [ ...]
-- [...] [...] [e, ...]
-- -> [e, ... ] [ ...] [ ...]
--
--
-- [e2, e1, ...] [py, ...] [bx, ...]
-- -> error, if prec bx == prec py && assoc bx /= assoc py
-- -> [py e2, e1, ...] [... ] [bx, ...], if prec bx < prec py || prec bx == prec py
-- -> [ e2, e1, ...] [bx, py, ...] [ ...], otherwise
--
-- [e2, e1, ...] [by, ...] [px, ...]
-- -> error if prec px <= prec by
-- -> [ e2, e1, ...] [px, by, ...] [ ...], otherwise
-- [e2, e1, ...] [py, ...] [px, ...]
-- -> [ e2, e1, ...] [px, py, ...] [ ...], otherwise
data Fix = FixIn | FixPre
-- deriving (Show)
data FixInput = Rator Fix Expr Fixity | Rand Expr
-- deriving (Show)
eNeg :: SLoc -> Expr
eNeg loc = EVar (mkIdentSLoc loc "negate")
negFixity :: Fixity
negFixity = (AssocLeft, 6)
resolveFixity :: Expr -> [((Expr, Fixity), Expr)] -> Either (SLoc, String) Expr
resolveFixity ae oes =
let inps = expr ae ++ concatMap opexpr oes
expr (ENegApp e) = Rator FixPre (eNeg (getSLoc e)) negFixity : expr e
expr e = [Rand e]
opexpr ((f, fx), e) = Rator FixIn f fx : expr e
oper (Rator FixPre f _) (e:es) = EApp f e : es
oper (Rator FixIn f _) (e2:e1:es) = EApp (EApp f e1) e2 : es
oper _ _ = undefined
prec (Rator _ _ (_, p)) = p
prec _ = undefined
assoc (Rator _ _ (a, _)) = a
assoc _ = undefined
resolve [e] [] [] = Right e
resolve _ [] [] = undefined
resolve es [] (ox@(Rator _ _ _) : is) = resolve es [ox] is
resolve es (oy:os) [] = resolve (oper oy es) os []
resolve es aos ( Rand e : is) = resolve (e:es) aos is
resolve es aos@(oy:os) ais@(ox@(Rator FixIn func _) : is)
| prec ox == prec oy && (assoc ox /= assoc oy || assoc ox == AssocNone) =
Left (getSLoc func, "ambiguous operator expression")
| prec ox < prec oy || prec ox == prec oy && assoc oy == AssocLeft =
resolve (oper oy es) os ais
| otherwise =
resolve es (ox:aos) is
resolve es aos@(oy:_) (ox@(Rator FixPre func _) : is)
| prec ox <= prec oy =
Left (getSLoc func, "bad prefix expression")
| otherwise =
resolve es (ox:aos) is
in resolve [] [] inps