(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_journal.ml

  Copyright (c) 2004-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

(*
let nullf_ fmt =
    let fmt = string_of_format fmt in
    let len = String.length fmt in
    let rec eatfmt i =
        if i >= len then
            Obj.magic ()
        else
            match String.unsafe_get fmt i with
            | '%' -> Printf.scan_format fmt i sF aF tF fF
            | ch -> eatfmt (succ i)
    and sF _ i = eatfmt i
    and aF _ _ i = eatfmt i
    and tF _ i = eatfmt i
    and fF i = eatfmt i
    in
    eatfmt 0
*)

module type T = sig
    module Priority: Cf_ordered.Total_T
    
    class virtual ['level] prioritizer:
        object
            method virtual code: 'level -> Priority.t
            method virtual tag: 'level -> string
        end

    class ['level] event:
        'level #prioritizer -> 'level -> string ->
        object
            method prioritizer: 'level prioritizer
            method level: 'level
            method message: string
        end
    
    class virtual ['event] archiver:
        object
            constraint 'event = 'level #event            
            method virtual emit: 'event -> unit
        end

    class virtual ['archiver] agent:
        'level #prioritizer -> 'level -> 'archiver list ->
        object
            constraint 'event = 'level #event
            constraint 'archiver = 'event #archiver

            val mutable archivers_: 'archiver list
            val mutable limit_: Priority.t            

            method private virtual event: 'level -> string -> 'event

            method setlimit: 'level -> unit
            method enabled: 'level -> bool
            
            method private put:
                'a 'b. 'level -> ('event -> 'b) ->
                ('a, unit, string, 'b) format4 -> 'a
        end
end

module Create(P: Cf_ordered.Total_T) : (T with module Priority = P) = struct
    module Priority = P
    
    class virtual ['level] prioritizer =
        object
            method virtual code: 'level -> Priority.t
            method virtual tag: 'level -> string
        end

    class ['level] event prioritizer level message =
        let prioritizer = (prioritizer :> 'level prioritizer) in
        object(_:'event)
            method prioritizer = prioritizer
            method level: 'level = level
            method message: string = message
        end
    
    class virtual ['event] archiver =
        object
            constraint 'event = 'level #event            
            method virtual emit: 'event -> unit
        end
    
    class virtual ['archiver] agent prioritizer limit archivers =
        let prioritizer = (prioritizer :> 'level prioritizer) in
        object(self:'self)
            constraint 'event = 'level #event
            constraint 'archiver = 'event #archiver

            val mutable archivers_: 'archiver list = archivers
            val mutable limit_ = prioritizer#code limit
        
            method private virtual event: 'level -> string -> 'event

            method setlimit limit = limit_ <- prioritizer#code limit
            method enabled limit = prioritizer#code limit >= limit_
            
            method private put:
                'a 'b. 'level -> ('event -> 'b) ->
                ('a, unit, string, 'b) format4 -> 'a
                = fun level cont ->
                    let f message =
                        let e = self#event level message in
                        if self#enabled level then
                            List.iter (fun j -> j#emit e) archivers_;
                        cont e
                    in
                    Printf.kprintf f
        end
end

module Basic = struct
    include Create(Cf_ordered.Int_order)

    type invalid = [ `Invalid ]
    type fail = [ `Fail ]
    type error = [ `Error ]
    type warn = [ `Warn ]
    type notice = [ `Notice ]
    type info = [ `Info ]
    type debug = [ `Debug ]
    
    type basic = [ invalid | fail | error | warn | notice | info | debug ]
    type enable = [ `None | `All ]
    type level = [ basic | enable ]
end

class ['level] basic_prioritizer =
    object
        inherit ['level] Basic.prioritizer
        constraint 'level = [> Basic.level ]
        
        method code = function
            | `All -> max_int
            | `Invalid -> 7000
            | `Fail -> 6000
            | `Error -> 5000
            | `Warn -> 4000
            | `Notice -> 3000
            | `Info -> 2000
            | `Debug -> 1000
            | `None -> min_int
            | _ -> invalid_arg "Cf_journal: no code defined for priority!"
        
        method tag =
            let invalid_ = "INVALID" in
            let fail_ = "FAIL" in
            let error_ = "ERROR" in
            let warn_ = "WARN" in
            let notice_ = "NOTICE" in
            let info_ = "INFO" in
            let debug_ = "DEBUG" in
            function
            | `Invalid -> invalid_
            | `Fail -> fail_
            | `Error -> error_
            | `Warn -> warn_
            | `Notice -> notice_
            | `Info -> info_
            | `Debug -> debug_
            | _ -> invalid_arg "Cf_journal: no tag defined for priority!"
    end

class ['event] basic_channel_archiver channel =
    object
        constraint 'level = [> Basic.level ]
        constraint 'event = 'level #Basic.event
        inherit ['event] Basic.archiver
        
        method channel = channel
        
        method emit e =
            let n = e#level in
            let p = e#prioritizer in
            if (p#code `Fail) - (p#code e#level) > 0 then begin
                let tag = p#tag n in
                let m = e#message in
                Printf.fprintf channel "%s: %s\n" tag m;
                flush channel
            end
    end

class virtual ['archiver] basic_agent prioritizer limit archivers =
    let prioritizer = (prioritizer :> 'level basic_prioritizer) in
    object(self)
        constraint 'level = [> Basic.level ]
        constraint 'event = 'level #Basic.event
        constraint 'archiver = 'event #Basic.archiver
        inherit ['archiver] Basic.agent prioritizer limit archivers

        method invalid: 'a 'b. ('a, unit, string, 'b) format4 -> 'a =
            self#put `Invalid (fun x -> invalid_arg x#message)

        method fail: 'a 'b. ('a, unit, string, 'b) format4 -> 'a =
            self#put `Fail (fun x -> failwith x#message)
        
        method error: 'a. ('a, unit, string, unit) format4 -> 'a =
            self#put `Error ignore
        
        method warn: 'a. ('a, unit, string, unit) format4 -> 'a =
            self#put `Warn ignore
        
        method notice: 'a. ('a, unit, string, unit) format4 -> 'a =
            self#put `Notice ignore
        
        method info: 'a. ('a, unit, string, unit) format4 -> 'a =
            self#put `Info ignore
        
        method debug: 'a. ('a, unit, string, bool) format4 -> 'a =
            self#put `Debug (fun _ -> true)
    end

let basic_prioritizer = new basic_prioritizer

let basic_stdout_archiver =
    new basic_channel_archiver Pervasives.stdout

let basic_stderr_archiver =
    new basic_channel_archiver Pervasives.stderr

class basic_stdio_agent archiver =
    object
        inherit [Basic.level Basic.event basic_channel_archiver] basic_agent
            basic_prioritizer `Notice [archiver]
        
        method private event = new Basic.event basic_prioritizer
    end

type t = Basic.level Basic.event Basic.archiver basic_agent

let stdout = new basic_stdio_agent basic_stdout_archiver
let stderr = new basic_stdio_agent basic_stderr_archiver

(*--- End of File [ cf_journal.ml ] ---*)
