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 : 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
  85         val b = basis ()
  86     in
  87         if !ErrorMsg.anyErrors then
  88             (b, NONE)
  89         else
  90             let
  91                 val prog = Parse.parse fname
  92             in
  93                 if !ErrorMsg.anyErrors then
  94                     (Env.empty, NONE)
  95                 else
  96                     let
  97                         val G' = Tycheck.checkFile b (tInit ()) prog
  98                     in
  99                         (G', #3 prog)
 100                     end
 101             end
 102     end
 103
 104 fun reduce fname =
 105     let
 106         val (G, body) = check fname
 107     in
 108         if !ErrorMsg.anyErrors then
 109             NONE
 110         else
 111             case body of
 112                 SOME body =>
 113                 let
 114                     val body' = Reduce.reduceExp G body
 115                 in
 116                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 117                                          [PD.string "Result:",
 118                                           PD.space 1,
 119                                           p_exp body']))*)
 120                     SOME body'
 121                 end
 122               | _ => NONE
 123     end
 124
 125 fun eval fname =
 126     case reduce fname of
 127         (SOME body') =>
 128         if !ErrorMsg.anyErrors then
 129             ()
 130         else
 131             Eval.exec (!defaultV) body'
 132       | NONE => ()
 133
 134 end