adamc@1: (* Copyright (c) 2008, Adam Chlipala
adamc@1:  * All rights reserved.
adamc@1:  *
adamc@1:  * Redistribution and use in source and binary forms, with or without
adamc@1:  * modification, are permitted provided that the following conditions are met:
adamc@1:  *
adamc@1:  * - Redistributions of source code must retain the above copyright notice,
adamc@1:  *   this list of conditions and the following disclaimer.
adamc@1:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1:  *   this list of conditions and the following disclaimer in the documentation
adamc@1:  *   and/or other materials provided with the distribution.
adamc@1:  * - The names of contributors may not be used to endorse or promote products
adamc@1:  *   derived from this software without specific prior written permission.
adamc@1:  *
adamc@1:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@1:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1:  * POSSIBILITY OF SUCH DAMAGE.
adamc@1:  *)
adamc@1: 
adamc@1: (* Laconic/Web language parser *)
adamc@1: 
adamc@1: structure Compiler :> COMPILER = struct 
adamc@1: 
adamc@1: structure LacwebLrVals = LacwebLrValsFn(structure Token = LrParser.Token)
adamc@1: structure Lex = LacwebLexFn(structure Tokens = LacwebLrVals.Tokens)
adamc@1: structure LacwebP = Join(structure ParserData = LacwebLrVals.ParserData
adamc@1:                          structure Lex = Lex
adamc@1:                          structure LrParser = LrParser)
adamc@1: 
adamc@1: (* The main parsing routine *)
adamc@1: fun parse filename =
adamc@1:     let
adamc@1:         val () = (ErrorMsg.resetErrors ();
adamc@1:                   ErrorMsg.resetPositioning filename)
adamc@1: 	val file = TextIO.openIn filename
adamc@1: 	fun get _ = TextIO.input file
adamc@1: 	fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@1: 	val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@1: 	val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ())
adamc@1:     in
adamc@1:         TextIO.closeIn file;
adamc@5:         if ErrorMsg.anyErrors () then
adamc@5:             NONE
adamc@5:         else
adamc@5:             SOME absyn
adamc@1:     end
adamc@1:     handle LrParser.ParseError => NONE
adamc@1: 
adamc@5: fun elaborate env filename =
adamc@5:     case parse filename of
adamc@5:         NONE => NONE
adamc@5:       | SOME file =>
adamc@5:         let
adamc@5:             val out = Elaborate.elabFile env file
adamc@5:         in
adamc@5:             if ErrorMsg.anyErrors () then
adamc@5:                 NONE
adamc@5:             else
adamc@5:                 SOME out
adamc@5:         end
adamc@16: 
adamc@16: fun corify eenv cenv filename =
adamc@16:     case elaborate eenv filename of
adamc@16:         NONE => NONE
adamc@31:       | SOME (file, _) =>
adamc@25:         if ErrorMsg.anyErrors () then
adamc@25:             NONE
adamc@25:         else
adamc@25:             SOME (Corify.corify file)
adamc@5: 
adamc@20: fun reduce eenv cenv filename =
adamc@20:     case corify eenv cenv filename of
adamc@20:         NONE => NONE
adamc@25:       | SOME file =>
adamc@25:         if ErrorMsg.anyErrors () then
adamc@25:             NONE
adamc@25:         else
adamc@25:             SOME (Reduce.reduce (Shake.shake file))
adamc@20: 
adamc@23: fun shake eenv cenv filename =
adamc@23:     case reduce eenv cenv filename of
adamc@23:         NONE => NONE
adamc@25:       | SOME file =>
adamc@25:         if ErrorMsg.anyErrors () then
adamc@25:             NONE
adamc@25:         else
adamc@25:             SOME (Shake.shake file)
adamc@25: 
adamc@25: fun monoize eenv cenv filename =
adamc@25:     case shake eenv cenv filename of
adamc@25:         NONE => NONE
adamc@25:       | SOME file =>
adamc@25:         if ErrorMsg.anyErrors () then
adamc@25:             NONE
adamc@25:         else
adamc@25:             SOME (Monoize.monoize cenv file)
adamc@23: 
adamc@26: fun cloconv eenv cenv filename =
adamc@26:     case monoize eenv cenv filename of
adamc@26:         NONE => NONE
adamc@26:       | SOME file =>
adamc@26:         if ErrorMsg.anyErrors () then
adamc@26:             NONE
adamc@26:         else
adamc@26:             SOME (Cloconv.cloconv file)
adamc@26: 
adamc@29: fun cjrize eenv cenv filename =
adamc@29:     case cloconv eenv cenv filename of
adamc@29:         NONE => NONE
adamc@29:       | SOME file =>
adamc@29:         if ErrorMsg.anyErrors () then
adamc@29:             NONE
adamc@29:         else
adamc@29:             SOME (Cjrize.cjrize file)
adamc@29: 
adamc@1: fun testParse filename =
adamc@1:     case parse filename of
adamc@5:         NONE => print "Failed\n"
adamc@1:       | SOME file =>
adamc@5:         (Print.print (SourcePrint.p_file file);
adamc@5:          print "\n")
adamc@5: 
adamc@5: fun testElaborate filename =
adamc@14:     (case elaborate ElabEnv.basis filename of
adamc@5:          NONE => print "Failed\n"
adamc@31:        | SOME (file, _) =>
adamc@32:          (print "Succeeded\n";
adamc@32:           Print.print (ElabPrint.p_file ElabEnv.basis file);
adamc@5:           print "\n"))
adamc@5:     handle ElabEnv.UnboundNamed n =>
adamc@5:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@1: 
adamc@16: fun testCorify filename =
adamc@16:     (case corify ElabEnv.basis CoreEnv.basis filename of
adamc@16:          NONE => print "Failed\n"
adamc@16:        | SOME file =>
adamc@16:          (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@16:           print "\n"))
adamc@16:     handle CoreEnv.UnboundNamed n =>
adamc@16:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@16: 
adamc@20: fun testReduce filename =
adamc@20:     (case reduce ElabEnv.basis CoreEnv.basis filename of
adamc@20:          NONE => print "Failed\n"
adamc@20:        | SOME file =>
adamc@20:          (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@20:           print "\n"))
adamc@20:     handle CoreEnv.UnboundNamed n =>
adamc@20:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@20: 
adamc@23: fun testShake filename =
adamc@23:     (case shake ElabEnv.basis CoreEnv.basis filename of
adamc@23:          NONE => print "Failed\n"
adamc@23:        | SOME file =>
adamc@23:          (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@23:           print "\n"))
adamc@23:     handle CoreEnv.UnboundNamed n =>
adamc@23:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@23: 
adamc@25: fun testMonoize filename =
adamc@25:     (case monoize ElabEnv.basis CoreEnv.basis filename of
adamc@25:          NONE => print "Failed\n"
adamc@25:        | SOME file =>
adamc@25:          (Print.print (MonoPrint.p_file MonoEnv.basis file);
adamc@25:           print "\n"))
adamc@25:     handle MonoEnv.UnboundNamed n =>
adamc@25:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@25: 
adamc@26: fun testCloconv filename =
adamc@26:     (case cloconv ElabEnv.basis CoreEnv.basis filename of
adamc@26:          NONE => print "Failed\n"
adamc@26:        | SOME file =>
adamc@26:          (Print.print (FlatPrint.p_file FlatEnv.basis file);
adamc@26:           print "\n"))
adamc@26:     handle FlatEnv.UnboundNamed n =>
adamc@26:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@26: 
adamc@29: fun testCjrize filename =
adamc@29:     (case cjrize ElabEnv.basis CoreEnv.basis filename of
adamc@29:          NONE => print "Failed\n"
adamc@29:        | SOME file =>
adamc@29:          (Print.print (CjrPrint.p_file CjrEnv.basis file);
adamc@29:           print "\n"))
adamc@29:     handle CjrEnv.UnboundNamed n =>
adamc@29:            print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@29: 
adamc@29: fun compile filename =
adamc@29:     case cjrize ElabEnv.basis CoreEnv.basis filename of
adamc@29:         NONE => ()
adamc@29:       | SOME file =>
adamc@29:         let
adamc@29:             val outf = TextIO.openOut "/tmp/lacweb.c"
adamc@29:             val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@29:         in
adamc@29:             Print.fprint s (CjrPrint.p_file CjrEnv.basis file);
adamc@29:             TextIO.closeOut outf
adamc@29:         end
adamc@29: 
adamc@1: end