Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
type User = {
username : string
password : string
}
type Error = string
type UseCase<'a> =
| Notify of Error * 'a
| UserExist of User * (bool -> 'a)
| Register of User * 'a
let mapUseCase (f : 'a -> 'b) (useCase : UseCase<'a>) : UseCase<'b> =
match useCase with
| Register (user, value) -> Register (user, f value)
| UserExist (user, fn) -> UserExist (user, f << fn)
| Notify (message, v) -> Notify (message, f v)
type FreeUseCase<'a> =
| Pure of 'a
| Free of UseCase<FreeUseCase<'a>>
let rec bind (f : 'a -> FreeUseCase<'b>) (useCase : FreeUseCase<'a>) : FreeUseCase<'b> =
match useCase with
| Pure value -> f value
| Free t -> Free (mapUseCase (bind f) t)
let liftF (useCase:UseCase<'a>) : FreeUseCase<'a> =
Free (mapUseCase Pure useCase)
let (>>=) = fun useCase f -> bind f useCase
let (>>.) = fun t1 t2 -> t1 >>= fun _ -> t2
type UseCaseBuilder() =
member x.Bind(term, f) = bind f term
member x.Return(value) = Pure value
member x.Combine(term1, term2) = term1 >>. term2
member x.Zero() = Pure ()
member x.Delay(f) = f()
let usecase = new UseCaseBuilder()
let register (user : User) : FreeUseCase<unit> = liftF (Register (user, ()))
let notify (message : Error) : FreeUseCase<unit> = liftF (Notify (message, ()))
let userExist (user : User) : FreeUseCase<bool> = liftF (UserExist (user, true |> (=)))
let validatePassword (password : string) : string Option =
if (password.Length < 6) then
None
else
Some password
let createUser' user =
userExist user
>>= fun exists ->
if exists then
validatePassword user.password
|> function
| Some _ -> register user
| None -> notify "invalid password"
else
notify "username already exists"
let createUser user = usecase {
let! exist = userExist user
if (not exist) then
match (validatePassword user.password) with
| Some _ -> do! register user
| None -> do! notify "invalid password"
else
do! notify "username already exists"
}
let pureExist username =
["hugo"; "paco"; "luis"] |> Seq.contains username
let rec interpretIO (useCase:FreeUseCase<'a>) : 'a =
match useCase with
| Free (Register (user, next)) ->
printfn "User: %s Pass: %s" user.username user.password
interpretIO next
| Free (UserExist (user, fn)) ->
// should be from DB, u know...
interpretIO (fn (pureExist user.username))
| Free (Notify (error, next)) ->
printfn "Error: %s" error
interpretIO next
| Pure a -> a
let rec interpretPure (acc : string list) (useCase:FreeUseCase<'a>) : string list =
match useCase with
| Free (Register (user, next)) ->
interpretPure ((sprintf "User: %s Pass: %s" user.username user.password) :: acc) next
| Free (UserExist (user, fn)) ->
interpretPure acc (fn (pureExist user.username))
| Free (Notify (error, next)) ->
interpretPure ((sprintf "Error: %s" error) :: acc) next
| Pure a -> acc
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment