~jojo/Carth

37798fbf79be4eb67bf9cc207a23ecae0c13fe9c — JoJo 1 year, 1 month ago f509947
New pair syntax. [a b] => [a b . Unit] => (Cons a (Cons b Unit))
M TODO.org => TODO.org +0 -11
@@ 504,14 504,3 @@ Features and other stuff to do/implement in/around Carth.
  functions not optimized away, or unsafePerformIO returns something
  like ~(data (UnsafeIOResult a) (UnsafeIOResult a SizedMarker))~ to
  ensure the result is sized.

* TODO Pair notation
  ~(Pair _ _)~ sucks to type, and pairs are or will be common. An idea:

  #+BEGIN_EXAMPLE
  [a . b] => (Pair a b)
  [a b c] => (Pair a (Pair b (Pair c Unit)))
  [a b . c] => (Pair a (Pair b c))
  [a . [b . c]] => —"—
  [a . b . c] => invalid
  #+END_EXAMPLE

M examples/fizzbuzz.carth => examples/fizzbuzz.carth +5 -5
@@ 7,11 7,11 @@
       (<o display fizzbuzz')))

(define (fizzbuzz' n)
  (match (Pair (divisible? n 3) (divisible? n 5))
    (case (Pair False False) (my-show-int n))
    (case (Pair True False) "Fizz")
    (case (Pair False True) "Buzz")
    (case (Pair True True) "Fizzbuzz")))
  (match [(divisible? n 3) (divisible? n 5)]
    (case [False False] (my-show-int n))
    (case [True  False] "Fizz")
    (case [False True ] "Buzz")
    (case [True  True ] "Fizzbuzz")))

(define my-show-int
  (fmatch

M examples/sieve.carth => examples/sieve.carth +2 -4
@@ 6,7 6,5 @@

(define (sieve xs)
  (Iter (fun (_)
          (let1 (Pair x xs') (next! xs)
            (Some (Pair x
                        (sieve (filter (<o not (flip divisible? x))
                                       xs'))))))))
          (let1 [x xs'] (next! xs)
            (Some [x (sieve (filter (<o not (flip divisible? x)) xs'))])))))

M src/Check.hs => src/Check.hs +2 -2
@@ 108,9 108,9 @@ builtinDataTypes' =
        ]
      )
    , ("Str", [], [("Str", [tArray (Inferred.TPrim (TNat 8))])])
    , ( "Pair"
    , ( "Cons"
      , [TVImplicit 0, TVImplicit 1]
      , [("Pair", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]
      , [("Cons", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]
      )
    , ("Unit", [], [("Unit", [])])
    , ("Bool", [], [("False", []), ("True", [])])

M src/Parse.hs => src/Parse.hs +39 -3
@@ 176,10 176,26 @@ data BindingLhs
    | CaseVarLhs Pat

expr' :: Parser Expr'
expr' = choice [var, estr, num, eConstructor, pexpr]
expr' = choice [var, estr, num, eConstructor, etuple, pexpr]
  where
    estr = fmap (Lit . Str) strlit
    eConstructor = fmap Ctor big
    -- FIXME: These positions are completely wack. Gotta get a separate variant in the AST
    --        for pairs. Similar to Box.
    etuple =
        fmap unpos
            $ tuple expr (\p -> WithPos p (Ctor (Id (WithPos p "Unit"))))
            $ \l r ->
                  let p = getPos l
                  in  WithPos
                          p
                          (App
                              (WithPos
                                  p
                                  (App (WithPos p (Ctor (Id (WithPos p "Cons")))) l)
                              )
                              r
                          )
    var = fmap Var small
    pexpr = getSrcPos >>= \p -> parens $ choice
        [funMatch, match, if', fun, let1 p, let', letrec, typeAscr, sizeof, app]


@@ 260,12 276,14 @@ ns_strlit :: Parser String
ns_strlit = char '"' >> manyTill Lexer.charLiteral (char '"')

pat :: Parser Pat
pat = choice [patInt, patStr, patCtor, patVar, ppat]
pat = choice [patInt, patStr, patCtor, patVar, patTuple, ppat]
  where
    patInt = liftA2 PInt getSrcPos int
    patStr = liftA2 PStr getSrcPos strlit
    patCtor = fmap (\x -> PConstruction (getPos x) x []) big
    patVar = fmap PVar small
    patTuple = tuple pat (\p -> PConstruction p (Id (WithPos p "Unit")) [])
        $ \l r -> let p = getPos l in PConstruction p (Id (WithPos p "Cons")) [l, r]
    ppat = do
        pos <- getSrcPos
        parens (choice [patBox pos, patCtion pos])


@@ 284,7 302,8 @@ type_ :: Parser Type
type_ = nonptype <|> parens ptype

nonptype :: Parser Type
nonptype = choice [fmap TPrim tprim, fmap TVar tvar, fmap (TConst . (, []) . idstr) big]
nonptype = choice
    [fmap TPrim tprim, fmap TVar tvar, fmap (TConst . (, []) . idstr) big, ttuple]
  where
    tprim = try $ andSkipSpaceAfter
        (choice


@@ 297,6 316,16 @@ nonptype = choice [fmap TPrim tprim, fmap TVar tvar, fmap (TConst . (, []) . ids
                ]
        <* notFollowedBy identLetter
        )
    ttuple = tuple type_ (const (TConst ("Unit", []))) $ \l r -> TConst ("Cons", [l, r])

tuple :: Parser a -> (SrcPos -> a) -> (a -> a -> a) -> Parser a
tuple p unit f = brackets $ do
    a <- p
    as <- many (try p)
    let ls = a : as
    pos <- getSrcPos
    r <- option (unit pos) (try (reserved "." *> p))
    pure $ foldr f r ls

ptype :: Parser Type
ptype = choice [tfun, tbox, tapp]


@@ 318,6 347,12 @@ parens = andSkipSpaceAfter . ns_parens
ns_parens :: Parser a -> Parser a
ns_parens = between (symbol "(") (string ")")

brackets :: Parser a -> Parser a
brackets = andSkipSpaceAfter . ns_brackets

ns_brackets :: Parser a -> Parser a
ns_brackets = between (symbol "[") (string "]")

int :: Num a => Parser a
int = andSkipSpaceAfter (Lexer.signed empty ns_word)



@@ 380,6 415,7 @@ symbol = Lexer.symbol space
reserveds :: [String]
reserveds =
    [ ":"
    , "."
    , "Fun"
    , "Box"
    , "define"

M std/array.carth => std/array.carth +1 -1
@@ 9,7 9,7 @@
(define: (array/collect xs) (forall (a) (Fun (Iter a) (Array a)))
  (let ((n (iter/length xs))
        (ptr (: (transmute (id@"GC_malloc" (* (sizeof a) n))) (Box a))))
    (foldl (fun (v (Pair i x)) (array/insert i x v))
    (foldl (fun (v [i x]) (array/insert i x v))
           (Array ptr (cast n))
           (enumerate xs))))


M std/iter.carth => std/iter.carth +18 -18
@@ 3,7 3,7 @@
(import maybe)

(data (Iter a)
  (Iter (Fun Unit (Maybe (Pair a (Iter a))))))
  (Iter (Fun Unit (Maybe [a (Iter a)]))))

(define iter/nil
  (Iter (fun (_) None)))


@@ 12,12 12,12 @@
  (iter/cons x iter/nil))

(define (iter/cons x xs)
  (Iter (fun (_) (Some (Pair x xs)))))
  (Iter (fun (_) (Some [x xs]))))

(define (iter/chain xs ys)
  (Iter (fun (_) (maybe (next ys)
                        (fun ((Pair x xs'))
                          (Some (Pair x (iter/chain xs' ys))))
                        (fun ([x xs'])
                          (Some [x (iter/chain xs' ys)]))
                        (next xs)))))

(define (next (Iter it)) (it Unit))


@@ 32,11 32,11 @@
  (take (inc (- b a)) (range-from a)))

(define (range-from a)
  (Iter (fun (_) (Some (Pair a (range-from (inc a)))))))
  (Iter (fun (_) (Some [a (range-from (inc a))]))))

(define (take n xs)
  (Iter (if (> n 0)
            (fun (_) (maybe/map (map-cdr (take (- n 1))) (next xs)))
            (fun (_) (maybe/map (map-cadr (take (- n 1))) (next xs)))
          (fun (_) None))))

(define: (skip n xs)


@@ 45,40 45,40 @@
      xs
    (match (next xs)
      (case None iter/nil)
      (case (Some (Pair _ xs)) (skip (dec n) xs)))))
      (case (Some [_ xs]) (skip (dec n) xs)))))

(define (skip-while pred xs)
  (letrec ((skip-while' (fun (xs)
                          (match (next xs)
                            (case (Some (Pair x xs'))
                            (case (Some [x xs'])
                                  (if (pred x)
                                      (skip-while' xs')
                                    (Some (Pair x xs'))))
                                    (Some [x xs'])))
                            (case None None)))))
    (Iter (fun (_) (skip-while' xs)))))

(define (for xs f) (foldl (const f) Unit xs))

(define (map f xs)
  (Iter (fun (_) (maybe/map (map-both f (map f)) (next xs)))))
  (Iter (fun (_) (maybe/map (map-two f (map f)) (next xs)))))

(define (filter pred xs)
  (Iter (fun (_) (maybe/map (map-cdr (filter pred))
  (Iter (fun (_) (maybe/map (map-cadr (filter pred))
                            (next (skip-while (<o not pred) xs))))))

(define: (foldl f acc xs)
    (forall (acc x) (Fun (Fun acc x acc) acc (Iter x) acc))
  (define (foldl' (Pair acc xs))
  (define (foldl' [acc xs])
    (match (next xs)
      (case (Some (Pair x xs'))
            (foldl' (Pair (f acc x) xs')))
      (case (Some [x xs'])
            (foldl' [(f acc x) xs']))
      (case None
            acc)))
  (foldl' (Pair acc xs)))
  (foldl' [acc xs]))

(define (reverse xs)
  (define (rev xs a)
    (maybe a (fun ((Pair x xs')) (rev xs' (iter/cons x a))) (next xs)))
    (maybe a (fun ([x xs']) (rev xs' (iter/cons x a))) (next xs)))
  (rev xs iter/nil))

(define (iter/length xs)


@@ 87,6 87,6 @@
(define enumerate (zip (range-from (: (cast 0) Nat))))

(define (zip xs ys)
  (Iter (fun (_) (maybe/map2 (fun ((Pair x xs') (Pair y ys'))
                               (Pair (Pair x y) (zip xs' ys')))
  (Iter (fun (_) (maybe/map2 (fun ([x xs'] [y ys'])
                               [[x y] (zip xs' ys')])
                             (next xs) (next ys)))))

M std/list.carth => std/list.carth +16 -16
@@ 1,53 1,53 @@
(import std)

(data (List a)
  (Cons (Box (Pair a (List a))))
  (LCons (Box [a (List a)]))
  Nil)

(define first
  (fmatch (case (Cons (Box (Pair x _))) (Some x))
  (fmatch (case (LCons (Box [x _])) (Some x))
          (case Nil None)))
(define first!
  (fmatch (case (Cons (Box (Pair x _))) x)
  (fmatch (case (LCons (Box [x _])) x)
          (case Nil (panic "first! of empty list"))))

(define rest
  (fmatch (case (Cons (Box (Pair _ xs))) (Some xs))
  (fmatch (case (LCons (Box [_ xs])) (Some xs))
          (case Nil None)))
(define rest!
  (fmatch (case (Cons (Box (Pair _ xs))) xs)
  (fmatch (case (LCons (Box [_ xs])) xs)
          (case Nil (panic "rest! of empty list"))))

(define list/uncons
  (fmatch (case (Cons (Box p)) (Some p))
  (fmatch (case (LCons (Box p)) (Some p))
          (case Nil None)))

(define last
  (fmatch (case (Cons (Box (Pair x Nil))) (Some x))
          (case (Cons (Box (Pair _ xs))) (last xs))
  (fmatch (case (LCons (Box [x Nil])) (Some x))
          (case (LCons (Box [_ xs])) (last xs))
          (case Nil None)))
(define last!
  (fmatch (case (Cons (Box (Pair x Nil))) x)
          (case (Cons (Box (Pair _ xs))) (last! xs))
  (fmatch (case (LCons (Box [x Nil])) x)
          (case (LCons (Box [_ xs])) (last! xs))
          (case Nil (panic "last! of empty list"))))

(define init
  (fmatch (case Nil None)
          (case xs (Some (init! xs)))))
(define init!
  (fmatch (case (Cons (Box (Pair _ Nil))) Nil)
          (case (Cons (Box (Pair x xs))) (list/cons x (init! xs)))
  (fmatch (case (LCons (Box [_ Nil])) Nil)
          (case (LCons (Box [x xs])) (list/cons x (init! xs)))
          (case Nil (panic "init! of empty list"))))

(define list/nil? (fmatch (case Nil True) (case _ False)))

(define (list/reverse xs)
  (define (rev xs a)
    (maybe a (fun ((Pair x xs')) (rev xs' (list/cons x a))) (list/uncons xs)))
    (maybe a (fun ([x xs']) (rev xs' (list/cons x a))) (list/uncons xs)))
  (rev xs Nil))

(define (list/cons x xs)
  (Cons (box (Pair x xs))))
  (LCons (box [x xs])))

(define (list1 x)
  (list/cons x Nil))


@@ 65,7 65,7 @@
(define (list/iter xs)
  (Iter (fun (Unit)
          (match xs
            (case (Cons (Box (Pair y ys)))
                  (Some (Pair y (list/iter ys))))
            (case (LCons (Box [y ys]))
                  (Some [y (list/iter ys)]))
            (case Nil
                  None)))))

M std/queue.carth => std/queue.carth +6 -4
@@ 1,3 1,5 @@
(import list)

;; FIFO (First In, First Out) queue
(data (Queue a)
  (Queue (List a) (List a)))


@@ 12,7 14,7 @@
  (fmatch (case (Queue Nil Nil)
                None)
          (case (Queue in Nil)
                (let1 (Pair x out) (unwrap! (list/uncons (list/reverse in)))
                  (Some (Pair (Queue Nil out) x))))
          (case (Queue in (Cons (Box (Pair x out'))))
                (Some (Pair (Queue in out') x)))))
                (let1 [x out] (unwrap! (list/uncons (list/reverse in)))
                  (Some [(Queue Nil out) x])))
          (case (Queue in (LCons (Box [x out'])))
                (Some [(Queue in out') x]))))

M std/std.carth => std/std.carth +30 -8
@@ 9,12 9,34 @@
(import string)
(import queue)

(define (car (Pair a _)) a)
(define (cdr (Pair _ b)) b)

(define (map-car f (Pair a b)) (Pair (f a) b))
(define (map-cdr f (Pair a b)) (Pair a (f b)))
(define (map-both f g (Pair a b)) (Pair (f a) (g b)))
(define (car      [x . _])           x)
(define (cadr     [_ x . _])         x)
(define (caddr    [_ _ x . _])       x)
(define (cadddr   [_ _ _ x . _])     x)
(define (caddddr  [_ _ _ _ x . _])   x)

(define (cdr      [_ . x])           x)
(define (cddr     [_ _ . x])         x)
(define (cdddr    [_ _ _ . x])       x)
(define (cddddr   [_ _ _ _ . x])     x)
(define (cdddddr  [_ _ _ _ _ . x])   x)

(define (map-car     f [a . b]) [(f a) . b])
(define (map-cadr    f [a . b]) [a . (map-car f b)])
(define (map-caddr   f [a . b]) [a . (map-cadr f b)])
(define (map-cadddr  f [a . b]) [a . (map-caddr f b)])
(define (map-caddddr f [a . b]) [a . (map-cadddr f b)])

(define (map-cdr     f [a . b]) [a . (f b)])
(define (map-cddr    f [a . b]) [a . (map-cdr f b)])
(define (map-cdddr   f [a . b]) [a . (map-cddr f b)])
(define (map-cddddr  f [a . b]) [a . (map-cdddr f b)])
(define (map-cdddddr f [a . b]) [a . (map-cddddr f b)])

(define (map-cons f g [a . b]) [(f a) . (g b)])

(define (map-two f g [a b]) [(f a) (g b)])
(define (map-three f g h [a b c]) [(f a) (g b) (h c)])

(define: (undefined x)
    (forall (a) (Fun Unit a))


@@ 40,8 62,8 @@

;;; Function

(define (uncurry f (Pair a b)) (f a b))
(define (curry f a b) (f (Pair a b)))
(define (uncurry f [a b]) (f a b))
(define (curry f a b) (f [a b]))

(define (<| f a) (f a))
(define (|> a f) (f a))

M std/string.carth => std/string.carth +12 -9
@@ 11,14 11,17 @@
(define: (string/codepoints s)
    (Fun Str (Iter Nat32))
  (define: (init-byte b)
      (Fun Nat8 (Pair Nat8 Nat))
      (Fun Nat8 [Nat8 Nat])
    (if (= (cast 0) (bit-and b (cast 0b10000000)))
        (Pair b (cast 0))
        [b (cast 0)]
      (if (= (cast 0) (bit-and b (cast 0b00100000)))
          (Pair (bit-and b (cast 0b00011111)) (cast 1))
          [(bit-and b (cast 0b00011111))
           (cast 1)]
        (if (= (cast 0) (bit-and b (cast 0b00010000)))
            (Pair (bit-and b (cast 0b00001111)) (cast 2))
          (Pair (bit-and b (cast 0b00000111)) (cast 3))))))
            [(bit-and b (cast 0b00001111))
             (cast 2)]
          [(bit-and b (cast 0b00000111))
           (cast 3)]))))
  (define: cont-byte (Fun Nat8 Nat8) (bit-and (cast 0b00111111)))
  (define: (join a b) (Fun Nat32 Nat8 Nat32)
    (+ (shift-l (cast a) (cast 6))


@@ 26,10 29,10 @@
  (define (go bs)
    (Iter
     (fun (_)
       (maybe/map (fun ((Pair b0 bs'))
                    (let1 (Pair b0' n) (init-byte b0)
                      (Pair (foldl join (cast b0') (take (cast n) bs'))
                            (go (skip (cast n) bs')))))
       (maybe/map (fun ([b0 bs'])
                    (let1 [b0' n] (init-byte b0)
                      [(foldl join (cast b0') (take (cast n) bs'))
                       (go (skip (cast n) bs'))]))
                  (next bs)))))
  (go (string/bytes s)))


M test/bench/big-nested-struct-on-heap.carth => test/bench/big-nested-struct-on-heap.carth +2 -2
@@ 9,11 9,11 @@
        (c (C b b b b))
        (d (D c c c c))
        (e (E d d d d)))
    (seq (box (F e e e e)) (display (show-int n)))))
    (seq (box (F e e)) (display (show-int n)))))

(data A (A Int Int Int Int))
(data B (B A A A A))
(data C (C B B B B))
(data D (D C C C C))
(data E (E D D D D))
(data F (F E E E E))
(data F (F E E))

M test/tests/good/sieve-of-eratosthenes.carth => test/tests/good/sieve-of-eratosthenes.carth +2 -4
@@ 8,7 8,5 @@

(define (sieve xs)
  (Iter (fun (_)
          (let1 (Pair x xs') (next! xs)
            (Some (Pair x
                        (sieve (filter (<o not (flip divisible? x))
                                       xs'))))))))
          (let1 [x xs'] (next! xs)
            (Some [x (sieve (filter (<o not (flip divisible? x)) xs'))])))))