~plan/plunder

17341b10321fc82b4536bd552ba9976d250c7232 — Sol 4 months ago 11b8da7
viceroy: ^-rune
1 files changed, 60 insertions(+), 42 deletions(-)

M sire/viceroy.sire
M sire/viceroy.sire => sire/viceroy.sire +60 -42
@@ 7,7 7,7 @@
;;;; Viceroy will eventually replace Stew, but it is still in it's
;;;; infancy.
;;;;
;;;; TODO Implement the (^) rune.
;;;; DONE Implement the (^) rune.
;;;; TODO Implement the (:) rune.
;;;; TODO Implement the (::) rune.
;;;; TODO Implement the (~) rune (and #List literals).


@@ 167,6 167,7 @@ TNAT=(TREF "Nat")
- ETUP Row-Exp
- ECAS Exp Row-(CaseBranchE Exp) (Maybe e)
- ELET p/Pat v/Exp b/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



@@ 327,7 328,7 @@ abstype#TypeTree
| if (len kids /= 2) | failStr rex {nonsense (&&) rune}
| EAND (readExp a) (readExp b)

= (readType self rex)
= (readTxp rex)
# switch (rexType rex)
* _
    | failStr rex {invalid type: what is this?}


@@ 337,7 338,7 @@ abstype#TypeTree
    | TREF (rexText rex)
* {NODE}
    # switch (rexRune rex)
    * {,} | TTUP (map readType-self rexKids-rex)
    * {,} | TTUP (map readTxp rexKids-rex)
    * _   | failStr rex {unknown rune in type expression}

= (readApp readExp rex)


@@ 368,7 369,7 @@ abstype#TypeTree
    | rexSons rex
| if (len sons /= 2)
    | failStr rex {this needs two have two parameters}
| (readSym name, readType-{} type)
| (readSym name, readTxp type)

= (readPat rex)
@ rune | rexRune rex


@@ 382,7 383,7 @@ abstype#TypeTree
    | PSEQ (readPat | fst sons)
| if (rune=={/} && nSon==2)
    @ [name type] sons
    | PVAR (readSym name) (readType-{} type)
    | PVAR (readSym name) (readTxp type)
| else
    | failStr rex {invalid pattern}



@@ 394,7 395,7 @@ abstype#TypeTree
        && (rexHeir rex == 0)
        && (len sons == 1)
    | failStr rex {expected a return type annotation like: >Nat}
| readType-{} tyRex
| readTxp tyRex

= (readAnonSig rex params)
@ numArgs     | dec (len params)


@@ 431,6 432,22 @@ abstype#TypeTree
@ pat                    | readPat patRex
| ELET pat (readExp val) (readExp body)

= (mkApp rex row)
| if (null row)
    | failStr rex {internal error: trying to create empty APP node}
| foldl EAPP (idx 0 row) (drop 1 row)

= (readKet readExp rex)
@ kids     | rexKids rex
@ nKid     | len kids
@ bodyRex  | get kids (dec nKid)
@ typeRex  | fst kids
@ expRexes | slice kids 1 (dec nKid)
@ bodyExp  | mkApp rex (map readExp expRexes)
| if (lth nKid 3)
    | failStr rex {Expected something like (^ exp exp... Type)body}
| EKET (readRetTy typeRex) bodyExp (readExp bodyRex)

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


@@ 501,6 518,7 @@ abstype#TypeTree
         * {++} | ETUP (readSeq readExp rex)
         * {+}  | ETUP (readSeq readExp rex)
         * {,}  | ETUP (readSeq readExp rex)
         * {^}  | readKet readExp rex
         * {@}  | readLet readExp rex
         * {@@} | readLetRec readExp rex
         * {&}  | readAnonLambda readExp rex


@@ 529,7 547,7 @@ abstype#TypeTree
^ ASSERT (readExp _)
| if (nKid == 1) (idx 0 kids) (rexSetRune {|} rex)

= (readConstructors selfNm rex)
= (readConstructors rex)
: rex  < foreach (listToRow | tarSeq {-} rex)
@ kids | rexKids rex
@ nKid | len kids


@@ 537,7 555,7 @@ abstype#TypeTree
    | if (lth nKid 2)
        | failStr rex {bad constructor}
    @ cnstr  | readSym (fst kids)
    @ fields | map readType-selfNm (drop 1 kids)
    @ fields | map readTxp (drop 1 kids)
    | (cnstr, fields)
| else
    (readSym rex, [])


@@ 556,14 574,14 @@ abstype#TypeTree
    | if (nKids == 4)
        @ [_ tyRex flagRex csRex] kids
        @ !typeName | readSym tyRex
        @ !cnstrs   | readConstructors typeName csRex
        @ !cnstrs   | readConstructors csRex
        @ !legible  | if (flagRex == '(-legible)) TRUE
                    | failStr flagRex {expected -legible flag}
        | DATA legible typeName cnstrs
    | if (nKids == 3)
        @ [_ tyRex csRex] kids
        @ !typeName | readSym tyRex
        @ !cnstrs   | readConstructors typeName csRex
        @ !cnstrs   | readConstructors csRex
        | DATA FALSE typeName cnstrs
    | else
        | failStr rex {#data expects three params}


@@ 591,11 609,9 @@ abstype#TypeTree
;;; Converting Between Type Representations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

= (lookupType ss nm)
| trk [lookupType ss nm]
@ rex (WORD nm 0)
@ bad (failStr rex {this is not a type!})
: _ _ bind@[_ plan _ _ _ props] < getBind nm ss rex failStr
| trk [=bind]
: yes < maybeCase (btSearch {isType} props) bad
| ifz yes bad
| plan


@@ 654,6 670,10 @@ abstype#TypeTree
    - ECAS x bs f  | showCase showExp x bs f
    - _            | {showExp: malformed exp} exp

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

    - ELET pat val body
        ` @ $(showPat pat) $(showExp val)
          $(showExp body)


@@ 833,18 853,15 @@ abstype#TypeTree
^ [adt1 _]
: cNm < foreach cNames
@ adt@(PIN (ty, cnstrs)) (lookupAdt ss cNm)
| trk [=adt]
| if (adt /= adt1)
    | failStr rex {two branches from different ADTs}
@ c@[tag fieldTys] (tabGet cnstrs cNm)
| ifz c
    | failStr rex
    | {internal error: failed to lookup constructor information}
| trk [=tag =fieldTys]
| [tag fieldTys]

= (badCase adt)
| trk [adt=(pinItem adt)]
^ die (strCat _)
++ {unhandled case when pattern-matching on }
++ lawName (pinItem (snd (fst (pinItem adt))))


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

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

    - ELET pat var body
        @ rex (showExp exp)
        # case pat


@@ 1009,7 1029,6 @@ abstype#TypeTree
= (typecheck ss mExpect exp)
^ _ {typecheck} #[] mExpect exp
? (go from e mExpect exp)
| trk [%go [=from] [=e] [=mExpect] [=exp]]
@ rex (showExp exp)
| unify ss rex mExpect



@@ 1020,13 1039,12 @@ abstype#TypeTree

    - EREF nm
        # case (tabLookup nm e)
        - SOME x | trk [=x] x
        - SOME x | x
        - NONE   @ bind   | lookupBind ss nm
                 @ ty     | getProp bind {type}
                 | ifz ty | failStr rex {untyped global}
                 @ @(SCHEME arity tree) ty
                 | ifz arity tree
                 | trk [=tree]
                 | failStr rex {polymorphic types are not yet supported}

    - EEQL a b


@@ 1046,17 1064,20 @@ abstype#TypeTree

    - EAPP f x
        @ tree (go {app-fun} e NONE f)
        | trk {APP},[=tree]
        | if (head tree /= funRoot)
            | failStr rex {head is not a function!}
        @ [inType outType] (tnodeParams tree)
        | trk [=inType =outType =tree]
        | seq (go {app-arg} e SOME-inType x) outType

    - ETUP xs
        | tyApp (tupleType | len xs)
        | map (go {tup} e NONE) xs

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

    - ELET pat val body
        # case pat
        - PSEQ p      | go {let-seq} e mExpect (ELET p val body)


@@ 1068,11 1089,8 @@ abstype#TypeTree

    - EREC nm txp val body
        @ !ty | force (viceType ss #[] txp)
        | trk [=ty]
        | trk [tabPut e nm ty]
        @ !e (tabPut e nm ty)
        | if (mExpect == SOME 0) die-[=mExpect]
        | trk [=e =mExpect]
        | seq | force (go {erec.head} e SOME-ty val)
        | go {erec.body} e mExpect body



@@ 1084,9 1102,7 @@ abstype#TypeTree
        @ argTxps  | map snd args
        @ !argTys  | force | map (viceType ss #[]) argTxps
        @ !resTy   | force | viceType ss #[] resTxp
        | trk [=resTy]
        @ funTy    | foldr (a b & tyApp Fun [a b]) resTy argTys
        | trk [=funTy]
        ^ seq _ funTy
        ^ go {fun} (tabUnion _ e) SOME-resTy body
        | tabFromPairs | rowCons [name funTy]


@@ 1200,7 1216,6 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
| rowSire | rowCons K-tag | gen arity i&(V (sub arity inc-i))

= (recordBind adt newtype cnstr@(name, tag, fieldTypes))
; trk [=cnstr]
@ arity     | len fieldTypes
@ type      | foldr funcType newtype fieldTypes
| ifz arity | adtBinds adt newtype [cnstr]


@@ 1236,13 1251,10 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
    @ bind  | PIN [nex plan sire ctx name props]
    @ ss    | (inc nex, ctx, tabPut binds name bind, mods)

    | trk [=type]

    | trk ` > $(showType type)
            = $(WORD name 0) $$plan
            \ $$props

    ; trk [bind=(pinItem bind) =props]
    ss

= (checkForADTDups rex branches)


@@ 1252,7 1264,7 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))

= (execute rex ss@(nex, ctx, binds, mods) cmd)

    | trk "DERP",[=ss]
    | deepseq cmd

    # case cmd



@@ 1282,18 1294,10 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))

    - DATA legible typeName cnstrs

        | trk [=legible =typeName =cnstrs]

        @ (newtype@[_ ntt], ss) | mkNewType typeName 0 ss

        | trk [=newtype =ntt]

        @ resolve (viceType ss (tabSing typeName ntt))

        | trk [resolve=[viceType %ss (tabSing typeName ntt)]]

        | trk [=ss]

        @ branches : (i, (nm, tys)) < foreach (rowIndexed cnstrs)
                   | (nm, if legible nm i, map resolve tys)



@@ 1306,8 1310,6 @@ ex=(readExp '(const x/Nat y/Bit >Nat ? x))
        @ ss | foldl doBind ss
             | constructorBinds adt ntt branches

        | trk [=branches adt=(pinItem adt)]

        | doBind ss (typeName, K-newtype, Type, bstSing {isType} 1)

    - EVAL x


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


@@ 1388,7 1391,8 @@ t==true ; compare t to true, using the above information during
(1 =?= 1)

#=?= (#| tryVice '(1 =?= true))
   ^ LEFT (#| v2 {viceroy-error} _)
  #| LEFT
  #| v2 {viceroy-error}
   ` # error during viceroy execution
     # expression true
     # reason


@@ 1397,7 1401,8 @@ t==true ; compare t to true, using the above information during
         # actual=Bit

#=?= (#| tryVice '(add 1 true))
   ^ LEFT (#| v2 {viceroy-error} _)
  #| LEFT
  #| v2 {viceroy-error}
   ` # error during viceroy execution
     # expression
         true


@@ 1550,3 1555,16 @@ s3=(SOME 3)
  #? (repeat x)
 #@@ ax=(#| LN_CONS x ax)
  #| ax


;;; ^-rune ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

= ex
& (x/Nat >Nat)
^ (>Nat) add _ _
| (3 .+ x)

#=?= ex
  #& a
  #@ z (#| add 3 a)
  #| add z z