src/order.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 (* Topological sorting of source files to take dependencies into account *)
  20
  21 structure Order :> ORDER = struct
  22
  23 open Ast
  24
  25 structure SS = StringSet
  26 structure SM = StringMap
  27
  28 fun predNeeded G (p, _) =
  29     case p of
  30         CRoot => SS.empty
  31       | CConst s =>
  32         if Env.lookupContext G s then
  33             SS.empty
  34         else
  35             SS.singleton s
  36       | CPrefix p => predNeeded G p
  37       | CNot p => predNeeded G p
  38       | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
  39
  40 fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
  41
  42 fun typNeeded G (t, _) =
  43     case t of
  44         TBase s =>
  45         if Env.lookupType G s then
  46             (SS.empty, SS.empty)
  47         else
  48             (SS.empty, SS.singleton s)
  49       | TList t => typNeeded G t
  50       | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
  51       | TAction (p, d, r) =>
  52         let
  53             val recordNeeded = SM.foldl
  54                                    (fn (t, ss) => unionCT (ss, typNeeded G t))
  55         in
  56             recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
  57         end
  58       | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
  59                                    typNeeded G t)
  60
  61       | TError => raise Fail "TError during dependency analysis"
  62       | TUnif _ => raise Fail "TUnif during dependency analysis"
  63
  64 val empty = ((SS.empty, SS.empty), SS.empty)
  65
  66 fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
  67     ((SS.union (c1, c2),
  68       SS.union (t1, t2)),
  69      SS.union (v1, v2))
  70
  71 val dt = (TError, ErrorMsg.dummyLoc)
  72
  73 fun expNeeded G (e, loc) =
  74     case e of
  75         EInt _ => ((SS.empty,
  76                     if Env.lookupType G "int" then
  77                         SS.empty
  78                     else
  79                         SS.singleton "int"),
  80                    SS.empty)
  81       | EString _ => ((SS.empty,
  82                        if Env.lookupType G "string" then
  83                            SS.empty
  84                        else
  85                            SS.singleton "string"),
  86                       SS.empty)
  87       | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
  88                           empty es
  89
  90       | ELam (x, to, e) =>
  91         let
  92             val G' = Env.bindVal G (x, dt, NONE)
  93         in
  94             case to of
  95                 NONE => expNeeded G' e
  96               | SOME t => unionCTE ((typNeeded G t, SS.empty),
  97                                     expNeeded G' e)
  98         end
  99       | EALam (x, p, e) =>
 100         let
 101             val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE)
 102         in
 103             unionCTE (((predNeeded G p, SS.empty), SS.empty),
 104                       expNeeded G' e)
 105         end
 106       | EVar x =>
 107         (case Env.lookupVal G x of
 108              NONE => ((SS.empty, SS.empty), SS.singleton x)
 109            | _ => empty)
 110       | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 111
 112       | ESkip => empty
 113       | ESet (_, e) => expNeeded G e
 114       | EGet (x, topt, _, e) =>
 115         (case topt of
 116              NONE => expNeeded (Env.bindVal G (x, dt, NONE)) e
 117            | SOME t => unionCTE ((typNeeded G t, SS.empty),
 118                                  expNeeded (Env.bindVal G (x, dt, NONE)) e))
 119       | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
 120                    empty es
 121       | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 122       | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 123       | EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
 124                                       unionCTE (expNeeded G e2,
 125                                                 expNeeded G e3))
 126
 127 fun declNeeded G (d, _, _) =
 128     case d of
 129         DExternType name => (Env.bindType G name, empty)
 130       | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
 131                                  (typNeeded G t, SS.empty))
 132       | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
 133                                case to of
 134                                    NONE => expNeeded G e
 135                                  | SOME t => unionCTE ((typNeeded G t, SS.empty),
 136                                                        expNeeded G e))
 137       | DContext name => (Env.bindContext G name, empty)
 138
 139 fun fileSig (_, ds, eo) =
 140     let
 141         val (G', needed) = foldl
 142                            (fn (d, (G, needed)) =>
 143                                let
 144                                    val (G', needed') = declNeeded G d
 145                                in
 146                                    (G', unionCTE (needed, needed'))
 147                                end)
 148                            (Env.empty, empty) ds
 149
 150         val needed =
 151             case eo of
 152                 NONE => needed
 153               | SOME e => unionCTE (needed,
 154                                     expNeeded G' e)
 155     in
 156         (((Env.contexts G', Env.types G'), Env.vals G'),
 157          needed)
 158     end
 159
 160 fun printSig ((cs, ts), vs) =
 161     (print "Contexts:";
 162      SS.app (fn s => (print " "; print s; print ";")) cs;
 163      print "\n   Types:";
 164      SS.app (fn s => (print " "; print s; print ";")) ts;
 165      print "\n  Values:";
 166      SS.app (fn s => (print " "; print s; print ";")) vs;
 167      print "\n")
 168
 169 val allNaughty = ref false
 170 val naughtyFiles = ref SS.empty
 171 fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
 172
 173 fun mergeProvide kind fname (m1, m2) =
 174     SS.foldl (fn (name, provide) =>
 175                  (case SM.find (provide, name) of
 176                       NONE => ()
 177                     | SOME fname' =>
 178                       (addNaughty fname;
 179                        addNaughty fname';
 180                        ErrorMsg.error NONE (String.concat ["Files ",
 181                                                            fname',
 182                                                            " and ",
 183                                                            fname,
 184                                                            " both provide ",
 185                                                            kind,
 186                                                            " ",
 187                                                            name]));
 188                   SM.insert (provide, name, fname)))
 189     m1 m2
 190
 191 fun order basisOpt fnames =
 192     let
 193         val () = allNaughty := false
 194         val () = naughtyFiles := SS.empty
 195
 196         fun doFile (fname, (provideC, provideT, provideV, require)) =
 197             let
 198                 val file = Parse.parse fname
 199                 val (((provideC', provideT'), provideV'),
 200                      require') = fileSig file
 201             in
 202                 (mergeProvide "context" fname (provideC, provideC'),
 203                  mergeProvide "type" fname (provideT, provideT'),
 204                  mergeProvide "value" fname (provideV, provideV'),
 205                  SM.insert (require, fname, require'))
 206             end
 207
 208         val (provideC, provideT, provideV, require) =
 209             foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
 210
 211         val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
 212                                   let
 213                                       fun consider (kind, provide, lastChance) =
 214                                           SS.foldl (fn (name, need) =>
 215                                                        case SM.find (provide, name) of
 216                                                            NONE =>
 217                                                            if lastChance name then
 218                                                                need
 219                                                            else
 220                                                                (addNaughty fname;
 221                                                                 ErrorMsg.error NONE
 222                                                                                ("File "
 223                                                                                 ^ fname
 224                                                                                 ^ " uses undefined "
 225                                                                                 ^ kind
 226                                                                                 ^ " "
 227                                                                                 ^ name);
 228                                                                 need)
 229                                                          | SOME fname' =>
 230                                                            SS.add (need, fname'))
 231
 232                                       val need = consider ("context", provideC,
 233                                                            case basisOpt of
 234                                                                NONE => (fn _ => false)
 235                                                              | SOME b => Env.lookupContext b)
 236                                                           SS.empty rc
 237                                       val need = consider ("type", provideT,
 238                                                            case basisOpt of
 239                                                                NONE => (fn _ => false)
 240                                                              | SOME b => Env.lookupType b)
 241                                                           need rt
 242                                       val need = consider ("value", provideV,
 243                                                            case basisOpt of
 244                                                                NONE => (fn _ => false)
 245                                                              | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
 246                                                           need rv
 247                                   in
 248                                       need
 249                                   end) require
 250
 251         fun loop (ready, waiting, order) =
 252             case SS.find (fn _ => true) ready of
 253                 NONE =>
 254                 if SM.numItems waiting = 0 then
 255                     rev order
 256                 else
 257                     (allNaughty := true;
 258                      ErrorMsg.error NONE "Cyclic dependency in source files";
 259                      order)
 260               | SOME next =>
 261                 let
 262                     val (ready', waiting') =
 263                         SM.foldli (fn (fname, requires, (ready', waiting')) =>
 264                                       let
 265                                           val requires' = SS.delete (requires, next)
 266                                               handle NotFound => requires
 267                                       in
 268                                           if SS.numItems requires' = 0 then
 269                                               (SS.add (ready', fname),
 270                                                waiting')
 271                                           else
 272                                               (ready',
 273                                                SM.insert (waiting', fname, requires'))
 274                                       end)
 275                                   (SS.delete (ready, next), SM.empty) waiting
 276                 in
 277                     loop (ready', waiting', next :: order)
 278                 end
 279
 280         val (ready, waiting) =
 281             SM.foldli (fn (fname, requires, (ready, waiting)) =>
 282                           if SS.numItems requires = 0 then
 283                               (SS.add (ready, fname),
 284                                waiting)
 285                           else
 286                               (ready,
 287                                SM.insert (waiting, fname, requires)))
 288                       (SS.empty, SM.empty) require
 289
 290         val ordered = loop (ready, waiting, [])
 291         val provider = {provideC = provideC,
 292                         provideT = provideT,
 293                         provideV = provideV}
 294     in
 295         if !allNaughty then
 296             (provider, [])
 297         else if SS.isEmpty (!naughtyFiles) then
 298             (provider, ordered)
 299         else
 300             order basisOpt (List.filter (fn fname => not (SS.member (!naughtyFiles, fname))) fnames)
 301     end
 302
 303 val order = fn basisOpt => fn fnames =>
 304                               let
 305                                   val (providers, fnames) = order basisOpt fnames
 306
 307                                   val (hasLib, fnames) = foldl (fn (fname, (hasLib, fnames)) =>
 308                                                                    if OS.Path.file fname = "lib.dtl" then
 309                                                                        (SOME fname, fnames)
 310                                                                    else
 311                                                                        (hasLib, fname :: fnames))
 312                                                                (NONE, []) fnames
 313
 314                                   val fnames = rev fnames
 315                                   val fnames = case hasLib of
 316                                                    NONE => fnames
 317                                                  | SOME hasLib => hasLib :: fnames
 318                               in
 319                                   (providers, fnames)
 320                               end
 321
 322 type providers = {provideC : string SM.map,
 323                   provideT : string SM.map,
 324                   provideV : string SM.map}
 325
 326 fun providesContext (p : providers, s) = SM.find (#provideC p, s)
 327 fun providesType (p : providers, s) = SM.find (#provideT p, s)
 328 fun providesValue (p : providers, s) = SM.find (#provideV p, s)
 329
 330 end