hat-2.7.0.0: trans/AuxFixity.hs
{- ---------------------------------------------------------------------------
Restructure expressions with infix operators according to associativity
and precedence. This variant of the infix resolution code is only
used when performing the tracing transformation. When doing ordinary
compilation, resolving infix expressions is part of the Rename phase.
-}
module AuxFixity(fixInfixList) where
import SysDeps(PackedString,packString,unpackPS)
import Extra(Pos(..),noPos,strPos,pair)
import Syntax
import SyntaxPos
import TokenId(TokenId(..), t_x, t_y, t_flip, t_minus, tnegate, visImport)
import AssocTree
--import PreImp
import AuxTypes
import MkSyntax(mkAppExp)
{-
-- Main function of the module.
-}
fixInfixList :: Environment -> [Exp TokenId] -> Exp TokenId
fixInfixList env [] = error "I: fixInfix []"
fixInfixList env ees@(ExpVarOp pos op:es) =
let fix = lookupFix env op
exp' = reorder env es
exp = invertCheck pos op fix env exp'
--in ExpLambda pos [varx,vary]
-- (ExpApplication pos [ExpVar pos op,vary,varx])
-- where
-- varx = ExpVar pos t_x
-- vary = ExpVar pos t_y
in if op == t_minus
then reorder env ees
else (mkAppExp [ExpVar noPos t_flip, ExpVar pos op, exp])
-- desugaring with flip better than lambda for reading a trace
fixInfixList env ees@(ExpConOp pos op:es) =
let fix = lookupFix env op
in case fix of
(Pre a,l) -> reorder env ees
_ -> let exp' = reorder env es
exp = invertCheck pos op fix env exp'
-- in ExpLambda pos [varx,vary]
-- (ExpApplication pos [ExpVar pos op,vary,varx])
-- where
-- varx = ExpVar pos t_x
-- vary = ExpVar pos t_y
in mkAppExp [ExpVar noPos t_flip, ExpCon pos op, exp]
-- desugaring with flip better than lambda for reading a trace
fixInfixList env ees =
case last ees of
ExpConOp pos op -> let fix = lookupFix env op
exp' = reorder env (init ees)
exp = invertCheck pos op fix env exp'
in (mkAppExp [ExpCon pos op,exp])
ExpVarOp pos op -> let fix = lookupFix env op
exp' = reorder env (init ees)
exp = invertCheck pos op fix env exp'
in (mkAppExp [ExpVar pos op,exp])
_ -> reorder env ees
-- the primary function that re-orders an infix list into a single expression
reorder :: Environment -> [Exp TokenId] -> Exp TokenId
reorder env es = getExp env [] [] es
-- getExp and getOp together `parse' the list of expressions into a
-- single tree-shaped expression. We expect the list to take the form
-- [exp,op,exp,op,exp,op...] i.e. exps and ops alternate. Of course,
-- there are exceptions: where the whole expr is a left or right section
-- of an operator; and where a prefix operator starts the show.
getExp :: Environment -- environment (contains fixity info)
-> [((Fixity,Int),(Exp TokenId,Int))] -- stack of operators already seen
-> [Exp TokenId] -- stack of outstanding non-op exprs
-> [Exp TokenId] -- input list of exprs
-> Exp TokenId -- re-combined output
getExp env ops exps (e:es) =
case e of
ExpConOp pos o ->
let fix = lookupFix env o in
case fix of
(Pre a,l) -> getExp env (stackPrefix fix (ExpCon pos o):ops) exps es
ExpVarOp pos o ->
let fix = lookupFix env o in
case fix of
(Pre a,l) -> getExp env (stackPrefix fix (ExpVar pos o):ops) exps es
_ | o==t_minus
-> getExp env (stackPrefix (Pre "negate",6) (ExpVar pos o):ops) exps es
_ -> getOp env ops (e:exps) es
getExp env ops [] [] =
error ("Problem with infix section at unknown location.")
getExp env ops (e:es) [] =
error ("Problem with infix section at "++strPos (getPos e))
getOp :: Environment -- environment (contains fixity info)
-> [((Fixity,Int),(Exp TokenId,Int))] -- stack of operators
-> [Exp TokenId] -- stack of outstanding non-op exprs
-> [Exp TokenId] -- input list of exprs
-> Exp TokenId -- recombined output
getOp env ops exps [] = finish ops exps
getOp env ops exps ees@(ExpConOp pos op:es) =
case harder pos ops op env of
Just (o,ops) -> getOp env ops (rebuild o exps) ees
Nothing -> let fop = stackInfix env (ExpCon pos op)
in getExp env (fop:ops) exps es
getOp env ops exps ees@(ExpVarOp pos op:es) =
case harder pos ops op env of
Just (o,ops) -> getOp env ops (rebuild o exps) ees
Nothing -> let fop = stackInfix env (ExpVar pos op)
in getExp env (fop:ops) exps es
getOp env ops exps (e:es) =
error ("Need infix operator at " ++ strPos (getPos e))
stackInfix :: Environment -> Exp TokenId -> ((Fixity,Int),(Exp TokenId,Int))
stackInfix env op@(ExpVar _ o) = (lookupFix env o, (op,2::Int))
stackInfix env op@(ExpCon _ o) = (lookupFix env o, (op,2::Int))
stackPrefix fix op = (fix,(op,1::Int))
-- harder decides whether a new operator has lower precedence than
-- the top of the operator stack. If so, we can pop the stack and
-- rebuild the accumulated expression so far before continuing.
-- If however it has higher precedence, then we must push the new
-- operator onto the stack and keep going. If it has equal precedence,
-- then left/right associativity must be taken into account.
harder :: Pos -- position
-> [((Fixity,Int),(b,c))] -- stack of operators
-> TokenId -- operator name
-> Environment -- environment holding fixity info
-> Maybe (((Fixity,Int),(b,c)),[((Fixity,Int),(b,c))])
harder pos [] op' env = Nothing
harder pos (ipop@((inf,pri),(_,_)):ops) op' env =
let (inf',pri') = lookupFix env op' in
if pri > pri' then
Just (ipop,ops)
else if pri == pri' then
case inf of
Def -> Just (ipop,ops)
L -> Just (ipop,ops)
Pre _ -> Just (ipop,ops)
R -> Nothing
None -> error ("Infix operator "++show op'++" at "++strPos pos
++" is non-associative.")
else Nothing
-- finish transforms the two stacks (operators + exprs) into the final
-- recombined expression.
finish :: [((Fixity,c),(Exp TokenId,Int))] -- stack of operators
-> [Exp TokenId] -- stack of non-op exprs
-> Exp TokenId -- output expr
finish [] [] = error "AuxFixity.finish: empty"
finish [] [e] = e
finish [] _ = error "AuxFixity.finish: multiple expression"
finish (o:ops) es = finish ops (rebuild o es)
-- rebuild the expression stack, by combining the top two items with
-- the given operator. Precondition: the operator must have higher
-- precedence than any operators between the exprs lower in the stack.
rebuild :: ((Fixity,c),(Exp TokenId,Int)) -- operator
-> [Exp TokenId] -- stack of expressions
-> [Exp TokenId] -- juggled the stack
rebuild (_,(op,2)) (e1:e2:es) =
mkAppExp [op,e2,e1]:es
rebuild ((Pre fun,_) ,(op,_)) (e1:es) =
mkAppExp [ExpVar (getPos op) (visImport fun),e1]:es
rebuild (_,(op,n)) es =
error ("Not enough arguments at " ++ strPos (getPos op))
-- discover fixity information from the .hx file info.
lookupFix :: Environment -> TokenId -> (Fixity,Int)
lookupFix (env,identMap) op =
case lookupAT env (useIdentMap identMap op) of
Just info -> (fixity info, priority info)
Nothing -> error ("No auxinfo for operator "++show op)
leftFixity :: Fixity -> Bool
leftFixity L = True
leftFixity Def = True
leftFixity (Pre _) = True
leftFixity _ = False --- !!! Cheating Infix is InfixR (??)
-- 'invertCheck' checks for priority inversion in an operator section.
invertCheck :: Show a => Pos -> a -> (b,Int) -> Environment
-> Exp TokenId -> Exp TokenId
invertCheck pos1 op1 (fix1,pri1) env exp =
case exp of
ExpApplication _ (ExpVar pos2 op2: es) -> check pos2 op2
ExpApplication _ (ExpCon pos2 op2: es) -> check pos2 op2
_ -> exp
where
check pos2 op2 =
let (fix2,pri2) = lookupFix env op2
in 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 exp
{- --------------------------------------------------------------------------}