%include doc/lhs2TeX.fmt

% Change History:
% 2000.07.04  Deal with nested declarations and qualified operators
% 2000.06.30 
% 2000.06.29  Released in the public domain by Tommy Thorn

\section{Fixing the operator precedence}

The Happy Haskell Parser parses all operators as if they had the same
precedence (as it should). The purpose of this module is to rewrite
the parse tree such that the operator bind according to their
precedence.

This pass would be simpler if preceeded by an alpha renaming phase.

WARNING: This is not well tested.

WARNING: doesn't yet deal with implicit fixity declarations, such as
this example:

< qrt = 12 - 7 + 5  -- qrt is 0, not 10
<   where
<   a - b = a Prelude.- b  -- Notice that - is implicitly infixl 9

WARNING: doesn't yet report error with incorrect use of
non-associative operators, such as:

< gakgak a b c = a == b == c



> module OperatorFix(operatorFixup, preludeOperators) where
> import HsSyn
> import List((\\),nub)

> type InfixDecl = (HsName, (Int, HsAssoc))

> operatorFixup :: [InfixDecl] -> HsModule -> HsModule
> operatorFixup operators (mod,exports,decls) =
>   (mod, exports, ofDecls operators' decls)

The top level declarations are special in that some of them may be
exported, and thus be referenced fully qualified.  Presently we do not
take export declaration into consideration but just assume that
everything is exported.

>   where
>   operators' = [ (Qual mod op, ifx)
>                | (UnQual op, ifx) <- collectInfixDecls decls
>                ] ++ operators


> ofDecls :: [InfixDecl] -> [HsDecl] -> [HsDecl]
> ofDecls operators decls = map (ofDecl operators') decls
>   where
>   operators' = collectInfixDecls decls ++ operators

The following function scans a list of |HsDecl|s for infix
declarations and returns them.

> collectInfixDecls :: [HsDecl] -> [InfixDecl]
> collectInfixDecls decls = infixdecls''
>   where
>   infixdecls  = [(ass,precOpt,ops) | HsInfixDecl sl ass precOpt ops <- decls]
>   infixdecls' = [ (op,(prec,ass))
>                 | (ass,precOpt,ops) <- infixdecls,
>                   let prec = maybe 9 id precOpt,
>                   op <- ops
>                 ]
>   allOps      = map fst infixdecls'
>   infixdecls'' = case allOps \\ nub allOps of
>                    []   -> infixdecls'
>                    dubs -> error $ show dubs ++ " dubly defined"


> ofDecl :: [InfixDecl] -> HsDecl -> HsDecl
> ofDecl operators decl = case decl of
>   HsValBind pos e rhs declsOpt -> HsValBind pos e' rhs' decls'
>      where
>      e'     = ofExp e
>      rhs'   = ofRhs rhs
>      decls' = fmap (ofDecls operators) declsOpt
>   somethingelse                -> somethingelse

>   where
>   ofRhs :: HsRhs -> HsRhs
>   ofRhs (HsUnGuardedRhs e)   = HsUnGuardedRhs (ofExp e)
>   ofRhs (HsGuardedRhss gRhs) = HsGuardedRhss (map ofGuardedRhs gRhs)

>   ofGuardedRhs :: HsGuardedRhs -> HsGuardedRhs
>   ofGuardedRhs (HsGuardedRhs pos a b) = HsGuardedRhs pos (ofExp a) (ofExp b)

>   ofStmt :: HsStmt -> HsStmt
>   ofStmt (HsGenerator e1 e2) = HsGenerator (ofExp e1) (ofExp e2)
>   ofStmt (HsQualifier e)     = HsQualifier (ofExp e)
>   ofStmt (HsLetStmt decls)   = HsLetStmt (ofDecls operators decls)

>   ofFieldUpdate :: HsFieldUpdate -> HsFieldUpdate
>   ofFieldUpdate (HsFieldUpdate name e) = HsFieldUpdate name (ofExp e)
>   ofFieldUpdate fu                     = fu

>   ofAlt :: HsAlt -> HsAlt
>   ofAlt (HsAlt pos e gAlts) = HsAlt pos (ofExp e) (ofGuardedAlts gAlts)
>   ofAlt (HsAltWhere pos e gAlts decls) =
>     HsAltWhere pos (ofExp e) (ofGuardedAlts gAlts) (ofDecls operators decls)

>   ofGuardedAlts :: HsGuardedAlts -> HsGuardedAlts
>   ofGuardedAlts (HsUnGuardedAlt e)    = HsUnGuardedAlt (ofExp e)
>   ofGuardedAlts (HsGuardedAlts gAlts) = HsGuardedAlts (map ofGuardedAlt gAlts)

>   ofGuardedAlt :: HsGuardedAlt -> HsGuardedAlt
>   ofGuardedAlt (HsGuardedAlt pos a b) = HsGuardedAlt pos (ofExp a) (ofExp b)

>   ofExp :: HsExp -> HsExp
>   ofExp e = case e of
>     HsInfixApp a op b         -> ofInfixApp e
>     HsApp e1 e2               -> HsApp (ofExp e1) (ofExp e2)
>     HsLambda xs e             -> HsLambda xs (ofExp e)
>     HsLet decls e             -> HsLet (ofDecls operators decls) (ofExp e)
>     HsIf e1 e2 e3             -> HsIf (ofExp e1) (ofExp e2) (ofExp e3)
>     HsCase e alts             -> HsCase (ofExp e) (map ofAlt alts)
>     HsDo stmts                -> HsDo (map ofStmt stmts)
>     HsTuple es                -> HsTuple (map ofExp es)
>     HsParen e                 -> HsParen (ofExp e)
>     HsLeftSection e op        -> HsLeftSection  (ofExp e) (ofExp op)
>     HsRightSection op e       -> HsRightSection (ofExp op) (ofExp e)
>     HsRecUpdate e fups        -> HsRecUpdate (ofExp e) (map ofFieldUpdate fups)
>     HsAsPat name e            -> HsAsPat name (ofExp e)
>     HsIrrPat e                -> HsIrrPat (ofExp e)
>     HsList es                 -> HsList (map ofExp es)
>     HsEnumFrom e              -> HsEnumFrom (ofExp e)
>     HsEnumFromTo e1 e2        -> HsEnumFromTo (ofExp e1) (ofExp e2)
>     HsEnumFromThen e1 e2      -> HsEnumFromThen (ofExp e1) (ofExp e2)
>     HsEnumFromThenTo e1 e2 e3 -> HsEnumFromThenTo (ofExp e1)
>                                                   (ofExp e2)
>                                                   (ofExp e3)
>     HsListComp e stmts        -> HsListComp (ofExp e) (map ofStmt stmts)
>     HsExpTypeSig pos e qtype  -> HsExpTypeSig pos (ofExp e) qtype
>     other                     -> other

\subsection{The meat of the matter.}

What is important to know is that the parser returns the parse tree
exactly as it sees it with all operators on an equal footing.
Examples:
\begin{itemize}
\item |(- a)| $\longrightarrow$ |HsParen (HsApp (HsVar -) (HsVar a))|
\item |(* a)| $\longrightarrow$ |HsRightSection (HsVar a) (HsVar *)|
\item |a*b-c*d| $\longrightarrow$
<   HsInfixApp (HsInfixApp (HsInfixApp (HsVar a)
<                                      (HsVar *)
<                                      (HsVar b))
<                          (HsVar -)
<                          (HsVar c))
<              (HsVar *)
<              (HsVar d)
\item |a-b-c| $\longrightarrow$
<   HsInfixApp (HsInfixApp (HsVar a) 
<                          (HsVar -)
<                          (HsVar b))
<              (HsVar -)
<              (HsVar c)
\item |a^b^c| $\longrightarrow$
<   HsInfixApp (HsInfixApp (HsVar a)
<                          (HsVar ^)
<                          (HsVar b))
<              (HsVar ^)
<              (HsVar c)
\end{itemize}

FIXME: This isn't correct for non-associtive operators where we should
catch errors, but I'm await clarifications as to the intended
semantics of non-associativity.

>   ofInfixApp :: HsExp -> HsExp
>   ofInfixApp (HsInfixApp e@(HsInfixApp a op1 b) op2 c) =
>     -- (a `op1` b) `op2` c
>     if op1 `needsReorder` op2 then
>        ofInfixApp (HsInfixApp a op1 (HsInfixApp b op2 c))
>     else
>        HsInfixApp (ofInfixApp e) op2 (ofExp c)
>   ofInfixApp (HsInfixApp a op b) = HsInfixApp (ofExp a) (ofExp op) (ofExp b) 
>   ofInfixApp e                   = (ofExp e) 


>   op1 `needsReorder` op2 = prec False op1 < prec True op2

>   prec rightSide (HsVar op) = case  op `lookup` operators of
>     Just (n, HsAssocLeft)  -> n
>     Just (n, HsAssocNone)  -> n+1
>     Just (n, HsAssocRight) | rightSide -> n+1
>                            | otherwise -> n
>     Nothing                -> error $ "operator "++show op++"is unknown"

The operators should be collected from the imported modules, but here
is an example of what might be defined by the Prelude.

> preludeOperators :: [InfixDecl]
> preludeOperators = mapFst UnQual ops ++ mapFst (Qual "Prelude") ops
>   where ops = [("!!",   (9, HsAssocLeft))
>               ,(".",    (9, HsAssocRight))
>   
>               ,("^",    (8, HsAssocRight))
>               ,("^^",   (8, HsAssocRight))
>               ,("**",   (8, HsAssocRight))
>               
>               ,("*",    (7, HsAssocLeft))
>               ,("/",    (7, HsAssocLeft))
>               ,("div",  (7, HsAssocLeft))
>               ,("mod",  (7, HsAssocLeft))
>               ,("rem",  (7, HsAssocLeft))
>               ,("qout", (7, HsAssocLeft))
>               
>               ,("+",    (6, HsAssocLeft))
>               ,("-",    (6, HsAssocLeft))
>   
>               ,("\\",   (5, HsAssocNone))
>               ,(":",    (5, HsAssocRight))
>               ,("++",   (5, HsAssocRight))
>   
>               ,("==",   (4, HsAssocNone))
>               ,("/=",   (4, HsAssocNone))
>               ,("<",    (4, HsAssocNone))
>               ,("<=",   (4, HsAssocNone))
>               ,(">",    (4, HsAssocNone))
>               ,(">=",   (4, HsAssocNone))
>               ,("elem", (4, HsAssocNone))
>               ,("notElem", (4, HsAssocNone))
>   
>               ,("&&",   (3, HsAssocRight))
>               ,("||",   (2, HsAssocRight))
>   
>               ,(">>",   (1, HsAssocRight))
>               ,(">>=",  (1, HsAssocRight))
>               
>               ,("$",    (0, HsAssocRight))
>               ,("seq",  (0, HsAssocRight))
>               ]
>         mapFst f = map (\(a,b) -> (f a, b))