~plan/plunder

63ee53645bf074e8c18c3ed32a2d55e3f3fb5493 — Sol 4 months ago 7512dcf
sire: fix Sire AST mismatch + (vice: #case works)

There were a couple of cases where the noun-representation of Sire ASTs
didn't match the one uses in sire-in-sire:

-   The Haskell version pre-computed whether-or-not each function is
    recursive and saved that on each function (to avoid re-computing
    during inline).  We update the sire code to match.

-   The Haskell version flattened (F (LAM ...)) nodes to [%F ...].
    This was more compact but more complicated to work with.  We update
    the Haskell version to remove the optimization.

-   The Haskell version unpacked variables, so that they are represented
    as `3` instead of `[%V 3]`.  This is more compact and easier to
    read, but more complicated to work with.  We update the Haskell version
    to remove the optimization.

In addition to that, this extends the syntax of Viceroy to support
`#case` expressions.  This is not fully complete, and doesn't yet support
type-checking, but small examples are working.
M lib/Sire.hs => lib/Sire.hs +31 -25
@@ 96,39 96,45 @@ getRow :: Any -> Maybe (Array Any)
getRow (ROW x) = Just x
getRow _       = Nothing

getLam :: Any -> Any -> Any -> Any -> Any -> Any -> Lam
getLam pinnedBit inlinedBit cycBit tagNat argsNat bodyVal =
    let
        !pin  = getBit pinnedBit  "pinned"
        !mark = getBit inlinedBit "inline"
        !body = getSyr bodyVal
        !recr = getBit cycBit     "is recurisve"
        !tag  = getNat tagNat     "lambda tag"
        !args = getNat argsNat    "lambda args"
    in
        LAM{pin,mark,body,args,tag,recr}
getLam :: Any -> Lam
getLam record =
    fromMaybe (error badRec) $ do
        params <- getRow record
        case toList params of
            [p,m,r,t,a,b] -> Just
                let
                    !pin  = getBit p "pinned"
                    !mark = getBit m "inline"
                    !body = getSyr b
                    !recr = getBit r "is recurisve"
                    !tag  = getNat t "lambda tag"
                    !args = getNat a "lambda args"
                in
                    LAM{pin,mark,body,args,tag,recr}
            _ -> Nothing
  where
    getBit (NAT 0) _  = False
    getBit (NAT 1) _  = True
    getBit (NAT n) cx = error (badBit cx $ show n)
    getBit val     cx = error (badBit cx $ show val)
    badRec = "bad Lambda Record:\n\n" <> unpack (planText record)

    badBit cx txt =
        "bad flag when reading lambda from state: " <> cx <> " " <> txt

    getBit (NAT 0) _  = False
    getBit (NAT 1) _  = True
    getBit val     cx = error (badBit cx $ show val)

getSyr :: Any -> Sire
getSyr (NAT n) = V n
getSyr topVal  = fromMaybe (error $ "bad Sire AST:\n\n" <> unpack (planText topVal)) do
getSyr topVal = fromMaybe (error $ "bad Sire AST:\n\n" <> unpack (planText topVal)) do
    params <- getRow topVal
    case toList params of
        [NAT "G", x]           -> Just $ G (getBinding "glo" x)
        [NAT "K", x]           -> Just $ K x
        [NAT "A", f, x]        -> Just $ A (getSyr f) (getSyr x)
        [NAT "L", v, b]        -> Just $ L (getSyr v) (getSyr b)
        [NAT "R", v, b]        -> Just $ R (getBinds v) (getSyr b)
        [NAT "F", p,i,c,t,a,b] -> Just $ F $ getLam p i c t a b
        [NAT "M", x]           -> Just $ M (getSyr x)
        _                      -> Nothing
        [NAT "V", NAT n] -> Just $ V n
        [NAT "G", x]     -> Just $ G (getBinding "glo" x)
        [NAT "K", x]     -> Just $ K x
        [NAT "A", f, x]  -> Just $ A (getSyr f) (getSyr x)
        [NAT "L", v, b]  -> Just $ L (getSyr v) (getSyr b)
        [NAT "R", v, b]  -> Just $ R (getBinds v) (getSyr b)
        [NAT "F", l]     -> Just $ F (getLam l)
        [NAT "M", x]     -> Just $ M (getSyr x)
        _                -> Nothing
  where
    getBinds :: Fan -> [Sire]
    getBinds (ROW bs) = toList (getSyr <$> bs)

M lib/Sire/Types.hs => lib/Sire/Types.hs +4 -10
@@ 107,28 107,22 @@ mkNewBind d =
sireNoun :: Sire -> Any
sireNoun = go
  where
    goLam :: Lam -> [Any]
    goLam l = [ toNoun l.pin
              , toNoun l.mark
              , toNoun l.recr
              , toNoun l.tag
              , toNoun l.args
              , go l.body
              ]
    goLam :: Lam -> Any
    goLam l = toNoun (l.pin, l.mark, l.recr, l.tag, l.args, go l.body)

    goBinds :: [Sire] -> Any
    goBinds = ROW . fromList . map go

    go :: Sire -> Any
    go = \case
        V n   -> NAT n
        V n   -> ROW $ arrayFromListN 2 ["V", NAT n]
        K n   -> ROW $ arrayFromListN 2 ["K", n]
        G b   -> ROW $ arrayFromListN 2 ["G", b.noun]
        A f x -> ROW $ arrayFromListN 3 ["A", go f, go x]
        L v b -> ROW $ arrayFromListN 3 ["L", go v, go b]
        R v b -> ROW $ arrayFromListN 3 ["R", goBinds v, go b]
        M x   -> ROW $ arrayFromListN 2 ["M", go x]
        F l   -> ROW $ arrayFromListN 7 ("F" : goLam l)
        F l   -> ROW $ arrayFromListN 2 ["F", goLam l]

lamRex :: Lam -> Rex
lamRex l =

M sire/sire_26_compile.sire => sire/sire_26_compile.sire +25 -23
@@ 37,11 37,12 @@

# record Lam
| LAM
* pin    : Bit
* inline : Bit
* tag    : Nat
* args   : Nat
* body   : Sire
* pin  : Bit
* mark : Bit
* recr : Bit
* tag  : Nat
* args : Nat
* body : Sire

# data Sire -legible
- V Nat


@@ 101,9 102,9 @@ appList=(listFoldl A)
=?= 1 | hasRefTo 0 | L (V 0) (V 0)
=?= 1 | hasRefTo 0 | R [(K 7)] (V 1)
=?= 1 | hasRefTo 0 | R [(V 1)] (V 0)
=?= 1 | hasRefTo 0 | F | LAM 0 0 0 2 (V 3)
=?= 0 | hasRefTo 0 | F | LAM 0 0 0 2 (V 2)
=?= 1 | hasRefTo 0 | F | LAM 0 0 0 2 | A (V 3) (V 2)
=?= 1 | hasRefTo 0 | F | LAM 0 0 0 0 2 (V 3)
=?= 0 | hasRefTo 0 | F | LAM 0 0 0 0 2 (V 2)
=?= 1 | hasRefTo 0 | F | LAM 0 0 0 0 2 | A (V 3) (V 2)

> Nat > Nat > Nat > Sire > Sire
= (moveTo from to alreadyBound topExp)


@@ 118,16 119,16 @@ appList=(listFoldl A)
- F fn  | F (setBody (go _ getBody-fn) fn)^(inc | add l getArgs-fn)
- _     | e

=?= (V 3)                 | moveTo 0 3 0 | V 0
=?= (V 2)                 | moveTo 1 3 0 | V 0
=?= (L (K 9) (V 0))       | moveTo 1 3 0 | L (K 9) (V 0)
=?= (L (K 9) (V 3))       | moveTo 1 3 0 | L (K 9) (V 1)
=?= (L (K 9) (V 4))       | moveTo 0 3 0 | L (K 9) (V 1)
=?= (V 0)                 | moveTo 0 3 1 | V 0
=?= (F | LAM 0 0 0 1 V-0) | moveTo 0 3 0 | F (LAM 0 0 0 1 V-0)
=?= (F | LAM 0 0 0 1 V-1) | moveTo 0 3 0 | F (LAM 0 0 0 1 V-1)
=?= (F | LAM 0 0 0 1 V-5) | moveTo 0 3 0 | F (LAM 0 0 0 1 V-2)
=?= (F | LAM 0 0 0 1 V-6) | moveTo 0 3 0 | F (LAM 0 0 0 1 V-3)
=?= (V 3)                   | moveTo 0 3 0 | V 0
=?= (V 2)                   | moveTo 1 3 0 | V 0
=?= (L (K 9) (V 0))         | moveTo 1 3 0 | L (K 9) (V 0)
=?= (L (K 9) (V 3))         | moveTo 1 3 0 | L (K 9) (V 1)
=?= (L (K 9) (V 4))         | moveTo 0 3 0 | L (K 9) (V 1)
=?= (V 0)                   | moveTo 0 3 1 | V 0
=?= (F | LAM 0 0 0 0 1 V-0) | moveTo 0 3 0 | F (LAM 0 0 0 0 1 V-0)
=?= (F | LAM 0 0 1 0 1 V-1) | moveTo 0 3 0 | F (LAM 0 0 1 0 1 V-1)
=?= (F | LAM 0 0 0 0 1 V-5) | moveTo 0 3 0 | F (LAM 0 0 0 0 1 V-2)
=?= (F | LAM 0 0 0 0 1 V-6) | moveTo 0 3 0 | F (LAM 0 0 0 0 1 V-3)

= (renum d !n args)
: a@(ARG ad ax) as < listCase args NIL


@@ 164,12 165,12 @@ appList=(listFoldl A)
- M b
    @ @(RES r me) | inline d s ~[] b
    | rap | RES r (fmapMaybe me | setEMark TRUE)
- F (lam@(LAM _ lMark _ lArgs lBody))
- F (lam@(LAM _ lMark lRecr _ lArgs lBody))
    | rap
    | RES @ s | listWeld (listRep NONE inc-lArgs) s
           @ d | inc (add lArgs d)
           | F | (setBody _ lam)^(getOut | inline d s ~[] lBody)
    | if (hasRefTo lArgs lBody) NONE
          @ d | inc (add lArgs d)
          | F | (setBody _ lam)^(getOut | inline d s ~[] lBody)
    | if lRecr NONE
    | SOME (POT lam lMark d lArgs ~[])
- R vs b
    @ nBinds (len vs)


@@ 290,7 291,7 @@ appList=(listFoldl A)
             @ [[env nex] vr] (ing ss vx st)
             | [(tabPut env k vr) nex]
    | ing ss b st
- F lam @ @(LAM pin _ tag lArg lBod) lam
- F lam @ @(LAM pin _mark _rec tag lArg lBod) lam
        @ slf           | nex
        @ !nex          | inc nex
        @ arg           | listGen lArg (add nex)


@@ 423,6 424,7 @@ three=3
^-^ LAM
^-^ V K G A L R M F
^-^ BIND getBindKey getBindValue getBindCode getBindLocation getBindName
^-^ hasRefTo
^-^
^-^ evalSire
^-^ apple apple_ appList

M sire/sire_27_sire.sire => sire/sire_27_sire.sire +9 -5
@@ 336,7 336,7 @@ ss=(SIRE_STATE 5 {repl} (tabSing %zaz {ZAZBIND}) #[])
    @ env2            ^ listWeld _ env
                      | listRev (NONE :: listFromRow (map SOME argNames))
    : st body         < replOpen (readExpr env2 bodRex) st
    | (st, F (LAM FALSE FALSE 0 nArgs body))
    | (st, F (LAM FALSE FALSE FALSE 0 nArgs body))
* 3
    @ [tagRex sigRex bodRex] | kids
    : st tag                 < replOpen (readKey tagRex) st


@@ 345,7 345,7 @@ ss=(SIRE_STATE 5 {repl} (tabSing %zaz {ZAZBIND}) #[])
    @ env2                   ^ listWeld _ env
                             | listRev (NONE :: listFromRow (map SOME argNames))
    : st body                < replOpen (readExpr env2 bodRex) st
    | (st, F (LAM FALSE FALSE tag nArgs body))
    | (st, F (LAM FALSE FALSE FALSE tag nArgs body))
* _
    | ({expected two or three params}, rex)



@@ 374,6 374,10 @@ ss=(SIRE_STATE 5 {repl} (tabSing %zaz {ZAZBIND}) #[])
: st (inl,nam) < replOpen (readFuncHead fst-kids) st
| (st, (inl, nam, args))

= (mkF pin mark tag numArgs body)
@ isRecur (hasRefTo numArgs body)
| F (LAM pin mark isRecur tag numArgs body)

= (readLam pinned readExpr env rex st)
@ rune (rexRune rex)
@ kids (rexKids rex)


@@ 385,7 389,7 @@ ss=(SIRE_STATE 5 {repl} (tabSing %zaz {ZAZBIND}) #[])
           | listRev | listMap SOME (f :: listFromRow argNames)
    @ nArg | len argNames
    : st body < replOpen (readExpr env2 bodRex) st
    | (st, F (LAM pinned inline f nArg body))
    | (st, mkF pinned inline f nArg body)
* 3
    @ [tagRex sigRex bodRex] kids
    : st tag                     < replOpen (readKey tagRex)    st


@@ 394,7 398,7 @@ ss=(SIRE_STATE 5 {repl} (tabSing %zaz {ZAZBIND}) #[])
           | listRev | listMap SOME (f :: listFromRow argNames)
    @ nArg | len argNames
    : st body < replOpen (readExpr env2 bodRex) st
    | (st, F (LAM pinned inline tag nArg body))
    | (st, mkF pinned inline tag nArg body)
* _
    | ({expected two or three params}, rex)



@@ 548,7 552,7 @@ ss=(SIRE_STATE 5 {repl} (tabSing %zaz {ZAZBIND}) #[])
- RIGHT [[doInline tagName] argNames]
    @ nArgs (len argNames)
    | TO_BIND key mProp tagName
    | F | LAM TRUE doInline tagName nArgs bodyExpr
    | mkF TRUE doInline tagName nArgs bodyExpr

> Rex > Maybe (Bit, Nat)
= (tryReadSigHead rex)

M sire/type_syntax.sire => sire/type_syntax.sire +4 -2
@@ 161,8 161,7 @@
@ rune (rexRune rex)
| ifz rune
    | err rex {Expected symbol or rune}
# switch rune
* {|}
@ tyApp
    @ kids (rexKids rex)
    @ head (idx 0 kids)
    @ para (drop 1 kids)


@@ 174,6 173,9 @@
        | err head {expected: TypeName}
    : params < rowTraverse loop para
    | ok (T_REF sym params)
# switch rune
* {|} tyApp
* {-} tyApp
* {>}
    @ style (rexStyle rex)
    : kidTypes < rowTraverse loop (rexKids rex)

M sire/viceroy.sire => sire/viceroy.sire +164 -54
@@ 30,17 30,7 @@
;;;; DONE Code using #data-generate constructors runs and typechecks.
;;;; DONE Codegen for switch.
;;;;
;;;; TODO Datatypes store metadata in props
;;;;
;;;;     constructor=[%tag1 (PIN [(Type a) %tag1 FOO [Nat Nat] %tag2 BAR [a]])]
;;;;
;;;;     = constructor
;;;;     ^ [%tag1 (PIN _)]
;;;;     + (0, (Type 0))
;;;;     + %tag1 FOO [Nat Nat]
;;;;     + %tag2 BAR [0]
;;;;
;;;; TODO Codegen for case-on-ADT (simple ADT shapes only)
;;;; DONE Codegen for case-on-ADT (simple ADT shapes only)
;;;;
;;;;     (Exp, Map Nat (Row Str, Exp))
;;;;


@@ 53,13 43,38 @@
;;;;     * k1 b1 ; in appropriate namespace given field patterns.
;;;;     * k2 b2
;;;;
;;;; TODO Parsing for simple {#case} expressions
;;;; DONE Parsing for simple {#case} expressions
;;;;
;;;;     # case expr
;;;;     - FOO       | b0
;;;;     - BAR x y z | b1
;;;;     - ZAZ x y   | b2
;;;;
;;;; TODO Datatypes store metadata in props
;;;;
;;;;     constructor=[%tag1 (PIN [(Type a) %tag1 FOO [Nat Nat] %tag2 BAR [a]])]
;;;;
;;;;     = constructor
;;;;     ^ [%tag1 (PIN _)]
;;;;     + (0, (Type 0))
;;;;     + %tag1 FOO [Nat Nat]
;;;;     + %tag2 BAR [0]
;;;;
;;;; TODO Write code to lookup information about constructors.
;;;;
;;;; TODO Add support for a fallback case to the parser.
;;;; TODO Add support for a fallback case to the code generator.
;;;; TODO Validate that all branches of a #case are from the same ADT.
;;;; TODO Validate that the number of fields of each branch matches the ADT.
;;;; TODO Validate that all branches of an ADT are handled.
;;;; TODO Validate that no two branches of a #case are the same constructor.
;;;; TODO Validate that ADT-branch field names are not repeated (per branch).
;;;; TODO Validate that the scrutinee has the same type as the ADT.
;;;; TODO Collect the field-types associated with each field-binding.
;;;; TODO Construct the type-environment for the body of each branch.
;;;; TODO Typecheck the body of each branch.
;;;; TODO Unify the types of all of the branches (and the fallback)
;;;;
;;;; TODO Multi-Assertion Blocks
;;;; TODO Multi-Command Blocks
;;;; TODO Multi-Bind Commands


@@ 93,11 108,12 @@

;;; Imports ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

:| sire_26_compile
:| sire
:| type_machinery
:| types
:| plan [try]
:| sire_26_compile ;
:| sire            ;
:| type_machinery  ;
:| types           ;
:| plan            [try]
:| sire_27_sire    [mkF]


;;; Types ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


@@ 110,17 126,21 @@
- TTUP Row-Typ
- TDAT Type

# typedef (CaseBranchE e) (Str, Nat, Row Maybe-Str, e)

# data Exp -legible
- EADD Exp Exp
- EBIT Bit
- ENAT Nat
- EEQL Exp Exp
- EREF Nat
- EREF Str
- EAPP Exp Exp
- ETUP Row-Exp
- ECAS Exp (Tab Nat (Row Maybe-Str, Exp))
- ELET nm/Str vTy/Type v/Exp b/Exp
- EFUN inline/Bit pin/Bit nm/Str Row-(Exp,Type) rTy/Type b/Exp
- ECAS Exp Row-(CaseBranch Exp)
- ELET nm/Str vTy/Typ v/Exp b/Exp
- EFUN inline/Bit pin/Bit nm/Str Row-(Exp,Typ) rTy/Typ b/Exp

# typedef CaseBranch (CaseBranchE Exp)

# typedef Constructor (Str, Row Typ)



@@ 346,6 366,48 @@ abstype#(Bst k v)
@ (!nm, !ty)           | readTypedSym name
| ELET nm ty (readExp val) (readExp body)

> _ > Rex > (Str, Row Maybe-Str, Exp)
= (readCaseBranch readExp rex)
@ rune (rexRune rex)
@ kids (rexKids rex)    ;;  TODO: This needs to validate lengths
@ nKid (len kids)       ;;  TODO: Good err-msg in case of non-hep items
@ last dec-nKid
@ patSyms | map readSym (take last kids)
@ body    | readExp (idx last kids)
@ cnstr   | idx 0 patSyms
@ fields  | foreach (drop 1 patSyms) n&(if n=="_" NONE SOME-n)
| (cnstr, fields, body)

> Str > Nat
(lookupCnstrTag sym)=sym

> _ > Rex > (Str, Nat, Typ, Row Maybe-Str, Exp)
= (readCaseBranches readExp rex)
: item      < foreach | listToRow | tarSeq {-} rex
@ [cn fs b] | readCaseBranch readExp item
@ tag       | lookupCnstrTag cn
| (cn, tag, fs, b)

(traceShowIdWith tag x)=(trk [tag x] x)
(traceShowId x)=(trk x x)

= (readExpKeyword readExp rex)
@ kids@[keywordRex] | rexKids rex
@ nKids             | len kids
@ keyword           | readSym keywordRex
| ifz nKids         | failStr rex {empty # rune}
# switch keyword
* _
    | failStr rex (strWeld {unknown keyword: } keyword)
* {case}
    @ [_ scrutRex branchesRex] kids
    | if (nKids /= 3)
        | failStr rex {#case expects three params}
    | traceShowIdWith "HERE"
    | ECAS
    * readExp scrutRex
    * readCaseBranches readExp branchesRex

= (readExp rex)
# switch (rexType rex)
* {EMBD} | failStr rex {embeded PLAN values are not accepted}


@@ 361,6 423,7 @@ abstype#(Bst k v)
         * {&}  | readAnonLambda readExp rex
         * {?}  | readNamedLambda FALSE readExp rex
         * {??} | readNamedLambda TRUE readExp rex
         * {#}  | readExpKeyword readExp rex
         * _    | failStr rex {unknown rune}

= (readBind rex)


@@ 398,7 461,7 @@ abstype#(Bst k v)
= (readConstructors rex)
| map readConstructor | listToRow | tarSeq {-} rex

= (readKeyword rex)
= (readCmdKeyword rex)
@ kids@[keywordRex] | rexKids rex
@ nKids             | len kids
@ keyword           | readSym keywordRex


@@ 412,14 475,15 @@ abstype#(Bst k v)
    @ !typeName (readSym typeNameRex)
    @ !cnstrs   (readConstructors cnstrsRex)
    | DATA typeName cnstrs

* _
    | EVAL (readExp rex)

= (readCmd rex)
# switch (rexRune rex)
* {=}   | readBind rex
* {=?=} | readAssertEql rex
* {!!}  | readAssert rex
* {#}   | readKeyword rex
* {#}   | readCmdKeyword rex
* _     | EVAL (readExp rex)




@@ 516,17 580,20 @@ abstype#(Bst k v)
;;;
;;; -   for each branch, A row of names corresponding to these binds.

> Tab Nat (Row (Maybe Str), Exp) > Set Nat
; TODO: these need to be special-cased for one-element ADTs (which have
; no tag).

> Row CaseBranch > Set Nat
= (caseSlots branches)
^ foldl _ %[] (tabValsRow branches)
& (need branch@(fields, exp))
^ foldl _ %[] branches
& (need branch@(_c, _t, fields, _))
^ setWeld need (setFromRow | catMaybes _)
: [i [mf _]] < foreach (rowIndexed fields)
| ifz mf NONE (SOME i)

> Sire
> Tab Nat (Row (Maybe Str), a)
> (Row Sire, Tab Nat (Row (Maybe Str)))
> Row CaseBranch
> (Row Sire, Row (Row Maybe-Str))
= (caseBinds adtSire branches)
@ slots    | caseSlots branches
@ numBinds | inc (setLen slots)


@@ 535,35 602,36 @@ abstype#(Bst k v)
    : [bindNum fieldIx] < listForEach (listIndexed | setToList slots)
    | A K-(idx | inc fieldIx) V-(inc bindNum)
++
    ^ tabMap _ branches
    & (fields, expr)
    ^ map _ branches
    & (_c, _t, fields, expr)
    | sizedListToRow numBinds
    | (NONE :: listMap (get fields) (setToList slots))

; type CaseBranch (Str, Nat, Row Maybe-Str, Exp)

=?= %[1 2 4]
  | caseSlots ## =3 ([NONE SOME-{x} SOME-{y}], EREF-{y})
              ## =9 ([NONE NONE NONE NONE SOME-{z}], EREF-{z})
  | caseSlots ++ ("FOO", 3, [0 SOME-{x} SOME-{y}], EREF-{y})
              ++ ("BAR", 9, [0 0 0 0 SOME-{z}], EREF-{z})

=?=  ++   ++ K {lol}
          ++ A K-(idx 2) V-1
          ++ A K-(idx 3) V-2
          ++ A K-(idx 5) V-3
     ++   ## =3 [0 SOME-{x} SOME-{y} 0]
          ## =9 [0 0 0 SOME-{z}]
     ++   ++ [0 SOME-{x} SOME-{y} 0]
          ++ [0 0 0 SOME-{z}]
  | caseBinds K-{lol}
 ## =3 ([NONE SOME-{x} SOME-{y}], EREF-{y})
 ## =9 ([NONE NONE NONE NONE SOME-{z}], EREF-{z})
 ++ ("FOO", 3, [0 SOME-{x} SOME-{y}], EREF-{y})
 ++ ("FOO", 9, [0 0 0 0 SOME-{z}], EREF-{z})

> _ > _ > Exp > Tab Nat (Row (Maybe Str), Exp) > Sire
= (compileCase go e scrut branches)
@ (binds, envs) | caseBinds (go e scrut) branches
^ foldr L _ binds
| switchSire (A K-dataTag V-(len binds)) K-{fallback}
| tabFromPairsList
: tag    < listForEach (tabKeysList branches)
@ enu    | listFromRowRev (tabIdx tag envs)
@ (_, x) | tabIdx tag branches
| (tag, go (listWeld enu e) x)
| switchSire (A K-dataTag V-(len binds)) K-{TODO: fallback}
| tabFromPairs
| trk [=branches =binds =envs]
: [[_ tag _ x] enu] < foreach (zip branches envs)
| (tag, go (listWeld listFromRowRev-enu e) x)


;;; Misc Codegen ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


@@ 586,7 654,7 @@ abstype#(Bst k v)
    - EADD a b  | addSire (go e a) (go e b)
    - EEQL a b  | eqlSire (go e a) (go e b)
    - ETUP xs   | rowSire (map go-e xs)
    - ECAS s bs | compileCase go e s bs
    - ECAS s bs | traceShowIdWith "OUTPUT" | compileCase go e s bs

    - EREF x
        @ rex (WORD x 0)


@@ 601,7 669,7 @@ abstype#(Bst k v)
    - EFUN inline pinned name args _rTy body
        @ tag     | name
        @ arity   | len args
        ^ F (LAM pinned inline tag arity _)
        ^ mkF pinned inline tag arity _
        ^ go _ body
        ^ listWeld (listRev _) e
        | listMap SOME (name :: listMap fst (listFromRow args))


@@ 612,13 680,13 @@ abstype#(Bst k v)
      | L (A K-(idx 2) V-1)
      | L (A K-(idx 3) V-2)
      | L (A K-(idx 5) V-3)
      ^ apple K-tabSwitch (A K-dataTag V-4, K-{fallback}, tabSire _)
      ^ apple K-tabSwitch (A K-dataTag V-4, K-{TODO: fallback}, tabSire _)
     ## =3 | addSire V-2 V-1
     ## =9 | V-0
  ^ | compile (5, {REPL}, #[], #[])
    | ECAS ENAT-{ADT} _
 ## =3 ([NONE SOME-{x} SOME-{y}], EADD EREF-{x} EREF-{y})
 ## =9 ([NONE NONE NONE NONE SOME-{z}], EREF-{z})
 ++ ("FOO", 3, [NONE SOME-{x} SOME-{y}], EADD EREF-{x} EREF-{y})
 ++ ("BAR", 9, [NONE NONE NONE NONE SOME-{z}], EREF-{z})


;;; Type-Checking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


@@ 664,6 732,21 @@ abstype#(Bst k v)
  # expected=($(showType | viceType expected))
  # actual=($(showType | viceType ty))



= (showCaseBranches showExp bs)
^ bloodline | listFromRow | map _ bs
& (cnstr, tag, fields, body)
^ NEST {-} (cat _) 0
++ [(WORD 0 cnstr)]
++ map x&(maybeCase x "_" n&n) fields
++ showExp body

(showSym s)=(WORD s 0)

= (showTypedSym [sym vty])
` ($(showSym sym))/($(showType | viceType vty))

= (showExp exp)
    # case exp
    - EREF n       | WORD n 0


@@ 673,6 756,7 @@ abstype#(Bst k v)
    - EADD a b     | `($(showExp a) .+ $(showExp b))
    - EAPP a b     | `($(showExp a) $(showExp b))
    - ETUP xs      | NEST "," (map showExp xs) 0
    - ECAS x bs    | NEST "#" ('case, showExp x) (showCaseBranches showExp bs)
    - _            | {showExp: malformed exp} exp

    - ELET name ty val body


@@ 681,7 765,14 @@ abstype#(Bst k v)
          $body

    - EFUN inlined pinned name args resTy body
        | die (inlined, pinned, name, args, resTy, body)
        | if (not inlined && not pinned && eqz name)
            @ argList
                ^ NEST {|} _ 0
                | rowSnoc (map showTypedSym args)
                ` >($(showType | viceType resTy))
            ` & $argList
              $(showExp body)
        | die "umm",(inlined, pinned, name, args, resTy, body)

= (lookupBind ss nm)
: _ _ bind < getBind nm ss (WORD nm 0) failStr


@@ 729,6 820,9 @@ abstype#(Bst k v)
        | seq (go e SOME-ty val)
        | go (tabPut e nm ty) mExpect body

    - ECAS _ _
        | maybeCase mExpect TNAT id

    - EFUN inlined pinned name args resTy body
        @ funTy | foldr TFUN resTy (map snd args)
        ^ seq _ funTy


@@ 736,7 830,7 @@ abstype#(Bst k v)
        | tabFromPairs (rowCons [name funTy] args)

    - _
        | {showExp: malformed exp} exp
        | {typecheck: malformed exp} exp

= (evaluate ss exp)
@ sire | compile ss exp


@@ 788,7 882,7 @@ ex=(ETUP ((EAPP (EAPP EREF-{add} ENAT-2) ENAT-3), ENAT-4, ENAT-5))
ex=(readExp '(const x/Nat y/Bit >Nat ? x))

=?= ex                  | EFUN 0 0 "const" ([%x TNAT], [%y TBIT]) TNAT EREF-{x}
=?= (compile ss ex)     | F (LAM 0 0 %const 2 V-1)
=?= (compile ss ex)     | F (LAM 0 0 0 %const 2 V-1)
=?= (evaluate ss ex)    | (const x y ? x)
=?= (typecheck ss 0 ex) | TFUN TNAT (TFUN TBIT TNAT)



@@ 829,7 923,7 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
@ type  | foldr TFUN newtype fieldTypes
^ (name, _, type, bstEmpty)
| ifz arity (K tag)
^ F (LAM 1 1 name arity _)
^ F (LAM 1 1 0 name arity _)
| rowSire | rowCons K-tag | gen arity i&(V (sub arity inc-i))

= (recordBind newtype (tag, cnstr@(name, fieldTypes)))


@@ 837,7 931,7 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
@ type      | foldr TFUN newtype fieldTypes
| ifz arity | adtBinds [(tag, cnstr)]
^ (name, _, type, bstEmpty)
^ F (LAM 1 1 name arity _)
^ F (LAM 1 1 0 name arity _)
| rowSire | gen arity i&(V (sub arity inc-i))

> Typ > Row (Nat, Constructor) > Row (Str, Sire, Typ, Bst Str Any)


@@ 847,7 941,7 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
* adtBinds newtype branches

=?=  ++  ++ {FOO}
         ++ F-(LAM 1 1 {FOO} 2 (rowSire [K-{tag1} V-1 V-0]))
         ++ F-(LAM 1 1 0 {FOO} 2 (rowSire [K-{tag1} V-1 V-0]))
         ++ (TFUN TNAT (TFUN TNAT TNAT))
         ++ 0
     ++  ++ {BAR}


@@ 1021,3 1115,19 @@ t==true ; compare t to true, using the above information during
(PAIR 3 == PAIR 3)
(PAIR 3 4 == PAIR 3 4)
(PAIR 3 4 == PAIR 3 4)

s3=(SOME 3)

(#| dataTag s3)

= ex
   & (x/Nat >Nat)
   # case (SOME x)
   - NONE   | 1
   - SOME x | inc x

#=?= ex
   #& a
   #| tabSwitch (#| dataTag a) {TODO: fallback}
   #| %[SOME NONE]
   #| c2 1 (#| inc (#| idx 1 a))