~plan/plunder

fae9aa1192cd086bf9d6400b7b2d4bfea439174b — Sol 4 months ago 17341b1
viceroy: list literals
3 files changed, 82 insertions(+), 16 deletions(-)

M sire/sire_07_dat.sire
M sire/types.sire
M sire/viceroy.sire
M sire/sire_07_dat.sire => sire/sire_07_dat.sire +3 -1
@@ 81,6 81,8 @@

(strictRow a)=(foldl const a a)

(seqRow row b)=(foldr seq b row)

= (insert ix val row)
| gen (inc len-row)
& i


@@ 956,7 958,7 @@ F=found
^-^ rowAnd rowOr sum sumOf all any zip zipWith
^-^ cat catMap
^-^ take drop rev
^-^ unfoldr span splitAt foldr1 strictRow insert
^-^ unfoldr span splitAt foldr1 strictRow seqRow insert
^-^
^-^ bopE bapE bowE appE rowE
^-^ {,}

M sire/types.sire => sire/types.sire +3 -1
@@ 131,6 131,8 @@ abstype#Txp
= natRoot  | getTypeRoot#Nat
= typeRoot | getTypeRoot#Type
= bitRoot  | getTypeRoot#Bit
= listRoot | getTypeRoot#List

= unitRoot | getTypeRoot#Unit
= boxRoot  | getTypeRoot#Sing
= pairRoot | getTypeRoot#Pair


@@ 465,6 467,6 @@ printType#Fun
^-^
^-^ TRUE FALSE bit not inc add div
^-^
^-^ funRoot natRoot bitRoot typeRoot
^-^ funRoot natRoot bitRoot typeRoot listRoot
^-^ tupleType
^-^

M sire/viceroy.sire => sire/viceroy.sire +76 -14
@@ 8,9 8,10 @@
;;;; infancy.
;;;;
;;;; DONE Implement the (^) rune.
;;;; TODO Implement the (:) rune.
;;;; TODO Implement the (::) rune.
;;;; TODO Implement the (~) rune (and #List literals).
;;;; DONE Implement the (~) rune (list literals)
;;;; DONE Implement List[3 4] literals.
;;;; DONE Implement the (::) rune (cons)
;;;; TODO Implement the (:) rune (monadic bind)
;;;;
;;;; DONE Implement the (@@) rune (LETREC bindings).
;;;; DONE _-patterns in LET bindings (not included in namespace).


@@ 110,7 111,6 @@
;;;;     x/Nat y/(Row Nat) x/(Nat, Nat)
;;;;
;;;; TODO Arrays: Array(...), Array#(...), # Array ...
;;;; TODO Arrays: Array(...), Array#(...), # Array ...
;;;;
;;;; DONE Strict let bindings (@ !x/Nat (add 2 3) 4)
;;;;


@@ 161,12 161,14 @@ TNAT=(TREF "Nat")
- EBIT Bit
- ENAT Nat
- EEQL Exp Exp
- ECONS Exp Exp
- EAND Exp Exp
- EREF Str
- EAPP Exp Exp
- ETUP Row-Exp
- ECAS Exp Row-(CaseBranchE Exp) (Maybe e)
- ELET p/Pat v/Exp b/Exp
- ELIST xs/(Row Exp)
- EKET t/Txp b/Exp v/Exp
- EREC n/Str t/Txp v/Exp b/Exp
- EFUN inline/Bit pin/Bit nm/Str Row-(Exp,Txp) rTy/Txp b/Exp


@@ 303,7 305,9 @@ abstype#TypeTree
@ bar  | natBar txt
@ heir | rexHeir rex
| ifNonZero heir
    | failStr rex {leaf-heirs are accepted}
    | if (rexStyle rex /= {WORD})
        | failStr rex {What is this nonsense?}
    | readExp (INFX {#} (WORD txt 0, heir) 0)
| if (rexStyle rex /= {WORD})
    | failStr rex {viceroy has no strings}
| if (txt == {true})  | EBIT TRUE


@@ 317,6 321,12 @@ abstype#TypeTree
@ xs           | map readExp kids
| foldl EADD (idx 0 xs) (drop 1 xs)

= (readCons readExp rex)
@ kids         | rexKids rex
| if null-kids | failStr rex {nonsense (::) rune}
@ xs           | map readExp kids
| foldr1 ECONS xs

= (readEql readExp rex)
@ kids@[a b]         | rexKids rex
| if (len kids /= 2) | failStr rex {nonsense (==) rune}


@@ 448,6 458,12 @@ abstype#TypeTree
    | failStr rex {Expected something like (^ exp exp... Type)body}
| EKET (readRetTy typeRex) bodyExp (readExp bodyRex)

= (readSig readExp rex)
@ kids@[seqRx] | rexKids rex
| if (len kids /= 1)
    | failStr rex {Expected something like ~[3 4 5]}
| ELIST (readSeq readExp seqRx)

= (readLetRec readExp rex)
@ kids@[patRex val body] | rexKids rex
| if (len kids /= 3)     | failStr rex {nonsense let binding}


@@ 498,11 514,14 @@ abstype#TypeTree
# switch keyword
* _
    | failStr rex (strWeld {unknown keyword: } keyword)
* {List}
    | if (nKids /= 2)
        | failStr rex {#List expects only one param}
    | ELIST (readSeq readExp (idx 1 kids))
* {case}
    @ [_ scrutRex branchesRex] kids
    | if (nKids /= 3)
        | failStr rex {#case expects three params}
    | traceShowIdWith "HERE"
    @ (branches, fallback) | readCaseBranches readExp branchesRex
    | ECAS (readExp scrutRex) branches fallback



@@ 519,6 538,8 @@ abstype#TypeTree
         * {+}  | ETUP (readSeq readExp rex)
         * {,}  | ETUP (readSeq readExp rex)
         * {^}  | readKet readExp rex
         * {~}  | readSig readExp rex
         * {::} | readCons readExp rex
         * {@}  | readLet readExp rex
         * {@@} | readLetRec readExp rex
         * {&}  | readAnonLambda readExp rex


@@ 657,6 678,9 @@ abstype#TypeTree
- PSEQ p     | ` !($(showPat p))
- PVAR nm ty | ` ($(WORD nm 0) / $(showViceType ty))

= (showTup showExp row)
| NEST {,} (map showExp row) 0

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


@@ 665,11 689,15 @@ abstype#TypeTree
    - EEQL a b     | `($(showExp a) == $(showExp b))
    - EAND a b     | `($(showExp a) && $(showExp b))
    - EADD a b     | `($(showExp a) .+ $(showExp b))
    - ECONS a b    | `($(showExp a) :: $(showExp b))
    - EAPP a b     | `($(showExp a) $(showExp b))
    - ETUP xs      | NEST "," (map showExp xs) 0
    - ETUP xs      | showTup showExp xs
    - ECAS x bs f  | showCase showExp x bs f
    - _            | {showExp: malformed exp} exp

    - ELIST xs
        ` List#($(showTup showExp xs))

    - EKET ty body var
        ` ^ >($(showViceType ty)) $(showExp body)
          $(showExp var)


@@ 911,6 939,8 @@ abstype#TypeTree
= (andSire a b) | apple (G getBind#and) [a b]
= (eqlSire a b) | apple (G getBind#eql) [a b]

= (consSire a b) | apple (G getBind#CONS) [a b]


;;; Evaluating Expressions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



@@ 920,13 950,14 @@ abstype#TypeTree
    ? (go e exp)
    # case exp

    - EBIT n   | K n
    - ENAT n   | K n
    - EAPP a b | A (go e a) (go e b)
    - EADD a b | addSire (go e a) (go e b)
    - EEQL a b | eqlSire (go e a) (go e b)
    - EAND a b | andSire (go e a) (go e b)
    - ETUP xs  | rowSire (map go-e xs)
    - EBIT n    | K n
    - ENAT n    | K n
    - EAPP a b  | A (go e a) (go e b)
    - EADD a b  | addSire (go e a) (go e b)
    - ECONS a b | consSire (go e a) (go e b)
    - EEQL a b  | eqlSire (go e a) (go e b)
    - EAND a b  | andSire (go e a) (go e b)
    - ETUP xs   | rowSire (map go-e xs)

    - ECAS s bs f
        | traceShowIdWith "OUTPUT"


@@ 938,6 969,9 @@ abstype#TypeTree
        - NONE   | G (getBind x ss rex failStr (_ pin _ & pin))
        - SOME i | V i

    - ELIST xs
        | foldr (x xs & consSire (go e x) xs) K-NIL xs

    - EKET _ty body var
        | L (go e var) (go (SOME {_})::e body)



@@ 1057,6 1091,12 @@ abstype#TypeTree
        @ !bTy | go {and} e SOME-bitRoot
        | bitRoot

    - ECONS a b
        @ !aTy | go {cons.head} e NONE a
        @ !lTy | listRoot aTy
        @ !bTy | go {cons.tail} e SOME-lTy b
        | lTy

    - EADD a b
        @ !aTy | go {add} e SOME-natRoot a
        @ !bTy | go {add} e SOME-natRoot b


@@ 1073,6 1113,12 @@ abstype#TypeTree
        | tyApp (tupleType | len xs)
        | map (go {tup} e NONE) xs

    - ELIST xs
        | if null-xs (listRoot natRoot)
        @ ty1 (go {list.1} e NONE (fst xs))
        | seqRow | map (go {list} e SOME-ty1) (drop 1 xs)
        | listRoot ty1

    - EKET txp body val
        @ !ty | force (viceType ss #[] txp)
        | seq | force (go {ket.val} e SOME-ty val)


@@ 1334,6 1380,10 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))

(tryVice rex)=(try [viceroy ss rex v2 v2])

* # backfill NIL (List Nat)
* NIL_BIT=NIL
* # backfill NIL_BIT (List Bit)

{=}#=viceroy
{=?=}#=viceroy
{!!}#=viceroy


@@ 1345,6 1395,7 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
{+}#=viceroy
{,}#=viceroy
{^}#=viceroy
{~}#=viceroy
{@}#=viceroy
{@@}#=viceroy
{&}#=viceroy


@@ 1568,3 1619,14 @@ s3=(SOME 3)
  #& a
  #@ z (#| add 3 a)
  #| add z z


;;; List Constructors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(List[3 4] =?= ~[3 4])

(List[3 4] =?= (3 :: 4 :: ~[]))

(List[3 4] =?= (3 :: 4 :: NIL))

(List[true false] =?= (true :: false :: NIL_BIT))