SpadEnvironment.spad

)abbrev domain SPENV SpadEnvironment
SpadEnvironment() : Exports == Implementation where
)include SpadTypeDefs.inc

  MEMBER ==> Record(key : EKEY, entry : EVAL)
  SCOPE ==> HashTable(EKEY, EVAL, "UEQUAL")

  Exports ==> SpadEnvCategory with
    coerce : SCOPE -> PF
    coerce : EKEY -> N

  Implementation ==> add
    Rep := List SCOPE

    import Printer
    import Logger('Env)
    import SpadNodeFactory
    import SpadNodeTools
    import SpadLogic(%)
    import SpadTypeEvaluator(%)

    -- create empty environment
    new() ==
      imported := ["imported", [null, []]]$MEMBER
      [[[imported]]$SCOPE]

    keyOf (n : N) : EKEY ==
      symbol? n => n :: Symbol
      not? n => keyOf (n :: APP).args.1
      apply? n => n :: APP
      typeHas? n => keyOf((n :: TEH).expr)
      typeIs? n => keyOf((n :: TEI).expr)
      case? n => keyOf((n :: SC).expr)
      fail ["not a valid environment key:" :: PF, bold(n :: PF)]
      error "keyOf $ SpadEnvironment"

    coerce (key : EKEY) : N ==
      key case APP => [key :: APP]
      key case Symbol => [key :: Symbol]
      key case "imported" => ["%imported"]

    typesOf (key : EKEY, env : %) : List(N) ==
      val := search(key, env)
      (val case EVAL => val.type :: List(N); [])

    factsAbout (key : EKEY, env : %) : List(N) ==
      val := search(key, env)
      (val case EVAL => val.facts; [])

    addType (t : N, env : %) : Void ==
      apply? t =>
        app := t :: APP
        addDomain(app, env)
        for k in app.args repeat
          addType(k, env)
        importDomain(app, env)

      mappingType? t =>
        mt := t :: MT
        for k in [mt.result, :mt.args] repeat
          addType(k, env)

      recordType? t =>
        rt := t :: RT
        for f in fields rt repeat
          addType(f.type, env)
        for f in makeRecordFunList t repeat
          addTypeOf(f.expr :: Symbol, nodeTypeOrigin(f.type, t), env)

      unionType? t =>
        ut := t :: UT
        for v in variants ut repeat
          if typeDecl? v then
            v := (v :: TD).type
          addType(v, env)
        for f in makeUnionFunList t repeat
          addTypeOf(f.expr :: Symbol, nodeTypeOrigin(f.type, t), env)

      symbol? t =>
        -- BUG! this is not correct but will do for time being
        ts := typesOf(t :: Symbol, env)
        -- detect type alias
        #ts = 1 and typeValue? ts.1 =>
          tv := ts.1 :: TVL
          addType(tv.value, env)

      string? t => void

      fail ["Type" :: PF, bold(t :: PF), "not handled!" :: PF]
      error "addType $ SpadEnvironment"

    fetchType (key : EKEY, env : %) ==
      val := search(key, env)
      val case "failed" =>
        key case APP => getTypeInfo(key :: APP, env)
        key case Symbol => "failed"
      val case EVAL =>
        typeInfo? val.type => val.type :: TI
        "failed"

    addTypeOf (key : EKEY, type : N, env : %) : Void ==
      val := search(key, env)
      val case "failed" =>
        env(key) := [nodeList [type], []]
      val case EVAL =>
        list? val.type =>
          types := val.type :: List(N)
          not member?(type, types) =>
            val.type := nodeList [type, :types]
        fail [bold(key :: PF), "has been already defined!" :: PF]
        error "addTypeOf $ SpadEnvironment"

    addFactAbout (key : EKEY, fact : N, env : %) : Void ==
      val := search(key, env)
      val case "failed" =>
        env(key) := [nodeList [], [fact]]
      val case EVAL =>
        not member?(fact, val.facts) =>
          val.facts := [fact, :val.facts]

    addFacts (n : N, env : %) : Void ==
      for p in extractPredicates n repeat
        addFactAbout(keyOf p, p, env)

    importDomain (dom : EKEY, env : %) : Void ==
      key := dom :: N
      imported := env("imported").facts
      member?(key, imported) => void

      notice ["Importing" :: PF, bold(dom :: PF), "domain" :: PF]
      ti? := search(dom, env)
      ti? case "failed" => error "importDomain $ SpadEnvironment"
      ti := (ti? :: EVAL).type :: TI
      for n in ti.body.list repeat
        n' := substitute(n, typeVar() :: TV, key)
        guard := null
        if typeGuard? n' then
          tg := n' :: TG
          n' := tg.expr
          guard := tg.type
        if typeOrigin? n' then
          to := n' :: TO
          n' := to.expr
        td := n' :: TD
        n' := nodeTypeOrigin(td.type, key)
        if not null? guard then
          n' := nodeTypeGuard(n', guard)
        addTypeOf(td.expr :: Symbol, n', env)
      env("imported") := [null, [key, :imported]]

    addDomain (dom : APP, env : %) : Void ==
      key? (dom, env) => env
      notice ["Adding type" :: PF, bold (dom :: PF), "to the environment!" :: PF]
      ti := getTypeInfo(dom, env)
      env(dom) := [[ti], []]

    addDomainAs (dom : APP, name : Symbol, env : %) : Void ==
      key? (name, env) => env
      notice(["Adding" :: PF, bold (dom :: PF), "as" :: PF, bold (name :: PF), 
              "to the environment!" :: PF])
      ti := getTypeInfo(dom, env)
      env(name) := [[ti], [nodeTypeHas([name], [dom])]]

    empty? (env : %) : Boolean ==
      empty?(env)$Rep

    search (key : EKEY, env : %) : Union(EVAL, "failed") ==
      empty? env => "failed"
      top := first env
      -- 1) if the symbol is found at first level the return it
      result := search(key, top)
      result case EVAL => result
      -- 2) if it is found deeper then (deep-)copy it to top level and return it
      for level in rest env repeat
        result := search(key, level)
        result case EVAL =>
          value := result :: EVAL
          value' := [copy value.type, [copy n for n in value.facts]]$EVAL
          top(key) := value'
          return value'
      -- 3) not found :(
      "failed"

    elt (env : %, key : EKEY) : EVAL ==
      val := search(key, env)
      val case EVAL => val
      fail [string bold(key :: PF), "not found in the environment!" :: PF]
      error ""

    setelt! (env : %, key : EKEY, val : EVAL) : % ==
      top := first env
      top(key) := val
      env

    flatten (env : %) : % ==
      empty? env => new()
      newenv : SCOPE := empty()
      for level in env repeat
        for e in members(level)@List(MEMBER) repeat
          if not key?(e.key, newenv) then
            newenv(e.key) := e.entry
      [newenv]

    createScope env ==
      cons(empty(), env)

    discardScope env ==
      rest env

    merge (env : %, left : %, right : %) : % ==
      top := [k :: Symbol for k in keys first env | k case Symbol]
      lks := [k :: Symbol for k in keys first left | k case Symbol]
      rks := [k :: Symbol for k in keys first right | k case Symbol]
      for k in setIntersection(lks, rks) | not member?(k, top) repeat
        lv := left(k) :: EVAL
        rv := right(k) :: EVAL
        fs := setIntersection(lv.facts, rv.facts)
        lv.type = rv.type => env(k) := [lv.type, fs]
        list? lv.type and list? rv.type =>
          ts := setUnion(lv.type :: List(N), rv.type :: List(N))
          env(k) := [nodeList ts, fs]
        not list? lv.type and not list? rv.type =>
          env(k) := [nodeUnionType [lv.type, rv.type], fs]
      env

    coerce (key : EKEY) : PF == key :: N :: PF

    coerce (val : EVAL) : PF ==
      fs := [f :: PF for f in val.facts]
      empty? fs =>
        pile [cyan("type:" :: PF), val.type :: PF]
      vconcat([pile [cyan("type:" :: PF), val.type :: PF],
               pile [cyan("facts:" :: PF), :fs]])
      
    coerce (scope : SCOPE) : PF ==
      entries : List(PF) := []
      empty? scope => "()" :: PF
      for e in members(scope)@List(MEMBER) repeat
        sym := hconcat [bold cyan(e.key :: PF), ":" :: PF]
        entries := [pile [sym, e.entry :: PF], :entries]
      vconcat reverse entries

    coerce (env : %) : PF ==
      empty? env => "()" :: PF
      (first flatten env) :: PF

)abbrev domain SPENVT SpadEnvironmentTest
SpadEnvironmentTest() : Exports == Implementation where
)include SpadTypeDefs.inc

  Exports ==> with
    test1 : () -> Void
    test2 : () -> Void
    test3 : () -> Void

  Implementation ==> add
    import SpadEnvironment
    import SExpression
    import SpadNode
    import SpadNodeFactory
    import Printer
    import MainLogger

    test1 () ==
      loggerDefaultLevel "info"
      resetTime()

      env := new()
      dom1 := [['Integer], []] $ APP
      dom2 := [['List], [['Integer]]] $ APP
      addDomain(dom1, env)
      addDomain(dom2, env)
      println (env :: PF)

    test2 () ==
      loggerDefaultLevel "info"
      resetTime()

      env := new()
      dom0 := [['Polynomial], [null]] $ APP
      dom1 := [['Polynomial], [nodeApp(['Integer], [])]] $ APP
      dom2 := [['Integer], []] $ APP
      addDomain(dom0, env)
      addDomain(dom1, env)
      addDomain(dom2, env)
      modemaps := typesOf('*, env)
      println pile([hconcat [bold cyan ("*" :: PF), ":" :: PF],
                    :[(modemap :: PF) for modemap in modemaps]])