Monad.oz

%%% Monad.oz --- A synax that resembles Haskell's do notation for monads.
%% NB: The macros need to be evaluated before the examples can be run

declare Maybe Reader State Seq in

fun {Seq Monad A B}
   {Monad.bind A fun {$ _} B end}
end

%% Syntax: return X
%    Creates an action in the current monad that evaluates to X.
{Macro.defmacro return
 fun {$ fMacro(_|Expr|_ _) _}
    <<'`'{Monad.pure <<',' Expr >>}>>
 end}

%% Syntax: seq A1 … AN
%     Executes actions A1 through AN in a sequence using the current monad.
{Macro.defmacro seq
 fun {$ fMacro(_|As _) _}
    {List.foldR As fun {$ A Ar}
                      if Ar == nil then A
                      else
                         <<'`'{Seq Monad <<','A>> <<','Ar>>}>>
                      end
                   end nil}
 end}

%% Syntax: bind [X1 A1 … XN AN] S1 … SN
%    Binds the result of each Ai to Xi then executes actions S1 through SN in
%    a sequence, using the monad.
{Macro.defmacro bind
 fun {$ fMacro(_|Binds|Code _) _}
    CodeSeq = {Macro.listToSequence Code} in
    case Binds
    of fRecord(fAtom('|' _)
           [Var
            fRecord(fAtom('|' _)
                    [Action Rest])])  then
       <<'`'{Monad.bind <<','Action>>
             fun {$ <<','Var>>}
                <<bind <<','Rest>> <<','CodeSeq>> >>
             end}>>
    else
       <<'`' <<seq <<','CodeSeq >> >> >>
    end
 end}

% Default implementations of map and apply in terms of bind and pure, for
% convenience.

fun {Fmap Monad F M}
   <<bind [X M] <<return {F X}>>>>
end

fun {Ap Monad MF MX}
   <<bind [F MF X MX] <<return {F X}>>>>
end

Maybe = monad(map: fun {$ F V}
                      case V
                      of nothing then nothing
                      [] just(X) then just(F X)
                      end
                   end
              pure: fun {$ X} just(X) end
              apply: fun {$ MaybeF MaybeX}
                        case MaybeF
                        of nothing then nothing
                        [] just(F) then
                           case MaybeX
                           of nothing then nothing
                           [] just(X) then just(F X)
                           end
                        end
                     end
              bind: fun {$ MaybeX F}
                       case MaybeX
                       of nothing then nothing
                       [] just(X) then {F X}
                       end
                    end)

Reader = monad(map: fun {$ F G}
                       fun {$ X} {F {G X}} end
                    end
               pure: fun {$ X}
                        fun {$ _} X end
                     end
               apply: fun {$ F G}
                         fun {$ X} {F X {G X}} end
                      end
               bind: fun {$ F G}
                        fun {$ X} {{G {F X}} X} end
                     end)

State = monad(map: fun {$ F G}
                      proc {$ S ?X2 ?S2}
                         X {G S X S2} in X2 = {F X}
                      end
                   end
              pure: fun {$ X}
                       proc {$ S ?X2 ?S2}
                          X2 = X
                          S2 = S
                       end
                    end
              apply: fun {$ F G}
                        proc {$ S ?X3 ?S3}
                           F2 X2 S2 {F S F2 S2}
                           {G S2 X2 S3} in
                           X3 = {F2 X2}
                        end
                     end
              bind: fun {$ F G}
                       proc {$ S ?X3 ?S3}
                          X2 S2 {F S X2 S2} in
                          {{G X2} S2 X3 S3}
                       end
                    end)

local
   fun {MaybeHead Xs}
      case Xs
      of X|_ then just(X)
      [] nil then nothing
      end
   end
in
   local Monad = Maybe in
      {Browse
       <<bind [A {MaybeHead [1 2 3]}
               B {MaybeHead if false then nil
                            else [3 4] end}
               C {MaybeHead [5 6]}
               D just(3)]
       <<return A+B+C+D>>>>}
   end
end

local Monad = Reader in
   {Browse {<<bind [X List.length] <<return X*2>>>> [1 2 3]}}
end

local
   fun {Modify F}
      proc {$ S ?X ?S2}
         S2 = {F S}
         X  = S2
      end
   end

   Get = proc {$ S ?X ?S2}
            X  = S
            S2 = S
         end

   fun {Gets F}
      {State.map F Get}
   end

   fun {Push X} {Modify fun {$ Xs} X|Xs end} end
   Pop  = {Modify fun {$ _|Xr} Xr end}
   Peek = {Gets fun {$ X|_} X end}
in
   local Monad = State in
      local
         FinalState
         Output
         {<<seq
             {Push 4}
             {Push 6}
             Pop
             {Push 5}
             <<bind [X Peek]
                <<return X-1>>>>>>
          [1 2 3] Output FinalState}
      in
         {Browse Output}
         {Browse FinalState}
      end
   end
end