src/main.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* Main interface *)
  20
  21 structure Main :> MAIN = struct
  22
  23 open Ast Print
  24
  25 structure SM = StringMap
  26
  27 val dmy = ErrorMsg.dummyLoc
  28
  29 val defaultT : record ref = ref SM.empty
  30 val defaultV : (unit -> exp) SM.map ref = ref SM.empty
  31
  32 fun registerDefault (name, t, v) =
  33     case SM.find (!defaultT, name) of
  34         NONE => (defaultT := SM.insert (!defaultT, name, t);
  35                  defaultV := SM.insert (!defaultV, name, v))
  36       | SOME _ => raise Fail "Duplicate default environment variable"
  37
  38 fun tInit () = (TAction ((CRoot, dmy),
  39                          !defaultT,
  40                          StringMap.empty),
  41                 dmy)
  42
  43
  44
  45 fun check' G fname =
  46     let
  47         (*val _ = print ("Check " ^ fname ^ "\n")*)
  48         val prog = Parse.parse fname
  49     in
  50         if !ErrorMsg.anyErrors then
  51             G
  52         else
  53             Tycheck.checkFile G (tInit ()) prog
  54     end
  55
  56 fun basis () =
  57     let
  58         val dir = Posix.FileSys.opendir Config.libRoot
  59
  60         fun loop files =
  61             case Posix.FileSys.readdir dir of
  62                 NONE => (Posix.FileSys.closedir dir;
  63                          files)
  64               | SOME fname =>
  65                 if String.isSuffix ".dtl" fname then
  66                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
  67                                                file = fname}
  68                           :: files)
  69                 else
  70                     loop files
  71
  72         val files = loop []
  73         val files = Order.order files
  74     in
  75         if !ErrorMsg.anyErrors then
  76             Env.empty
  77         else
  78             foldl (fn (fname, G) => check' G fname) Env.empty files
  79     end
  80
  81 fun check fname =
  82     let
  83         val _ = ErrorMsg.reset ()
  84         val _ = Env.preTycheck ()
  85
  86         val b = basis ()
  87     in
  88         if !ErrorMsg.anyErrors then
  89             (b, NONE)
  90         else
  91             let
  92                 val prog = Parse.parse fname
  93             in
  94                 if !ErrorMsg.anyErrors then
  95                     (Env.empty, NONE)
  96                 else
  97                     let
  98                         val G' = Tycheck.checkFile b (tInit ()) prog
  99                     in
 100                         (G', #3 prog)
 101                     end
 102             end
 103     end
 104
 105 fun reduce fname =
 106     let
 107         val (G, body) = check fname
 108     in
 109         if !ErrorMsg.anyErrors then
 110             NONE
 111         else
 112             case body of
 113                 SOME body =>
 114                 let
 115                     val body' = Reduce.reduceExp G body
 116                 in
 117                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 118                                          [PD.string "Result:",
 119                                           PD.space 1,
 120                                           p_exp body']))*)
 121                     SOME body'
 122                 end
 123               | _ => NONE
 124     end
 125
 126 fun eval fname =
 127     case reduce fname of
 128         (SOME body') =>
 129         if !ErrorMsg.anyErrors then
 130             ()
 131         else
 132             Eval.exec (SM.map (fn f => f ()) (!defaultV)) body'
 133       | NONE => ()
 134
 135 end