Zipper in F#

Example.fs

module Example

type fs =
  | File of string list
  | Dir  of (string, fs) Map

type fsKind =
  | IsFile
  | IsDir

type 'a m = (fs, 'a) Zipp.m

let slash (name : string) : fs Zipp.prism
  = { get =
        function
        | Dir map -> Map.tryFind name map
        | _       -> None

      set = fun whole part ->
        match whole with
        | Dir map -> Dir (Map.add name part map)
        | _       -> whole
    }

let map_keys map = map |> Map.toList |> List.map fst

let optionToList
  = function
  | Some a -> [a]
  | None   -> []

let ls : string list m
  = Zipp.monad {
    let! fs = Zipp.get
    match fs with
    | Dir map -> return map_keys map
    | _       -> return! Zipp.fail
  }

let classify (name : string) : fsKind m
  = Zipp.monad {
    do!  Zipp.go (slash name)
    let! fs = Zipp.get
    let! _  = Zipp.up
    match fs with
    | File _ -> return IsFile
    | _      -> return IsDir
  }

let rec collectFSModules
  = Zipp.monad {
    let! files = ls
    let! lists = Zipp.forM files <| fun file -> Zipp.monad {
      let! kind = classify file
      do! Zipp.go (slash file)
      let! res = Zipp.monad {
        if file.EndsWith(".fs") && kind = IsFile
        then
          let! fs = Zipp.get
          match fs with
          | File blob -> return [blob]
          | _         -> return! Zipp.fail
        else
          if kind = IsDir
          then
            let! list = collectFSModules
            return list
          else
            return []
      }
      let! _    = Zipp.up
      return res
    }
    return List.concat lists
  }

exception NotAFile

let rec addModuleHeader
  = Zipp.monad {
    let! files = ls
    do!  Zipp.forM_ files <| fun file -> Zipp.monad {
      let! kind = classify file
      do! Zipp.go (slash file)
      do! Zipp.monad {
        if file.EndsWith(".fs") && kind = IsFile
        then
          do! Zipp.change <| function
                | File lines -> File ("module " + file :: lines)
                | _          -> raise NotAFile
        else
          if kind = IsDir
          then
            do! addModuleHeader
          else
            return ()
      }
      let! _    = Zipp.up
      return ()
    }
  }

let fs : fs
  = Dir <| Map.ofList
      [ "foo", Dir <| Map.ofList
          [ "a.fs", File
              [ "some"
                "fs"
                "things"
              ]

            "b.hs", File
              [ "some"
                "non-fs"
                "thungs"
              ]
          ]

        "eh.fs", File
          [ "some"
            "more"
            "fs-things"
          ]
      ]

printfn "test1 = %A" <| Zipp.eval fs collectFSModules
printfn "test2 = %A" <| Zipp.exec fs addModuleHeader

Zipp.fs

module Zipp

type 't layer =
  { locus : 't
    back  : 't -> 't -> 't
    dirty :  bool
  }

type 't zipperState =
  't layer list

type ('t, 'a) m =
  't zipperState -> ('a * 't zipperState) option

type 't prism =
  { get  : 't -> 't option
    set  : 't -> 't -> 't
  }

exception Failed
exception CantGoUp

let inline returnM (a : 'a) : ('t, 'a) m
  = fun st -> Some (a, st)

let inline bindM
  (ma :       ('t, 'a) m)
  (k  : 'a -> ('t, 'b) m)
      :       ('t, 'b) m
  = ma >>
    function
    | None -> None
    | Some (a, st') ->
      k a st'

let fail : ('t, 'a) m
  = fun _ -> None

let inline catchM
  (ma :        ('t, 'a) m)
  (k  : exn -> ('t, 'a) m)
      :        ('t, 'a) m
  = fun st ->
    let res =
      try
        ma st
      with
        e -> k e st

    match res with
    | None   -> k Failed st
    | Some a -> Some a

let inline start (t : 't) : 't zipperState
  = [ { locus = t
        back  = fun s a -> raise CantGoUp
        dirty = false
      }
    ]

type ZipperMonad () =
  member inline self.Return(x) = returnM x
  member inline self.ReturnFrom(ma : ('t, 'a) m)  = ma

  member inline self.Bind   (ma : ('t, 'a) m, k)  = bindM  ma k
  member inline self.TryWith(ma : ('t, 'a) m, k)  = catchM ma k

  member inline self.Delay(lma : unit -> ('t, 'a) m) = lma()

let monad = new ZipperMonad ()

let inline go
  (prism : 't prism)
         : ('t, unit) m
  = function
  | layer :: rest as stack ->
    match prism.get layer.locus with
    | Some part ->
      let newLayer =
        { locus = part
          back  = prism.set
          dirty = false
        }

      Some ((), newLayer :: stack)

    | None -> None
  | [] -> None

let up : ('t, unit) m
  = function
  | layer :: prev :: rest ->
    let updatedPrev =
      if layer.dirty
      then
        { prev with
            locus = layer.back prev.locus layer.locus
            dirty = true
        }
      else
        prev
    Some ((), updatedPrev :: rest)

  | _ -> None

let top : ('t, 't layer) m
  = function
  | layer :: _ as stack -> Some (layer, stack)
  | _ -> None

let get : ('t, 't) m
  = function
  | layer :: _ as stack -> Some (layer.locus, stack)
  | _ -> None

let inline gets (f : 't -> 'a) : ('t, 'a) m
  = monad {
    let! t = get
    return (f t)
  }

let inline view (p : 't -> 'a option) : ('t, 'a) m
  = monad {
    let! t = get
    match p t with
    | None   -> return! fail
    | Some a -> return  a
  }

let inline stateful (f : 't -> ('a * 't)) : ('t, 'a) m
  = function
  | layer :: rest ->
    let (res, newLocus) = f layer.locus
    let newLayer =
      { layer with
          locus = newLocus
          dirty = true
      }
    Some (res, newLayer :: rest)
  | _ -> None

let inline change (f : 't -> 't) : ('t, unit) m
  = function
  | layer :: rest ->
    let newLocus = f layer.locus
    let newLayer =
      { layer with
          locus = newLocus
          dirty = true
      }
    Some ((), newLayer :: rest)
  | _ -> None

let inline optional (ma : ('t, 'a) m) : ('t, 'a option) m
  = monad {
    try
      let! a = ma
      return Some a
    with e ->
      return None
  }

let rec whileSuccessful (ma : ('t, 'a) m) : ('t, unit) m
  = monad {
    let! res = optional ma
    match res with
    | Some _ -> do! whileSuccessful ma
    | None   -> return ()
  }

let exit : ('t, unit) m
  = fun st -> whileSuccessful up st

let inline guard (flag : bool) : ('t, unit) m
  = if flag
    then returnM ()
    else fail

let inline forM
  (xs : 'a list)
  (k  : 'a -> ('t, 'b) m)
      : ('t, 'b list) m
  =
    let rec loop acc xs =
      match xs with
      | x :: xs' ->
        monad {
          let! y = k x
          return! loop (y :: acc) xs'
        }
      | _ ->
        returnM (List.rev acc)

    loop [] xs

let inline forM_
  (xs : 'a list)
  (k  : 'a -> ('t, 'b) m)
      : ('t, unit) m
  =
    let rec loop xs =
      match xs with
      | x :: xs' ->
        monad {
          let! y = k x
          return! loop xs'
        }
      | _ ->
        returnM ()

    loop xs

let inline run
  (t  : 't)
  (ma : ('t, 'a) m)
      : ('a * 't) option
  =
    let ma' = monad {
      let! res = ma
      do!  exit
      return ma
    }
    match ma (start t) with
    | Some (a, [{locus = t'}]) ->
      Some (a, t')
    | _ -> None

let inline eval
  (t  : 't)
  (ma : ('t, 'a) m)
      : 'a option
  =
    match run t ma with
    | Some (a, _) -> Some a
    | None        -> None

let inline exec
  (t  : 't)
  (ma : ('t, 'a) m)
      : 't option
  =
    match run t ma with
    | Some (_, t') -> Some t'
    | None         -> None

Zipp.fsi

module Zipp

type 't layer =
  { locus : 't
    back  : 't -> 't -> 't
    dirty :  bool
  }

type 't zipperState = 't layer list
type ('t, 'a) m = 't zipperState -> ('a * 't zipperState) option

type 't prism =
  { get : 't -> 't option
    set : 't -> 't -> 't
  }

type ZipperMonad =
  class
    new                      : unit -> ZipperMonad
    member inline Bind       : ('t, 'a) m * ('a -> ('t, 'b) m) -> ('t, 'b) m
    member inline Delay      : (unit -> ('t, 'a) m) -> ('t, 'a) m
    member inline Return     : 'a -> ('t, 'a) m
    member inline ReturnFrom : ('t, 'a) m -> ('t, 'a) m
    member inline TryWith    : ('t, 'a) m * (exn -> ('t, 'a) m) -> ('t, 'a) m
  end

exception Failed
exception CantGoUp

val inline returnM  : 'a -> ('t, 'a) m
val inline bindM    : ('t, 'a) m -> ('a -> ('t, 'b) m) -> ('t, 'b) m
val        fail     : ('t, 'a) m
val inline catchM   : ('t, 'a) m -> (exn -> ('t, 'a) m) -> ('t, 'a) m

val        monad    : ZipperMonad

val inline start    : 't -> 't zipperState

val inline go       : 't prism -> ('t, unit) m
val        up       :             ('t, unit) m

val        get      :                      ('t, 't) m
val inline gets     : ('t -> 'a)        -> ('t, 'a) m
val inline view     : ('t -> 'a option) -> ('t, 'a) m

val inline stateful : ('t -> 'a * 't) -> ('t, 'a) m
val inline change   : ('t -> 't)      -> ('t, unit) m

val inline optional : ma:('t, 'a) m -> ('t, 'a option) m
val whileSuccessful : ma:('t, 'a) m -> ('t, unit) m

val        exit     : ('t,unit) m

val inline guard    : bool -> ('t,unit) m

val inline forM     : 'a list -> ('a -> ('t, 'b) m) -> ('t, 'b list) m
val inline forM_    : 'a list -> ('a -> ('t, 'b) m) -> ('t, unit) m

val inline run      : 't -> ('t, 'a) m -> ('a * 't) option
val inline eval     : 't -> ('t, 'a) m -> 'a option
val inline exec     : 't -> ('t, 'a) m -> 't option

zipp.fsproj

<Project Sdk="Microsoft.NET.Sdk">

  <PropertyGroup>
    <OutputType>Exe</OutputType>
    <TargetFramework>netcoreapp2.2</TargetFramework>
    <NoWarn>62,40</NoWarn>
  </PropertyGroup>

  <ItemGroup>
    <Compile Include="Zipp.fsi" />
    <Compile Include="Zipp.fs" />
    <Compile Include="Example.fs" />
  </ItemGroup>

</Project>