compiler.ml

module type Eq = sig
    type t
    val equal : t -> t -> bool
end

module type Order = sig
    type comparison =
        | Less
        | Equal
        | Greater
        
    type t
    val compare : t -> t -> comparison
end

module type Monoid = sig
    type t
    val empty  : t
    val append : t -> t -> t
end

module ComparisonMonoid (ORDER: Order) : Monoid = struct
    open ORDER
    
    type t = comparison
    
    let empty = Equal
    
    let append l r = match l, r with
        | Less   , _ -> Less
        | Equal  , r -> r
        | Greater, _ -> Greater
end

module type Functor = sig
    type 'a t
    val map : ('a -> 'b) -> ('a t -> 'b t)
end

module type Applicative = sig
    type 'a t
    val pure  : 'a -> 'a t
    val apply : ('a -> 'b) t -> 'a t -> 'b t
end

module type Error = sig
    type t
    val say : string -> t
    val toS : t -> string
end

module type Alternative = sig
    type 'a t
    val none   : unit -> 'a t
    val select : 'a t -> 'a t -> 'a t
end

module type Monad = sig
    type 'a t
    val return : 'a -> 'a t
    val bind   : 'a t -> ('a -> 'b t) -> 'b t
end

module type MonadFail = 
    functor (ERROR : Error) -> sig
        type 'a t
        val throw : ERROR.t -> 'a t
        val catch : 'a t -> (ERROR.t -> 'a t) -> 'a t
    end

module AlternativeOutOfMonadFail (M : MonadFail) (ERROR : Error) = struct
    include M(ERROR)
    let none   ()  = throw (ERROR.say "unknown error")
    let select l r = catch l (fun _ -> r)
end

module ApplicativeOutOfMonad (M : Monad) = struct
    include M
    let pure = return
    let apply mf mx =
        bind mf (fun f ->
        bind mx (fun x ->
        return (f x)))
end

module FunctorOutOfApplicative (A : Applicative) = struct
    include A
    let map f obj = apply (pure f) obj 
end

module FunctorOutOfMonad (M : Monad) = struct
    module AM = ApplicativeOutOfMonad(M)
    module FM = FunctorOutOfApplicative(AM)
    
    module Make = struct
        include   M
        include (AM : Applicative with type 'a t := 'a t)
        include (FM : Functor     with type 'a t := 'a t)
    end
end

module type Stream = sig
    type t
    type slice
    type position
    type carrier
    module Offset : sig
        type t
        val zero  : t
        val one   : t
    end
    val whole  : carrier -> t
    val add    : Offset.t -> t -> t option
    val slice  : int -> t -> (slice * Offset.t) option
    val curPos : t -> position
end

type ('a, 'b) either =
    | Left  of 'a
    | Right of 'b

module ParserBase
    (STREAM : Stream)
    (ERROR  : Error)
= struct
    type 'a t = { runParser : STREAM.t -> (ERROR.t, 'a) either * STREAM.Offset.t }
   
    let parser f = {runParser = f}
    
    let dispatcResult ok err res =
        match res with
        | Left  e, at -> err e at
        | Right a, at -> ok  a at
    
    let satisfy msg pred = parser @@ fun stream ->
        match STREAM.slice 1 stream with
        | Some (slice, toRest) ->
            Right slice, toRest
        | None ->
            Left (ERROR.say msg), STREAM.Offset.zero
    
    let return x = parser @@ fun stream ->
        Right x, STREAM.Offset.zero
    
    let bind p cont = parser @@ fun stream ->
        match p.runParser stream with
        | Right a, offset ->
            let Some stream = STREAM.add offset stream in
            (cont a).runParser stream
        | Left a, offset ->
            Left a, offset
    
    let throw err = parser @@ fun stream ->
        Left err, STREAM.Offset.zero
    
    let catch p handler = parser @@ fun stream ->
        match p.runParser stream with
        | Left err, offset when
            offset = STREAM.Offset.zero ->
                (handler err).runParser stream
                
        | other ->
            other

    let try_ p = parser @@ fun stream ->
        match p.runParser stream with
        | Left err, _ ->
            Left err, STREAM.Offset.zero
                
        | other ->
            other

    let rec some p = parser @@ fun stream ->
        (bind       p  @@ fun x  ->
         bind (many p) @@ fun xs ->
            return (x :: xs)).runParser stream
    and many p = catch (some p) @@ fun _ -> return []    
end

module Parser
    (STREAM : Stream)
    (ERROR  : Error)
= struct
    module PBS     = ParserBase(STREAM)
    module ALTPBSE = AlternativeOutOfMonadFail(PBS)(ERROR)
    module PBSE    = PBS(ERROR)
    module APPPBSE = ApplicativeOutOfMonad(PBSE)
    module FUNPBSE = FunctorOutOfMonad(PBSE)
    module Make = struct
        module Stream = STREAM
        include PBSE
        include (ALTPBSE      : Alternative with type 'a t := 'a t)
        include (APPPBSE      : Applicative with type 'a t := 'a t)
        include (FUNPBSE.Make : Functor     with type 'a t := 'a t)
    end
end

module CharStream : (Stream with type carrier = string) = struct
    type carrier = string

    type t =
        { carrier  : carrier
        ; position : position
        }
        
    and position =
        { column : int
        ; line   : int
        ; chars  : int
        }
        
    type slice = string
        
    module Offset = struct
        type t =  int
        
        let zero, one = 0, 1
    end
    
    let whole text = { carrier = text; position = { line = 1; column = 1; chars = 1 } }
    
    let curPos stream =
        stream.position

    let rec add offset stream =
        if offset = 0
        then Some stream
        else 
            if stream.position.chars == String.length stream.carrier
            then None
            else add (offset - 1)
                { stream with position =
                    advance stream.position stream.carrier.[stream.position.chars]
                }
        
    and advance pos chr =
        if chr = '\n'
        then
            { line   = 1 + pos.line
            ; column = 1
            ; chars  = 1 + pos.chars
            }
        else
            { pos
            with column = 1 + pos.column
            ;    chars  = 1 + pos.chars
            }
    
    let slice amount stream =
        if String.length stream.carrier - stream.position.chars >= amount
        then
            Some (String.sub stream.carrier stream.position.chars amount, amount)
        else
            None
end

module ParserError : Error = struct
    type t = string
    let say msg = msg
    let toS msg = msg
end

module CharParserMake = Parser(CharStream)(ParserError)
module CharParser = CharParserMake.Make

let (|>) x f = f x

let dprint = CharParser.dispatcResult (fun _ _ -> ()) (fun e _ -> print_string (ParserError.toS e))

let tokenize text = CharParser.(
    let rec space = satisfy "space" (String.contains " \n\t\r")
    in (some space).runParser (CharParser.Stream.whole text)
)

let _ =
    tokenize "hello" |> dprint