+ Arrow notation
+%* *
+%************************************************************************
+
+\begin{code}
+rnExpr (HsProc pat body src_loc)
+ = addSrcLoc src_loc $
+ rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
+ rnCmdTop body `thenM` \ (body',fvBody) ->
+ returnM (HsProc pat' body' src_loc, fvBody)
+
+rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
+ = rnExpr arrow `thenM` \ (arrow',fvArrow) ->
+ rnExpr arg `thenM` \ (arg',fvArg) ->
+ returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
+ fvArrow `plusFV` fvArg)
+
+-- infix form
+rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
+ = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) ->
+ rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
+ rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
+
+ -- Deal with fixity
+
+ lookupFixityRn op_name `thenM` \ fixity ->
+ mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
+
+ returnM (final_e,
+ fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
+
+rnExpr (HsArrForm op fixity cmds srcloc)
+ = rnExpr op `thenM` \ (op',fvOp) ->
+ rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
+ returnM (HsArrForm op' fixity cmds' srcloc,
+ fvOp `plusFV` fvCmds)
+
+---------------------------
+-- Deal with fixity (cf mkOpAppRn for the method)
+
+mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged
+ -> RenamedHsExpr -> Fixity -- Operator and fixity
+ -> RenamedHsCmdTop -- Right operand (not an infix)
+ -> RnM RenamedHsCmd
+
+---------------------------
+-- (e11 `op1` e12) `op2` e2
+mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
+ | nofix_error
+ = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
+
+ | associate_right
+ = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
+ returnM (HsArrForm op1 (Just fix1)
+ [a11, HsCmdTop new_c [] placeHolderType []] loc1)
+ where
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+
+---------------------------
+-- Default case
+mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
+ = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Arrow commands
+%* *
+%************************************************************************
+
+\begin{code}
+rnCmdArgs [] = returnM ([], emptyFVs)
+rnCmdArgs (arg:args)
+ = rnCmdTop arg `thenM` \ (arg',fvArg) ->
+ rnCmdArgs args `thenM` \ (args',fvArgs) ->
+ returnM (arg':args', fvArg `plusFV` fvArgs)
+
+rnCmdTop (HsCmdTop cmd _ _ _)
+ = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) ->
+ let
+ cmd_names = [arrAName, composeAName, firstAName] ++
+ nameSetToList (methodNamesCmd cmd')
+ in
+ -- Generate the rebindable syntax for the monad
+ lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
+
+ returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
+ fvCmd `plusFV` cmd_fvs)
+
+---------------------------------------------------
+-- convert OpApp's in a command context to HsArrForm's
+
+convertOpFormsCmd :: HsCmd id -> HsCmd id
+
+convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
+
+convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
+
+convertOpFormsCmd (OpApp c1 op fixity c2)
+ = let
+ arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
+ arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
+ in
+ HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
+
+convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
+
+convertOpFormsCmd (HsCase exp matches locn)
+ = HsCase exp (map convertOpFormsMatch matches) locn
+
+convertOpFormsCmd (HsIf exp c1 c2 locn)
+ = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
+
+convertOpFormsCmd (HsLet binds cmd)
+ = HsLet binds (convertOpFormsCmd cmd)
+
+convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
+ = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
+
+-- Anything else is unchanged. This includes HsArrForm (already done),
+-- things with no sub-commands, and illegal commands (which will be
+-- caught by the type checker)
+convertOpFormsCmd c = c
+
+convertOpFormsStmt (BindStmt pat cmd locn)
+ = BindStmt pat (convertOpFormsCmd cmd) locn
+convertOpFormsStmt (ResultStmt cmd locn)
+ = ResultStmt (convertOpFormsCmd cmd) locn
+convertOpFormsStmt (ExprStmt cmd ty locn)
+ = ExprStmt (convertOpFormsCmd cmd) ty locn
+convertOpFormsStmt (RecStmt stmts lvs rvs es)
+ = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
+convertOpFormsStmt stmt = stmt
+
+convertOpFormsMatch (Match pat mty grhss)
+ = Match pat mty (convertOpFormsGRHSs grhss)
+
+convertOpFormsGRHSs (GRHSs grhss binds ty)
+ = GRHSs (map convertOpFormsGRHS grhss) binds ty
+
+convertOpFormsGRHS (GRHS stmts locn)
+ = let
+ (ResultStmt cmd locn') = last stmts
+ in
+ GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
+
+---------------------------------------------------
+type CmdNeeds = FreeVars -- Only inhabitants are
+ -- appAName, choiceAName, loopAName
+
+-- find what methods the Cmd needs (loop, choice, apply)
+methodNamesCmd :: HsCmd Name -> CmdNeeds
+
+methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
+ = emptyFVs
+methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
+ = unitFV appAName
+methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
+
+methodNamesCmd (HsPar c) = methodNamesCmd c
+
+methodNamesCmd (HsIf p c1 c2 loc)
+ = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
+
+methodNamesCmd (HsLet b c) = methodNamesCmd c
+
+methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
+
+methodNamesCmd (HsApp c e) = methodNamesCmd c
+
+methodNamesCmd (HsLam match) = methodNamesMatch match
+
+methodNamesCmd (HsCase scrut matches loc)
+ = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
+
+methodNamesCmd other = emptyFVs
+ -- Other forms can't occur in commands, but it's not convenient
+ -- to error here so we just do what's convenient.
+ -- The type checker will complain later
+
+---------------------------------------------------
+methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
+
+-------------------------------------------------
+methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
+
+-------------------------------------------------
+methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
+
+---------------------------------------------------
+methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
+
+---------------------------------------------------
+methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
+methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
+methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
+methodNamesStmt (RecStmt stmts lvs rvs es)
+ = methodNamesStmts stmts `addOneFV` loopAName
+methodNamesStmt (LetStmt b) = emptyFVs
+methodNamesStmt (ParStmt ss) = emptyFVs
+ -- ParStmt can't occur in commands, but it's not convenient to error
+ -- here so we just do what's convenient
+\end{code}
+
+
+%************************************************************************
+%* *