Source

amall / src / am_List.ml

Full commit
module List
 =
  struct

    include List;

    value find_opt pred lst =
      try
        Some (List.find pred lst)
      with
      [ Not_found -> None ]
    ;

    value rec drop_while pred lst =
      match lst with
      [ [] -> []
      | [ hd :: tl ] ->
          if pred hd
          then drop_while pred tl
          else lst
      ]
    ;

    value last lst =
      match lst with
      [ [] -> failwith "ExtList.last"
      | [h :: t] ->
          inner h t
          where rec inner prev lst =
            match lst with
            [ [] -> prev
            | [h :: t] -> inner h t
            ]
      ]
    ;

    value concat_with between lol =
      match lol with
      [ [] -> []
      | [first :: rest] ->
          inner (List.rev first) rest
          where rec inner rev_acc lol =
            match lol with
            [ [] -> List.rev rev_acc
            | [h :: t] ->
                inner
                  (List.rev_append
                     h
                     (List.rev_append between rev_acc)
                  )
                  t
            ]
      ]
    ;


    (* returns: ([pre], [this], [rest]) or ([pre], [], []) *)

    value split_by_first pred lst =
      inner [] lst
      where rec inner rev_acc lst =
        match lst with
        [ [] -> (List.rev rev_acc, [], [])
        | [h :: t] ->
            if pred h
            then (List.rev rev_acc, [h], t)
            else inner [h :: rev_acc] t
        ]
    ;

    value split_by pred lst =
      loop [] lst
      where rec loop rev_acc lst =
        if lst = []
        then List.rev rev_acc
        else
          let (pre, _delim, rest) = split_by_first pred lst in
          loop [pre :: rev_acc] rest
    ;


    value map_filter func lst =
      inner [] lst
      where rec inner rev_acc lst =
        match lst with
        [ [] -> List.rev rev_acc
        | [h :: t] ->
            match func h with
            [ None -> inner rev_acc t
            | Some x -> inner [x :: rev_acc] t
            ]
        ]
    ;


    value hd_opt = fun
      [ [] -> None
      | [x :: _] -> Some x
      ]
    ;


    value assoc_count ?(cmp=Pervasives.compare) k t =
      inner 0 t
      where rec inner n t =
        match t with
        [ [] -> n
        | [(hk,_hv)::t] ->
            inner (if cmp k hk = 0 then (n+1) else n) t
        ]
    ;

    value assoc_opt ?(cmp=Pervasives.compare) k t =
      inner t
      where rec inner t =
        match t with
        [ [] -> None
        | [(hk, hv) :: t] ->
            if cmp k hk = 0
            then Some hv
            else inner t
        ]
    ;


    (* non tail-rec, GC-wise (does not recreate cons cells without need) *)

    value rec assoc_remove ?(cmp=Pervasives.compare) k t =
      let rec inner left t =
        if left = 0
        then t
        else loop left t
      and loop left t =
        match t with
        [ [] -> assert False
        | [((hk,_hv) as h) :: t] ->
            if cmp k hk = 0
            then inner (left - 1) t
            else [h :: loop left t]
        ]
      in
        inner (assoc_count ~cmp k t) t
    ;


    value rec assoc_replace ?(cmp=Pervasives.compare) k v t =
      [(k, v) :: assoc_remove ~cmp k t]
    ;


    value reduce_left mapfunc reducefunc lst =
      match lst with
      [ [] -> invalid_arg "ExtList.reduce_left: empty input list"
      | [h :: t] ->
          inner ~acc:(mapfunc h) t
          where rec inner ~acc lst =
            match lst with
            [ [] -> acc
            | [h :: t] ->
                inner t ~acc:(reducefunc acc (mapfunc h))
            ]
      ]
    ;

    value get_single lst =
      let fail reason = failwith ("ExtList.get_single: " ^ reason) in
      match lst with
      [ [] -> fail "empty list"
      | [x :: []] -> x
      | [_ :: [_ :: _]] -> fail "more than one element"
      ]
    ;

    value get_pair lst =
      let fail reason = failwith
        ("ExtList.get_pair: expected list of two elements, got " ^ reason) in
      match lst with
      [ [] -> fail "empty list"
      | [_ ::[]] -> fail "list of one element"
      | [x :: [y :: []]] -> (x, y)
      | _ -> fail "list of more than two elements"
      ]
    ;


    open Amall_types;

    module Functor
     =
      struct
        type t 'a = list 'a;
        value fmap = List.map;
      end
    ;

  end
;