src/order.sml

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