+ Arrow notation
+%* *
+%************************************************************************
+
+\begin{code}
+rnExpr (HsProc pat body)
+ = newArrowScope $
+ rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
+ rnCmdTop body `thenM` \ (body',fvBody) ->
+ returnM (HsProc pat' body', fvBody)
+
+rnExpr (HsArrApp arrow arg _ ho rtl)
+ = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
+ rnLExpr arg `thenM` \ (arg',fvArg) ->
+ returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
+ fvArrow `plusFV` fvArg)
+ where
+ select_arrow_scope tc = case ho of
+ HsHigherOrderApp -> tc
+ HsFirstOrderApp -> escapeArrowScope tc
+
+-- infix form
+rnExpr (HsArrForm op (Just _) [arg1, arg2])
+ = escapeArrowScope (rnLExpr op)
+ `thenM` \ (op'@(L _ (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)
+ = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
+ rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
+ returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
+
+rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
+ -- DictApp, DictLam, TyApp, TyLam
+\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 = wrapLocFstM rnCmdTop'
+ where
+ rnCmdTop' (HsCmdTop cmd _ _ _)
+ = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
+ let
+ cmd_names = [arrAName, composeAName, firstAName] ++
+ nameSetToList (methodNamesCmd (unLoc cmd'))
+ in
+ -- Generate the rebindable syntax for the monad
+ lookupSyntaxTable 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
+
+convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
+convertOpFormsLCmd = fmap convertOpFormsCmd
+
+convertOpFormsCmd :: HsCmd id -> HsCmd id
+
+convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
+convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
+convertOpFormsCmd (OpApp c1 op fixity c2)
+ = let
+ arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
+ arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
+ in
+ HsArrForm op (Just fixity) [arg1, arg2]
+
+convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
+
+-- gaw 2004
+convertOpFormsCmd (HsCase exp matches)
+ = HsCase exp (convertOpFormsMatch matches)
+
+convertOpFormsCmd (HsIf exp c1 c2)
+ = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
+
+convertOpFormsCmd (HsLet binds cmd)
+ = HsLet binds (convertOpFormsLCmd cmd)
+
+convertOpFormsCmd (HsDo ctxt stmts body ty)
+ = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
+ (convertOpFormsLCmd body) ty
+
+-- 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 _ _)
+ = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
+convertOpFormsStmt (ExprStmt cmd _ _)
+ = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
+convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
+ = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
+convertOpFormsStmt stmt = stmt
+
+convertOpFormsMatch (MatchGroup ms ty)
+ = MatchGroup (map (fmap convert) ms) ty
+ where convert (Match pat mty grhss)
+ = Match pat mty (convertOpFormsGRHSs grhss)
+
+convertOpFormsGRHSs (GRHSs grhss binds)
+ = GRHSs (map convertOpFormsGRHS grhss) binds
+
+convertOpFormsGRHS = fmap convert
+ where
+ convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
+
+---------------------------------------------------
+type CmdNeeds = FreeVars -- Only inhabitants are
+ -- appAName, choiceAName, loopAName
+
+-- find what methods the Cmd needs (loop, choice, apply)
+methodNamesLCmd :: LHsCmd Name -> CmdNeeds
+methodNamesLCmd = methodNamesCmd . unLoc
+
+methodNamesCmd :: HsCmd Name -> CmdNeeds
+
+methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
+ = emptyFVs
+methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
+ = unitFV appAName
+methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
+
+methodNamesCmd (HsPar c) = methodNamesLCmd c
+
+methodNamesCmd (HsIf p c1 c2)
+ = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
+
+methodNamesCmd (HsLet b c) = methodNamesLCmd c
+
+methodNamesCmd (HsDo sc stmts body ty)
+ = methodNamesStmts stmts `plusFV` methodNamesLCmd body
+
+methodNamesCmd (HsApp c e) = methodNamesLCmd c
+
+methodNamesCmd (HsLam match) = methodNamesMatch match
+
+methodNamesCmd (HsCase scrut matches)
+ = 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 (MatchGroup ms ty)
+ = plusFVs (map do_one ms)
+ where
+ do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
+
+-------------------------------------------------
+-- gaw 2004
+methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
+
+-------------------------------------------------
+methodNamesGRHS (L _ (GRHS stmts rhs)) = methodNamesLCmd rhs
+
+---------------------------------------------------
+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
+
+---------------------------------------------------
+methodNamesLStmt = methodNamesStmt . unLoc
+
+methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (BindStmt pat cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (RecStmt stmts _ _ _ _)
+ = 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}
+
+
+%************************************************************************
+%* *