PreviousUpNext

15.4.172  src/lib/c-glue/ml-grinder/ml-grinder.pkg

## ml-grinder.pkg
#
# The core of the ML-Grinder library



###                      Never tell the truth to people who are not worthy of it.
###
###                                                  -- Mark Twain,
###                                                     Notebook, 1902



local

   Author  = "Allen Leung"
   Email   = "leunga@cs.nyu.edu, leunga@dorsai.org"
   Version = "1.2.4"

   basisForTheMatchCompiler =
       string::cat
       [ "enum List X = NIL | . of X * List(X)\n",
         "enum Null_Or X = NULL | THE of X\n",
         "enum order = LESS | EQUAL | GREATER\n"
       ]
in

package ml_grinder :> Ml_Grinder {

    package pp          = pp
    package re          = reg_exp_lib
    package err         = adl_error
    package raw         = adl_raw_syntax
    package raw_util     = adl_raw_syntax_junk
    package raw_pp       = adl_raw_syntax_unparser
    package map_raw_syntax = adl_rewrite_raw_syntax_parsetree

    package raw_trans    = adl_raw_syntax_translation

    package raw_consts   = adl_raw_syntax_constants

    package parser
        =
        architecture_description_language_parser_g (
            #
            package rsu = raw_pp                                # "rsu" == "raw_syntax_unparser"
            adl_mode = FALSE extra_cells = []
        )

    package match_generic
        =
        match_gen_g (                   # See src/lib/compiler/back/low/tools/match-compiler/match-gen-g.pkg
            package rsu = raw_pp        # "rsu" == "raw_syntax_unparser"
            package rsj = raw_util      # "rsj" == "raw_syntax_junk"
            package map_raw_syntax = map_raw_syntax
       )
    #  package html_g = html_g 

    package r  = map_raw_syntax
    package u  = raw_util
    package m  = match_generic
    package p  = parser
    package tr = raw_trans

    i2s = int::to_string
    my ++  = pp.++
    infix ++

    type labeled X = raw::id * X

    line_width = REF 160

    nolocations = raw_trans::stripMarks

    fakeId = "__fake_id__"

    #  Pretty print as code 
    fun asML prog
        =
        pp::text (pp::setmode "code" ++ pp::text_width *line_width ++ prog)

    #  Error handling stuff 
    exception MLGrinderErrorMsg of String
    error   = err::error
    warning = err::warning

    fun bug (func, msg)
        = 
        {   msg = "ml_grinder error: " + func + ": " + msg;
            error msg;
            raise exception MLGrinderErrorMsg msg;
        }

    fun fail msg
        =
        {   error msg;
            raise exception MLGrinderErrorMsg msg;
        }

    silent = REF FALSE

    fun comment text
        =
        A.@@@("" . "/* " . map (fn c => " * " + c) text @ [" */", ""])

    package map {

       enum rule = E of raw::exp -> raw::exp
                     | SE of raw::structexp -> raw::structexp
                     | D of raw::decl -> raw::decl
                     | T of raw::ty -> raw::ty
                     | P of raw::pat -> raw::pat
    };

    package rewrite {

       enum rule = E of (raw::exp -> raw::exp) -> raw::exp -> raw::exp
                     | SE of (raw::structexp -> raw::structexp) ->
                                 raw::structexp -> raw::structexp
                     | D of (raw::decl -> raw::decl) -> raw::decl -> raw::decl
                     | T of (raw::ty -> raw::ty) -> raw::ty -> raw::ty
                     | P of (raw::pat -> raw::pat) -> raw::pat -> raw::pat
    };

    package fold {

        enum rule X = E of raw::exp * X -> X
                         | SE of raw::structexp * X -> X
                         | D of raw::decl * X -> X
                         | T of raw::ty * X -> X
                         | P of raw::pat * X -> X
    };

    package app {

        enum rule = E of raw::exp -> Void
                      | SE of raw::structexp -> Void
                      | D of raw::decl -> Void
                      | T of raw::ty -> Void
                      | P of raw::pat -> Void
    };

    package subst {

        enum rule = E of String -> Null_Or( raw::exp )
                      | SE of String -> Null_Or( raw::structexp )
                      | D of String -> Null_Or( raw::decl )
                      | T of String -> Null_Or( raw::ty )
                      | P of String -> Null_Or( raw::pat )
    };

    nothing = r::noRewrite

    #  Trace the current line 
    fun markLines { exp, decl, ty, pat, sexp }
        =
        {   fun exp' f (e as raw::MARKexp (l, _)) = { err::setLoc l; exp f e; }
              | exp' f e = exp f e;

            fun decl' f (d as raw::MARKDECL (l, _)) = { err::setLoc l; decl f d; }
              | decl' f d = decl f d;

            { exp=exp', decl=decl', ty, pat, sexp };
        }

    fun mapper rules
        =
        {   use Map;

            fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
              | f (E exp . rules, _, d, t, p, se)  = f (rules, fn _ => exp, d, t, p, se)
              | f (D decl . rules, e, _, t, p, se) = f (rules, e, fn _ => decl, t, p, se)
              | f (T ty . rules, e, d, _, p, se)   = f (rules, e, d, fn _ => ty, p, se)
              | f (P pat . rules, e, d, t, _, se)  = f (rules, e, d, t, fn _ => pat, se)
              | f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, fn _ => sexp);

            rules = f (rules, nothing, nothing, nothing, nothing, nothing);

            r::rewrite rules; 
        }

    fun rewriter rules
        =
        {   use Rewrite;

            fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
              | f (E exp . rules, _, d, t, p, se)  = f (rules, exp, d, t, p, se)
              | f (D decl . rules, e, _, t, p, se) = f (rules, e, decl, t, p, se)
              | f (T ty . rules, e, d, _, p, se)   = f (rules, e, d, ty, p, se)
              | f (P pat . rules, e, d, t, _, se)  = f (rules, e, d, t, pat, se)
              | f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, sexp);

            rules =   f (rules, nothing, nothing, nothing, nothing, nothing);

            r::rewrite rules;
        }

    fun subster rules
        =
        {   use Subst;

            fun g1 f _ (e as raw::ID_IN_EXPRESSION (raw::IDENT([], x))) =  
                   (case f x of THE e => e | NULL => e)
              | g1 f _ e = e;

            fun g2 f _ (e as raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, raw::LITERAL_IN_EXPRESSION (raw::STRING_LIT x))]) =  
                   (case f x of THE e => e | NULL => e)
              | g2 f _ e = e;

            fun g3 f _ (e as raw::IDTY (raw::IDENT([], x))) =  
                   (case f x of THE e => e | NULL => e)
              | g3 f _ e = e;

            fun g4 f _ (e as raw::IDPAT x) =  
                   (case f x of THE e => e | NULL => e)
              | g4 f _ e = e;

            fun g5 f _ (e as raw::IDSEXP (raw::IDENT([], x))) =  
                   (case f x of THE e => e | NULL => e)
              | g5 f _ e = e;

            fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
              | f (E exp . rules, _, d, t, p, se)  = f (rules, g1 exp, d, t, p, se)
              | f (D decl . rules, e, _, t, p, se) = f (rules, e, g2 decl, t, p, se)
              | f (T ty . rules, e, d, _, p, se)   = f (rules, e, d, g3 ty, p, se)
              | f (P pat . rules, e, d, t, _, se)  = f (rules, e, d, t, g4 pat, se)
              | f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, g5 sexp);

            rules =   f (rules, nothing, nothing, nothing, nothing, nothing);

            r::rewrite rules;
        }


    fun folder rules x
        =
        {   use Fold;

            x =   REF x;

            fun g f _ y
                =
                {   x := f (y,*x);
                    y;
                };

            fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
              | f (E exp . rules, _, d, t, p, se)  = f (rules, g exp, d, t, p, se)
              | f (D decl . rules, e, _, t, p, se) = f (rules, e, g decl, t, p, se)
              | f (T ty . rules, e, d, _, p, se)   = f (rules, e, d, g ty, p, se)
              | f (P pat . rules, e, d, t, _, se)  = f (rules, e, d, t, g pat, se)
              | f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, g sexp);

            rules =   f (rules, nothing, nothing, nothing, nothing, nothing);

            my { exp, decl, ty, pat, sexp }
                =
                r::rewrite rules;

            fun h f y
                =
                {    f y;
                     *x;
                };

            { exp = h exp, decl= h decl, ty=h ty, pat=h pat, sexp=h sexp };
        }

    fun apper rules
        =
        {   use App;

            fun g f _ x
                =
                {   f x;
                    x;
                };

            fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
              | f (E exp . rules, _, d, t, p, se)  = f (rules, g exp, d, t, p, se)
              | f (D decl . rules, e, _, t, p, se) = f (rules, e, g decl, t, p, se)
              | f (T ty . rules, e, d, _, p, se)   = f (rules, e, d, g ty, p, se)
              | f (P pat . rules, e, d, t, _, se)  = f (rules, e, d, t, g pat, se)
              | f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, g sexp);

            rules =   f (rules, nothing, nothing, nothing, nothing, nothing);

            my { exp, decl, ty, pat, sexp }
                =
                r::rewrite rules;

            fun h f x
                =
                {   f x;
                    ();
                };

            { exp = h exp, decl= h decl, ty=h ty, pat=h pat, sexp=h sexp };
        }

    fun noSimplify x
        =
        x

    #  Make a new type 
    generic package Type (type t) {

       type t     = t
       type pp    = pp::pp
       type ar    = App::rule
       type fr X = Fold::rule X
       type mr    = Map::rule
       type rr    = Rewrite::rule
       type sr    = Subst::rule
    };

    #  Map a list out of it 
    generic package List (type t 
                 my pp:        t -> pp::pp
                 my apply:     List( App::rule ) -> t -> Void
                 my fold:      List( Fold::rule(X) ) -> X -> t -> X
                 my map:       List( Map::rule ) -> t -> t
                 my rewrite:   List( Rewrite::rule ) -> t -> t
                 my subst:     List( Subst::rule ) -> t -> t
                 my simplify:  t -> t
                 my nolocations:   t -> t
                ) 
    {
       package t = Type (type t = List (t) )        use t
       list = pp::seq (pp::nop, pp.!! ", ", pp::nop)
       pp = fn x => list (list::map pp x)
       show = asML o pp
       apply = fn r => list::apply (apply r) 
       fold = fn r => { f = fold r;  fold_forward (fn (e, x) => f x e); }
       map = fn r => list::map (map r)
       subst = fn r => list::map (subst r)
       rewrite = fn r => list::map (rewrite r)
       simplify = list::map simplify
       nolocations = list::map nolocations
    };

    #  Make a labeled something out of it 
    generic package Labeled (type t 
                    my pp:           labeled( t ) -> pp::pp
                    my apply:        List( App::rule ) -> t -> Void
                    my fold:         List( Fold::rule(X) ) -> X -> t -> X
                    my map:          List( Map::rule ) -> t -> t
                    my rewrite:      List( Rewrite::rule ) -> t -> t
                    my subst:        List( Subst::rule ) -> t -> t
                    my simplify:     t -> t
                    my nolocations:  t -> t
                   )
    {
       package t = Type (type t = labeled (t) )     use t
       pp   = pp
       show = asML o pp
       apply = fn r => fn (l, x) => apply r x
       fold = fn r => fn u => fn (l, x) => fold r u x
       map = fn r => fn (l, x) => (l, map r x)
       rewrite = fn r => fn (l, x) => (l, rewrite r x)
       subst = fn r => fn (l, x) => (l, subst r x)
       simplify = fn (l, x) => (l, simplify x)
       nolocations = fn (l, x) => (l, nolocations x)
    };

   #  Declaration 
    package decl {

       package t = Type (type t = raw::decl)     use t

       fun parse s
           = 
           case p::parseString' *silent s of 
             [raw::MARKDECL(_, d)] => d | ds => raw::SEQ_DECL ds

       pp = raw_pp::decl 
       show = asML o pp 
       simplify = tr::simplify_declaration
       map = .decl o mapper  
       rewrite = .decl o rewriter  
       apply = .decl o apper
       subst = .decl o subster

       fun fold r x = .decl (folder r x)

       nolocations = nolocations
    };

    #  Make iterators for types without convenient ones 
    generic package Iterators (type t 
                      my ===> : t -> raw::decl
                      my <== : String * raw::decl -> t
                     ) 
    {
       fun simplify x = <==("simplify", decl::simplify(===> x))
       fun map r x = <==("map", decl::map r (===> x))
       fun rewrite r x = <==("rewrite", decl::rewrite r (===> x))
       fun subst r x = <==("subst", decl::subst r (===> x))
       fun apply r x = decl::apply r (===> x)
       fun fold r u x = decl::fold r u (===> x)
       fun nolocations x = <==("nolocations", decl::nolocations(===> x))
    }


    #  Expression 
    package exp {

       package t = Type (type t = raw::exp) use t

       fun parse s = 
           case decl::parse("my _ =\n" + s) of
              raw::VAL_DECL[raw::NAMED_VALUE(_, e)] => e | _ => raise exception p::PARSE_ERROR

       pp = raw_pp::exp 
       show = asML o pp 
       simplify = tr::simplifyExp
       map = .exp o mapper  
       rewrite = .exp o rewriter  
       apply = .exp o apper
       subst = .exp o subster

       fun fold r x = .exp (folder r x)

       fun nolocations e = 
           case decl::nolocations (raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, e)]) of
             raw::VAL_DECL[raw::NAMED_VALUE(_, e)] => e
           | _ => bug("Exp", "locations")
    }

    #  Expressions 
    package exps {

       fun parse s = 
           case decl::parse("my _ =\n(" + s + ")") of
              raw::VAL_DECL[raw::NAMED_VALUE(_, raw::TUPLE_IN_EXPRESSION e)] => e 
            | raw::VAL_DECL[raw::NAMED_VALUE(_, e)] => [e]
            | _ => raise exception p::PARSE_ERROR
       package x = List (Exp) use x
    }

    package label_expression {

       fun parse s = 
           case decl::parse("{\n" + s + "}") of
              raw::VAL_DECL[raw::NAMED_VALUE(_, raw::RECORDexp[e])] => e 
            | _ => raise exception p::PARSE_ERROR
       package x = Labeled (struct use Exp pp = raw_pp::label_expression end)     use x
    }

    # Labeled Expressions:
    #
    package label_expressions {

       fun parse s = 
           case decl::parse("{\n" + s + "}") of
              raw::VAL_DECL[raw::NAMED_VALUE(_, raw::RECORDexp e)] => e 
            | _ => raise exception p::PARSE_ERROR
       package x = List (Label_Expression)           use x
    }

    # Package Expression:
    #
    package sexp {

       package t = Type (type t = raw::structexp)    use t
       fun parse s = 
           case decl::parse("package __fake_id__ =\n" + s) of
              raw::PACKAGE_DECL(_, _, _, e) => e | _ => raise exception p::PARSE_ERROR

       pp = raw_pp::sexp 
       show = asML o pp 
       map = .sexp o mapper  
       rewrite = .sexp o rewriter  
       apply = .sexp o apper
       subst = .sexp o subster

       fun fold r x = .sexp (folder r x)

       simplify = tr::simplifySexp      

       fun nolocations x = 
           case decl::nolocations (raw::PACKAGE_DECL (fakeId,[], NULL, x)) of
             raw::PACKAGE_DECL(_, _, _, x) => x
           | _ => bug("Sexp", "locations")
    }

    # API Expression:
    #
    package api_expression {

       package t = Type (type t = raw::api_expression)        use t

       fun parse s = 
           case decl::parse("api f =\n" + s) of
              raw::API_DECL(_, e) => e | _ => raise exception p::PARSE_ERROR

       pp = raw_pp::api_expression 
       show  = asML o pp 

       package i = Iterators
          (type t = t
           fun ===> x = raw::API_DECL (fakeId, x)
           fun <== (name, raw::API_DECL(_, x)) = x
             | <== (name, _) = bug("Api_Exp", name)
          ) use i
    }

    #  Clauses: <clause> | ... | <clause> 
    package clauses {

       package t = Type (type t =  List (raw::clause))    use t
       fun parse s =
           case exp::parse("fn\n" + s) of
              raw::LAMBDA_EXPRESSION c => c |  _ => raise exception p::PARSE_ERROR

       pp = raw_pp::clauses
       show = asML o pp 
       isComplex = m::isComplex

       package i = Iterators
          (type t = t
           fun ===> x = raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, raw::LAMBDA_EXPRESSION x)]
           fun <== (name, raw::VAL_DECL[raw::NAMED_VALUE(_, raw::LAMBDA_EXPRESSION x)]) = x
             | <== (name, _) = bug("Clauses", name)
          ) use i
    }

    # Clause: <pat> => <exp>   
    #  or     <pat> where <exp> => <exp>      (ml_grinder extension)

    package clause {

       package t = Type (type t = raw::clause)   use t

       fun parse s = case Clauses::parse s of [c] => c |  _ => raise exception p::PARSE_ERROR

       pp = raw_pp::clause show = asML o pp 
       fun isComplex  c= m::isComplex[c]
       package i = Iterators
          (type t = t
           fun ===> x = raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, raw::LAMBDA_EXPRESSION [x])]
           fun <== (name, raw::VAL_DECL[raw::NAMED_VALUE(_, raw::LAMBDA_EXPRESSION [x])]) = x
             | <== (name, _) = bug("Clause", name)
          ) use i
    }

    #  Funclauses:  <funclause> | ... | <funclause> 
    package fun_clauses {

       use Clauses
       fun parse s =
           case decl::parse("fun \n" + s) of
              raw::FUN_DECL [raw::FUN (f, cs)] => (f, cs)
           |  _ => raise exception p::PARSE_ERROR
       fun nolocations (f, c) = (f, Clauses::nolocations c)
    }

    /* FunClause: f <pat> ... <pat> = <exp> 
     *  or        f <pat> ....<pat> where (<exp>) => <exp> (ml_grinder extension)
     */
    package fun_clause {

       use Clause
       fun parse s =
           case FunClauses::parse s of
              (f,[c]) => (f, c)
           |  _ => raise exception p::PARSE_ERROR
       fun nolocations (f, c) = (f, Clause::nolocations c)
    }

    #  Function_Defs: <function_def> and ... and <function_def> 
    package function_defs {

       package t = Type (type t =  List (raw::function_def))          use t
       fun parse s =
           case decl::parse("fun .\n" + s) 
             of raw::FUN_DECL b => b 
           |  _ => raise exception p::PARSE_ERROR
       pp = raw_pp::function_defs 
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::FUN_DECL x
           fun <== (name, raw::FUN_DECL x) = x 
             | <== (name, _) = bug("Function_Defs", name)
          ) use i
    }

    #  Fun: f <funclause> 
    package function_def {

       package t = Type (type t = raw::function_def)     use t
       fun parse s =
           case Function_Defs::parse s of [b] => b | _ => raise exception p::PARSE_ERROR
       pp = raw_pp::function_def
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::FUN_DECL [x]
           fun <== (name, raw::FUN_DECL [x]) = x
             | <== (name, _) = bug("Fun", name)
          )      use i
    }

    #  Named_Values: <named_value> and ... and <named_value> 
    package named_values {

       package t = Type (type t = List (raw::NAMED_VALUE) )       use t
       fun parse s =
           case decl::parse("my\n" + s) 
             of raw::VAL_DECL b => b 
           |  _ => raise exception p::PARSE_ERROR
       pp = raw_pp::named_values 
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::VAL_DECL x
           fun <== (name, raw::VAL_DECL x) = x
             | <== (name, _) = bug("Named_Values", name)
          )     use i
    }

    #  Named_Value: <pat> = <exp> 
    package named_value {

       package t = Type (type t = raw::NAMED_VALUE)        use t
       fun parse s =
           case Named_Values::parse s of [b] => b | _ => raise exception p::PARSE_ERROR
       pp = raw_pp::named_value
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::VAL_DECL [x]
           fun <== (name, raw::VAL_DECL [x]) = x
             | <== (name, _) = bug("Named_Value", name)
          )      use i
    }

    package consbinds {

       package t = Type (type t = List( raw::consbind ))    use t
       fun parse s = 
            case decl::parse("enum f=\n" + s) of
               raw::DATATYPE_DECL ([raw::DATATYPE { cbs=c, ... } ], _) => c 
            |  _ => raise exception p::PARSE_ERROR
       pp = raw_pp::consbinds
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::DATATYPE_DECL(
                         [raw::DATATYPE { name=fakeId, tyvars=[], mc=NULL,
                                         asm=FALSE, field=NULL, cbs=x } ],

                         [])
           fun <== (name, raw::DATATYPE_DECL(
                         [raw::DATATYPE { cbs, ... } ], _)) = cbs
             | <== (name, _) = bug("Consbinds", name)
          )        use i
    }

    package consbind {

       package t = Type (type t = raw::consbind)      use t
       fun parse s = case Consbinds::parse s of [c] => c | _ => raise exception p::PARSE_ERROR
       pp = raw_pp::consbind
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::DATATYPE_DECL(
                         [raw::DATATYPE { name=fakeId, tyvars=[], mc=NULL,
                                         asm=FALSE, field=NULL, cbs=[x] } ],
                         [])
           fun <== (name, raw::DATATYPE_DECL(
                         [raw::DATATYPE { cbs=[x], ... } ], _)) = x
             | <== (name, _) = bug("Constructor_Def", name)
          )     use i
    }

    package datatypes {

       package t = Type (type t = List( raw::datatype ))         use t
       fun parse s = 
            case decl::parse("enum " + s) 
              of raw::DATATYPE_DECL (db,[]) => db
               | _ => raise exception p::PARSE_ERROR
       pp = raw_pp::datatypes
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::DATATYPE_DECL (x,[])
           fun <== (name, raw::DATATYPE_DECL (x, _)) = x
             | <== (name, _) = bug("Datatypes", name)
          )         use i
    }

    package datatype {

       package t = Type (type t = raw::datatype)       use t
       fun parse s = 
            case Datatypes::parse s of [d] => d |  _ => raise exception p::PARSE_ERROR
       pp = raw_pp::datatype
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::DATATYPE_DECL([x],[])
           fun <== (name, raw::DATATYPE_DECL([x], _)) = x
             | <== (name, _) = bug("Datatype", name)
          )        use i
    }

    package typebinds {

       package t = Type (type t =  List( raw::typebind ))         use t
       fun parse s = 
            case decl::parse("type " + s) 
              of raw::DATATYPE_DECL([], tb) => tb
               |  _ => raise exception p::PARSE_ERROR
       pp = raw_pp::typebinds
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::DATATYPE_DECL([], x)
           fun <== (name, raw::DATATYPE_DECL(_, x)) = x
             | <== (name, _) = bug("Typebinds", name)
          )       use i
    }

    package typebind {

       package t = Type (type t = raw::typebind)         use t
       fun parse s = 
            case Typebinds::parse s of [d] => d | _ => raise exception p::PARSE_ERROR
       pp = raw_pp::typebind
       show = asML o pp
       package i = Iterators
          (type t = t
           fun ===> x = raw::DATATYPE_DECL([],[x])
           fun <== (name, raw::DATATYPE_DECL(_,[x])) = x
             | <== (name, _) = bug("Typebind", name)
          )         use i
    }

    package ty {

       package t = Type (type t = raw::ty)        use t
       fun parse s = 
           case decl::parse("type __fake_id__=\n" + s) of
              raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, t)]) => t
           |  _ => raise exception p::PARSE_ERROR
       pp = raw_pp::ty show = asML o pp
       map = .ty o mapper  
       rewrite = .ty o rewriter  
       apply = .ty o apper
       subst = .ty o subster
       fun fold r x = .ty (folder r x)
       simplify = tr::simplifyTy
       fun nolocations t = 
          case decl::nolocations (raw::DATATYPE_DECL([],[raw::TYPEBIND (fakeId,[], t)])) of
            raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, t)]) => t
          | _ => bug("Ty", "locations")
    }

    package tys {

       fun parse s = 
           case decl::parse("type t=\n(" + s + ")") of
              raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, raw::TUPLETY ts)]) => ts
            | raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, t)]) => [t]
            | _ => raise exception p::PARSE_ERROR
       package x = List (Ty)                use x
    }

    package labty {

       fun parse s = 
           case decl::parse("type t= {\n" + s + "}") of
              raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, raw::RECORDTY[t])]) => t
           |  _ => raise exception p::PARSE_ERROR
       package x = Labeled (struct use Ty pp = raw_pp::labty end)     use x
    }

    package labtys {

       fun parse s = 
           case decl::parse("type t= {\n" + s + "}") of
              raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, raw::RECORDTY ts)]) => ts
           |  _ => raise exception p::PARSE_ERROR
       package x = List (Labty)            use x
    }

    package pat {

       package t = Type (type t = raw::pat)       use t
       type t = raw::pat
       fun parse s = 
           case decl::parse("my\n" + s + " = ()") of
              raw::VAL_DECL[raw::NAMED_VALUE (p, _)] => p | _ => raise exception p::PARSE_ERROR
       pp = raw_pp::pat show = asML o pp
       map = .pat o mapper  
       rewrite = .pat o rewriter  
       apply = .pat o apper
       subst = .pat o subster
       fun fold r x = .pat (folder r x)
       simplify = tr::simplifyPat
       fun nolocations p = 
          case decl::nolocations (raw::VAL_DECL[raw::NAMED_VALUE (p, raw::TUPLE_IN_EXPRESSION [])]) of
            raw::VAL_DECL[raw::NAMED_VALUE (p, _)] => p
          | _ => bug("Pat", "locations")
    }

    package pats {

       fun parse s = 
           case decl::parse("my(\n" + s + ")=()") of
              raw::VAL_DECL[raw::NAMED_VALUE (raw::TUPLEPAT p, _)] => p 
            | raw::VAL_DECL[raw::NAMED_VALUE (p, _)] => [p]
            | _ => raise exception p::PARSE_ERROR
       package x = List (Pat)                use x
    }

    package labpat {

       fun parse s = 
           case decl::parse("my {\n" + s + "} =()") of
              raw::VAL_DECL[raw::NAMED_VALUE (raw::RECORD_PATTERN([p], _), _)] => p 
            | _ => raise exception p::PARSE_ERROR
       package x = Labeled (pkg use Pat pp = raw_pp::labpat end)        use x
    {

    package labpats {

       fun parse s = 
           case decl::parse("my {\n" + s + "} =()") of
              raw::VAL_DECL[raw::NAMED_VALUE (raw::RECORD_PATTERN (ps, _), _)] => ps 
            | _ => raise exception p::PARSE_ERROR
       package x = List (Labpat)          use x
    }

    package constants {

       fun constants ()
           =
           {   t = raw_consts::newConstTable();
               defineConst = raw_consts::const t;

               fun declareConsts decl
                   =
                   case raw_consts::genConsts t of
                     [] => decl
                   | ds => raw::LOCAL_DECL (ds,[decl]) 

               { defineConst, declareConsts };
           }
    }

    #  Input/Output 
    package io {

       type filename = String

       fun read_string filename =
       let s = file::open_for_read filename
       in  file::read_all s before file::close_input s
       end

       fun read_lines filename
           =
           {   s =   file::open_for_read filename;

               fun read (text)
                   = 
                   case file::read_line s of
                     "" => reverse text
                   | t  => read (t . text)

               read [] before file::close_input s;
           }

       fun stripNL "" = ""
         | stripNL s
           = 
           {   i =   size s - 1;

               if   string::get (s, i) == '\n'
               then string::substring (s, 0, i)
               else s;
           }

       fun read_lines' filename
           =
           map stripNL (read_lines filename);

       fun read_verbatim filename
           =
           A.@@@(read_lines' filename);

       fun read_file filename
           = 
           case parser::load filename of
             [d] => d
           | ds => raw::SEQ_DECL ds;

       enum writeOpt = 
            INFILE of filename
          | OUTFILE of filename      
          | EXT of String
          | AUTHOR of String
          | VERSION of String
          | PROGRAM of String
          | EMAIL of String
          | COMMENT of List( String )


       #  Don't write the file if nothing has changed 
       fun changed (outfile, text)
           =
           {   ch
                   = 
                   {   s =   file::open_for_read outfile;
                       t =   file::read_all s;

                       t != text before file::close_input s;
                   }
                   except _ => TRUE;

               if ch   then err::log("[Writing " + outfile + "]") 
                       else err::log("[No change to " + outfile + "]");

               ch;
           }

       fun write_string (filename, text)
           = 
           if changed   (filename, text)
           then
                {   s =   file::open filename;

                    file::write (s, text)
                    before
                        file::close s;
                }
           else ()

       fun write_lines (filename, text)
           =
           write_string (filename, string::cat text)

       fun writeFile (opts, generatedProgram)
           = 
           {   infile  = REF NULL;
               outfile = REF NULL;
               extension  = REF "pkg";
               author     = REF NULL;
               version = REF NULL;
               program = REF NULL;
               email   = REF NULL;
               comment = REF [];

               apply (fn INFILE s => infile   :=   THE s;
                       | OUTFILE s => outfile :=   THE s;
                       | EXT s => extension   :=   s;
                       | AUTHOR s => author   :=   THE s;
                       | VERSION s => version :=   THE s;
                       | PROGRAM s => program :=   THE s;
                       | EMAIL s => email     :=   THE s;
                       | COMMENT s => comment :=   s @ *comment) opts;

               #  Find out what output file to use 
               outfile
                   =  
                   case *outfile of 
                     THE f => f

                   | NULL => #  Determine outfile name from infile/suffix 
                     case *infile of
                       NULL => bug("writeFile", "no output filename given")

                     | THE infile
                           =>
                           {   my { base, ext }
                                   =
                                   winix__premicrothread::path::split_base_ext infile;

                               outfile = winix__premicrothread::path::join_base_ext
                                                  { base, ext=THE *extension };

                               if infile == outfile
                               then 
                                  bug("writeFile",
                                      "input and output file have the same name: " +
                                         infile)
                               else outfile;
                           };

               #  Create a comment message on top 
               from  = case *infile of 
                              THE f => [" * from \"" + f + "\""]
                            | NULL   => [];
               auth  = case *author of THE a => a + " + s " | NULL => "";
               prog  = case *program of THE p => p + " " | NULL => "";
               ver   = case *version of THE v => "(version " + v + ")" | NULL => "";
               by    = case auth + prog + ver of "" => [] | s => [" * by " + s];
               other = map (fn s => " * " + s) (*comment);
               email = case *email of THE e => 
                             [" * Please send comments and suggestions to " + e]
                           | NULL => [] ;
               prog' = case *program of THE p => p + " is " | NULL => "";

               comment
                   =  
                   A.@@@("/*" .
                       " * This file has been automatically generated" .
                       from @
                       by @
                       email @
                       [" * [" + prog'  + 
                        "built with the ml_grinder library (version " + Version + ")]"] @
                       other @
                       [ " */",
                         ""
                       ] 
                      );

               #  Prettyprint and generate the program 

               text =   decl::show (raw::SEQ_DECL[comment, generatedProgram]);

               write_string (outfile, text);
           }
    }



    #  The match compiler 
    package match_compiler {


        fakeBasis = decl::parse basisForTheMatchCompiler 

        fun compileTypes datatypes
            =
            m::compileTypes (fakeBasis . datatypes)

        exception MATCH_COMPILER = m::mc::MATCH_COMPILER

        fun compile_case_pattern { datatypes, prog }
            =
            {   literals =   REF m::LitMap::empty;
                info     =   compileTypes datatypes;

                #  Compile a case statement 

                fun compileCase (exp, rules)
                    = 
                    {   dfa  =   m::compile info rules

                        m::report { warning=err::warning, 
                                            error=err::error,
                                            log=err::log,
                                            dfa, 
                                            rules };

                        m::coder { root=exp, dfa, 
                                  fail=fn () => raw::RAISEexp (u::ID "MATCH"), 
                                  literals };
                    };


                #  Compile a function 

                fun fbind (fb as raw::FUN (f, cs as c . _))
                    =
                    if Clauses::isComplex cs
                    then #  expand function 

                          {   my raw::CLAUSE (args, _, _)
                                  =
                                  c;

                              arity = length args;
                              vars  = list::from_fn (arity, fn i => "p_" + i2s i);
                              root  = raw::TUPLE_IN_EXPRESSION (map u::ID vars);
                              cs'   = map (fn raw::CLAUSE (ps, g, e) =>
                                                     raw::CLAUSE([raw::TUPLEPAT ps], g, e)) cs;
                              body  = compileCase (root, cs');

                              raw::FUN (f, [raw::CLAUSE (map raw::IDPAT vars, NULL, body)]);
                          }
                    else  fb
                  | fbind fb = fb

                #  Find all occurances of conditional patterns and transform them 
                prog = decl::map
                       [Map::D (fn raw::FUN_DECL fbs => raw::FUN_DECL (map fbind fbs)
                               | d => d
                             ),
                        Map::E (fn e as raw::CASEexp (r, cs) =>
                                 if Clauses::isComplex cs then compileCase (r, cs) 
                                 else e
                               | e => e)
                       ] prog;

                litDecls = 
                     m::LitMap::keyed_fold_backward
                         (fn (l, v, d) =>
                            raw::NAMED_VALUE (raw::IDPAT v, raw::LITERAL_IN_EXPRESSION l) . d) [] (*literals);

                litDecls = case litDecls of 
                                 [] => []
                               | _  => [raw::VAL_DECL litDecls];

                { prog, literals=litDecls };
            }
    } #  match_compiler 


    #  The lexer generator 
    package lexer_generator {


        exception LEXER_GENERATOR of String
        package p  = perl_syntax
        package lg = lexer_generator_g (perl_syntax::R)

        fun compile re = the (number_string::scan_string p::scan re)

        fun lexerGenerate prog
            =
            {   exception WrongForm;

                fun exp (origExp as 
                      raw::CASEexp (raw::APPLY_EXPRESSION (raw::ID_IN_EXPRESSION (raw::IDENT(["Lexer"], "lexer")), head),
                                clauses))
                        =
                        (   {   rules = map (fn raw::CLAUSE([raw::TUPLEPAT [raw::LITPAT (raw::STRING_LIT re), p]], g, action)
                                                   => 
                                                   (re, p, g, action)
                                                 | _ => raise exception WrongForm
                                               )
                                               clauses;

                                regexps = map (fn (re, _, _, _) => compile re) rules;
                                lexer   = lg::compile regexps;

                                clauses = map (fn (_, p, g, action) => raw::CLAUSE([p], g, action))
                                              rules;

                                raw::CASEexp
                                   (raw::APPLY_EXPRESSION (raw::ID_IN_EXPRESSION (raw::IDENT(["Lexer"], "match")), head), 
                                    clauses);
                            }
                            except
                                WrongForm => origExp
                        )

                  | exp e = e;

                prog =   decl::map[Map::E exp] prog;

                literals = [];

                { prog, literals };

            };

    } #  lexer_generator 
}; #  ml_grinder 

end; #  local 


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext