(**** ML Programs from the book ML for the Working Programmer by Lawrence C. Paulson, Computer Laboratory, University of Cambridge. (Cambridge University Press, 1991) Copyright (C) 1991 by Cambridge University Press. Permission to copy without fee is granted provided that this copyright notice and the DISCLAIMER OF WARRANTY are included in any copy. DISCLAIMER OF WARRANTY. These programs are provided `as is' without warranty of any kind. We make no warranties, express or implied, that the programs are free of error, or are consistent with any particular standard of merchantability, or that they will meet your requirements for any particular application. They should not be relied upon for solving a problem whose incorrect solution could result in injury to a person or loss of property. If you do use the programs or functions in such a manner, it is at your own risk. The author and publisher disclaim all liability for direct, incidental or consequential damages resulting from your use of these programs or functions. ****) (*** Basic library module. From Chapter 9. ***) infix mem; signature BASIC = sig exception Lookup exception Nth val minl : int list -> int val maxl : int list -> int val take : int * 'a list -> 'a list val drop : int * 'a list -> 'a list val nth : 'a list * int -> 'a val mem : ''a * ''a list -> bool val newmem : ''a * ''a list -> ''a list val lookup : (''a * 'b) list * ''a -> 'b val filter : ('a -> bool) -> 'a list -> 'a list val exists : ('a -> bool) -> 'a list -> bool val forall : ('a -> bool) -> 'a list -> bool val foldleft : ('a * 'b -> 'a) -> 'a * 'b list -> 'a val foldright : ('a * 'b -> 'b) -> 'a list * 'b -> 'b end; functor BasicFUN() : BASIC = struct fun minl[m] : int = m | minl(m::n::ns) = if mn then maxl(m::ns) else maxl(n::ns); fun take (n, []) = [] | take (n, x::xs) = if n>0 then x::take(n-1,xs) else []; fun drop (_, []) = [] | drop (n, x::xs) = if n>0 then drop (n-1, xs) else x::xs; exception Nth; fun nth (l,n) = (*numbers the list elements [x0,x1,x2,...] *) case drop(n,l) of [] => raise Nth | x::_ => x; fun x mem [] = false | x mem (y::l) = (x=y) orelse (x mem l); (*insertion into list if not already there*) fun newmem(x,xs) = if x mem xs then xs else x::xs; exception Lookup; fun lookup ([], a) = raise Lookup | lookup ((x,y)::pairs, a) = if a=x then y else lookup(pairs, a); fun filter pred [] = [] | filter pred (x::xs) = if pred(x) then x :: filter pred xs else filter pred xs; fun exists pred [] = false | exists pred (x::xs) = (pred x) orelse exists pred xs; fun forall pred [] = true | forall pred (x::xs) = (pred x) andalso forall pred xs; fun foldleft f (e, []) = e | foldleft f (e, x::xs) = foldleft f (f(e,x), xs); fun foldright f ([], e) = e | foldright f (x::xs, e) = f(x, foldright f (xs,e)); end; (*** Lexical Analysis -- Scanning. From Chapter 9. ***) (*Formal parameter of LexicalFUN*) signature KEYWORD = sig val alphas: string list and symbols: string list end; (*Result signature of LexicalFUN*) signature LEXICAL = sig datatype token = Id of string | Key of string val scan : string -> token list end; (*All characters are covered except octal 0-41 (nul-space) and 177 (del), which are ignored. *) functor LexicalFUN (structure Basic: BASIC and Keyword: KEYWORD) : LEXICAL = struct local open Basic in datatype token = Key of string | Id of string; fun is_letter_or_digit c = "A"<=c andalso c<="Z" orelse "a"<=c andalso c<="z" orelse "0"<=c andalso c<="9"; val specials = explode"!@#$%^&*()+-={}[]:\"|;'\\,./?`_~<>"; (*scanning of an alphanumeric identifier or keyword*) fun alphanum (id, c::cs) = if is_letter_or_digit c then alphanum (id^c, cs) else (id, c::cs) | alphanum (id, []) = (id, []); fun tokenof a = if a mem Keyword.alphas then Key(a) else Id(a); (*scanning of a symbolic keyword*) fun symbolic (sy, c::cs) = if sy mem Keyword.symbols orelse not (c mem specials) then (sy, c::cs) else symbolic (sy^c, cs) | symbolic (sy, []) = (sy, []); fun scanning (toks, []) = rev toks (*end of chars*) | scanning (toks, c::cs) = if is_letter_or_digit c then (*identifier or keyword*) let val (id, cs2) = alphanum(c, cs) in scanning (tokenof id :: toks, cs2) end else if c mem specials then (*special symbol*) let val (sy, cs2) = symbolic(c, cs) in scanning (Key sy :: toks, cs2) end else (*spaces, line breaks, strange characters are ignored*) scanning (toks, cs); (*Scanning a list of characters into a list of tokens*) fun scan a = scanning([], explode a); end end; (*** Parsing functionals. From Chapter 9. ***) infix 5 --; infix 3 >>; infix 0 ||; signature PARSE = sig exception SynError of string type token val reader: (token list -> 'a * 'b list) -> string -> 'a val -- : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e val >> : ('a -> 'b * 'c) * ('b -> 'd) -> 'a -> 'd * 'c val || : ('a -> 'b) * ('a -> 'b) -> 'a -> 'b val $ : string -> token list -> string * token list val empty : 'a -> 'b list * 'a val id : token list -> string * token list val infixes : (token list -> 'a * token list) * (string -> int) * (string -> 'a -> 'a -> 'a) -> token list -> 'a * token list val repeat : ('a -> 'b * 'a) -> 'a -> 'b list * 'a end; functor ParseFUN (Lex: LEXICAL) : PARSE = struct type token = Lex.token; exception SynError of string; (*Phrase consisting of the keyword 'a' *) fun $a (Lex.Key b :: toks) = if a=b then (a,toks) else raise SynError a | $a _ = raise SynError "Symbol expected"; (*Phrase consisting of an identifier*) fun id (Lex.Id a :: toks) = (a,toks) | id toks = raise SynError "Identifier expected"; (*Application of f to the result of a phrase*) fun (ph>>f) toks = let val (x,toks2) = ph toks in (f x, toks2) end; (*Alternative phrases*) fun (ph1 || ph2) toks = ph1 toks handle SynError _ => ph2 toks; (*Consecutive phrases*) fun (ph1 -- ph2) toks = let val (x,toks2) = ph1 toks val (y,toks3) = ph2 toks2 in ((x,y), toks3) end; fun empty toks = ([],toks); (*Zero or more phrases*) fun repeat ph toks = ( ph -- repeat ph >> (op::) || empty ) toks; fun infixes (ph,prec_of,apply) = let fun over k toks = next k (ph toks) and next k (x, Lex.Key(a)::toks) = if prec_of a < k then (x, Lex.Key a :: toks) else next k ((over (prec_of a) >> apply a x) toks) | next k (x, toks) = (x, toks) in over 0 end; fun reader ph a = (*Scan and parse, checking that no tokens remain*) (case ph (Lex.scan a) of (x, []) => x | (_, _::_) => raise SynError "Extra characters in phrase"); end; (*** Pretty printing. See Oppen (1980). From Chapter 8. ***) signature PRETTY = sig type T val blo : int * T list -> T val str : string -> T val brk : int -> T val pr : outstream * T * int -> unit end; functor PrettyFUN () : PRETTY = struct datatype T = Block of T list * int * int (*indentation, length*) | String of string | Break of int; (*length*) (*Add the lengths of the expressions until the next Break; if no Break then include "after", to account for text following this block. *) fun breakdist (Block(_,_,len)::sexps, after) = len + breakdist(sexps, after) | breakdist (String s :: sexps, after) = size s + breakdist (sexps, after) | breakdist (Break _ :: sexps, after) = 0 | breakdist ([], after) = after; fun pr (os, sexp, margin) = let val space = ref margin fun blanks 0 = () | blanks n = (output(os," "); space := !space - 1; blanks(n-1)) fun newline () = (output(os,"\n"); space := margin) fun printing ([], _, _) = () | printing (sexp::sexps, blockspace, after) = (case sexp of Block(bsexps,indent,len) => printing(bsexps, !space-indent, breakdist(sexps,after)) | String s => (output(os,s); space := !space - size s) | Break len => if len + breakdist(sexps,after) <= !space then blanks len else (newline(); blanks(margin-blockspace)); printing (sexps, blockspace, after)) in printing([sexp], margin, 0); newline() end; fun length (Block(_,_,len)) = len | length (String s) = size s | length (Break len) = len; val str = String and brk = Break; fun blo (indent,sexps) = let fun sum([], k) = k | sum(sexp::sexps, k) = sum(sexps, length sexp + k) in Block(sexps,indent, sum(sexps,0)) end; end;