- rn_seq (From expr)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- returnRn (From expr', fvExpr)
-
- rn_seq (FromThen expr1 expr2)
- = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
-
- rn_seq (FromTo expr1 expr2)
- = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
-
- rn_seq (FromThenTo expr1 expr2 expr3)
- = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
- returnRn (FromThenTo expr1' expr2' expr3',
- unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
+ (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