+ Arrow notation
+%* *
+%************************************************************************
+
+\begin{code}
+rnExpr (HsProc pat body)
+ = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
+ rnCmdTop body `thenM` \ (body',fvBody) ->
+ returnM (HsProc pat' body', fvBody)
+
+rnExpr (HsArrApp arrow arg _ ho rtl)
+ = rnLExpr arrow `thenM` \ (arrow',fvArrow) ->
+ rnLExpr arg `thenM` \ (arg',fvArg) ->
+ returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
+ fvArrow `plusFV` fvArg)
+
+-- infix form
+rnExpr (HsArrForm op (Just _) [arg1, arg2])
+ = 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)
+ = rnLExpr op `thenM` \ (op',fvOp) ->
+ rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
+ returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
+
+---------------------------
+-- Deal with fixity (cf mkOpAppRn for the method)
+
+mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
+ -> LHsExpr Name -> Fixity -- Operator and fixity
+ -> LHsCmdTop Name -- Right operand (not an infix)
+ -> RnM (HsCmd Name)
+
+---------------------------
+-- (e11 `op1` e12) `op2` e2
+mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
+ op2 fix2 a2
+ | nofix_error
+ = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (HsArrForm op2 (Just fix2) [a1, a2])
+
+ | associate_right
+ = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
+ returnM (HsArrForm op1 (Just fix1)
+ [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
+ -- TODO: locs are wrong
+ 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])
+
+\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
+ 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
+
+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)
+
+convertOpFormsCmd (HsCase exp matches)
+ = HsCase exp (map 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 ids ty)
+ = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ids 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)
+convertOpFormsStmt (ResultStmt cmd)
+ = ResultStmt (convertOpFormsLCmd cmd)
+convertOpFormsStmt (ExprStmt cmd ty)
+ = ExprStmt (convertOpFormsLCmd cmd) ty
+convertOpFormsStmt (RecStmt stmts lvs rvs es)
+ = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
+convertOpFormsStmt stmt = stmt
+
+convertOpFormsMatch = fmap convert
+ where convert (Match pat mty grhss)
+ = Match pat mty (convertOpFormsGRHSs grhss)
+
+convertOpFormsGRHSs (GRHSs grhss binds ty)
+ = GRHSs (map convertOpFormsGRHS grhss) binds ty
+
+convertOpFormsGRHS = fmap convert
+ where convert (GRHS stmts)
+ = let
+ (L loc (ResultStmt cmd)) = last stmts
+ in
+ GRHS (init stmts ++ [L loc (ResultStmt (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 rbs ty) = methodNamesStmts stmts
+
+methodNamesCmd (HsApp c e) = methodNamesLCmd c
+
+methodNamesCmd (HsLam match) = methodNamesMatch match
+
+methodNamesCmd (HsCase scrut matches)
+ = 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 (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
+
+-------------------------------------------------
+methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
+
+-------------------------------------------------
+methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
+
+---------------------------------------------------
+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
+
+---------------------------------------------------
+methodNamesLStmt = methodNamesStmt . unLoc
+
+methodNamesStmt (ResultStmt cmd) = methodNamesLCmd cmd
+methodNamesStmt (ExprStmt cmd ty) = methodNamesLCmd cmd
+methodNamesStmt (BindStmt pat cmd ) = methodNamesLCmd 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}
+
+
+%************************************************************************
+%* *