Free Monad + Interpreter in Elm

Main.elm

module Main exposing (..)

{-| Free monad + interpreter in Elm
-}

import Dict exposing (Dict)


{-| Dict String Int-like structure

`next` allows us to combine actions:

     Set "foo" 42  <|
     Get "foo"     <| \foo ->
     Set "bar" foo <|
     End

-}
type DSL next
    = Set String Int next
    | Get String (Int -> next)
    | End


example1 : DSL (DSL (DSL (DSL next)))
example1 =
    Set "foo" 42 <|
        Get "foo" <|
            \foo ->
                Set "bar" foo <|
                    End


map : (a -> b) -> DSL a -> DSL b
map fn dsl =
    case dsl of
        Set key value next ->
            Set key value (fn next)

        Get key kont ->
            Get key (fn << kont)

        End ->
            End


type FreeForDSL a
    = Free (DSL (FreeForDSL a))
    | Return a


example2 : FreeForDSL next
example2 =
    Free
        (Set "foo" 42 <|
            Free
                (Get "foo" <|
                    \foo ->
                        Free
                            (Set "bar" foo <|
                                Free End
                            )
                )
        )


return : a -> FreeForDSL a
return =
    Return


andThen : (a -> FreeForDSL b) -> FreeForDSL a -> FreeForDSL b
andThen fn x =
    case x of
        Return a ->
            fn a

        Free dsl ->
            Free (map (andThen fn) dsl)


example3 : FreeForDSL next
example3 =
    -- we don't have do notation...
    Free (Set "foo" 42 (Return ()))
        |> andThen
            (\() ->
                Free (Get "foo" Return)
                    |> andThen
                        (\foo ->
                            Free (Set "bar" foo (Return ()))
                                |> andThen
                                    (\() ->
                                        Free End
                                    )
                        )
            )



{-

   If elm-format indented things differently we could have a pseudo-do notation:

   bind : FreeForDSL a -> (a -> FreeForDSL b) -> FreeForDSL b
   bind x fn =
       andThen fn x

   example3Alt : FreeForDSL next
   example3Alt =
       bind (Free (Set "foo" 42 (Return ())))  <| \() ->
       bind (Free (Get "foo" Return))          <| \foo ->
       bind (Free (Set "bar" foo (Return ()))) <| \() ->
       Free End
-}


liftFree : DSL a -> FreeForDSL a
liftFree action =
    Free (map Return action)


get : String -> FreeForDSL Int
get key =
    liftFree (Get key identity)


set : String -> Int -> FreeForDSL ()
set key value =
    liftFree (Set key value ())


end : FreeForDSL a
end =
    liftFree End


example4 : FreeForDSL next
example4 =
    -- again, we don't have do notation
    set "foo" 42
        |> andThen
            (\() ->
                get "foo"
                    |> andThen
                        (\foo ->
                            set "bar" foo
                                |> andThen (\() -> end)
                        )
            )



{-
   example4Alt : FreeForDSL next
   example4Alt =
       bind (set "foo" 42)  <| \() ->
       bind (get "foo")     <| \foo ->
       bind (set "bar" foo) <| \() ->
       end


   ... OK, now for the interpreters
-}


run : FreeForDSL a -> Dict String Int -> Dict String Int
run program dict =
    case program of
        Free (Set key value next) ->
            run next (Dict.insert key value dict)

        Free (Get key kont) ->
            let
                value =
                    Dict.get key dict
                        |> Maybe.withDefault -1
            in
            run (kont value) dict

        Free End ->
            dict

        Return _ ->
            Dict.empty


result : Dict String Int
result =
    {- Dict.fromList
       [ ("foo", 42)
       , ("bar", 42)
       ]
    -}
    run example4 Dict.empty


runWithLog : FreeForDSL a -> ( Dict String Int, List String ) -> ( Dict String Int, List String )
runWithLog program ( dict, log ) =
    case program of
        Free (Set key value next) ->
            runWithLog next
                ( Dict.insert key value dict
                , ("Set the key '" ++ key ++ "' to " ++ String.fromInt value)
                    :: log
                )

        Free (Get key kont) ->
            let
                value =
                    Dict.get key dict
                        |> Maybe.withDefault -1
            in
            runWithLog (kont value)
                ( dict
                , ("Got value " ++ String.fromInt value ++ " from '" ++ key ++ "'")
                    :: log
                )

        Free End ->
            ( dict
            , "Finished" :: log
            )

        Return _ ->
            ( Dict.empty
            , log
            )


resultWithLog : ( Dict String Int, List String )
resultWithLog =
    {- ( Dict.fromList
           [ ("foo", 42)
           , ("bar", 42)
           ]
       , [ "Finished"
         , "Set the key 'bar' to 42"
         , "Got value 42 from 'foo'"
         , "Set the key 'foo' to 42"
         ]
       )
    -}
    runWithLog example4 ( Dict.empty, [] )

repl.md