~jojo/Carth

b144030d9a5428cf4472e3c55258d8983c20982d — JoJo 1 year, 26 days ago 400ecae
Make main IO Unit, i.e. (Fun RealWorld [Unit RealWorld])
M examples/fizzbuzz.carth => examples/fizzbuzz.carth +4 -4
@@ 1,10 1,10 @@
(import std)

(define main fizzbuzz)
(define (main real-world) (fizzbuzz real-world))

(define (fizzbuzz Unit)
  (for (range 1 100)
       (<o display fizzbuzz')))
(define fizzbuzz
  (io/for (range 1 100)
          (<o display fizzbuzz')))

(define (fizzbuzz' n)
  (match [(divisible? n 3) (divisible? n 5)]

M examples/hello-world.carth => examples/hello-world.carth +1 -1
@@ 1,4 1,4 @@
(import std)

(define (main unit)
(define main
  (display (str-append "Hello, world!" "\n")))

M examples/literate.org => examples/literate.org +1 -1
@@ 12,7 12,7 @@ First we import the standard library.
explicitly won't hurt.

#+BEGIN_SRC carth :tangle yes
(define (main _)
(define main
  (display (id "Literate programming rules!")))
#+END_SRC


M examples/sicp.carth => examples/sicp.carth +1 -1
@@ 1,6 1,6 @@
(import std)

(define (main unit)
(define main
  (display (show-int (fib 11))))

(define fib

D examples/sieve.carth => examples/sieve.carth +0 -10
@@ 1,10 0,0 @@
(import std)

(define (main Unit)
  (let ((primes (sieve (range-from 2))))
    (for primes (<o display show-int))))

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

M foreign-core/src/lib.rs => foreign-core/src/lib.rs +1 -1
@@ 80,7 80,7 @@ pub extern "C" fn carth_str_eq(s1: Str, s2: Str) -> bool {
    s1 == s2
}

#[export_name = "display-inline"]
#[export_name = "unsafe-display-inline"]
pub extern "C" fn display_inline(s: Str) {
    let s = from_carth_str(&s);
    print!("{}", s);

M src/Check.hs => src/Check.hs +1 -0
@@ 113,6 113,7 @@ builtinDataTypes' =
      , [("Cons", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]
      )
    , ("Unit", [], [("Unit", [])])
    , ("RealWorld", [], [("UnsafeRealWorld", [])])
    , ("Bool", [], [("False", []), ("True", [])])
    ]


M src/Compile.hs => src/Compile.hs +2 -1
@@ 82,7 82,8 @@ handleProgram f file cfg pgm = withContext $ \ctx ->
                              ice $ "LLVM verification exception:\n" ++ msg
                      withPassManager (optPasses optLvl tm) $ \passman -> do
                          verbose cfg "   Optimizing"
                          _ <- runPassManager passman mod
                          r <- runPassManager passman mod
                          when (not r) $ putStrLn "DEBUG: runPassManager returned False"
                          when (getDebug cfg) $ writeLLVMAssemblyToFile' ".dbg.opt.ll" mod
                          f cfg tm mod


M src/Gen.hs => src/Gen.hs +3 -0
@@ 1192,6 1192,9 @@ litStructNamed :: Ast.TConst -> [LLConst.Constant] -> LLConst.Constant
litStructNamed t xs =
    let tname = mkName (mangleTConst t) in LLConst.Struct (Just tname) False xs

litRealWorld :: Operand
litRealWorld = litUnit

litUnit :: Operand
litUnit = ConstantOperand (LLConst.Array i8 [])


M src/TypeAst.hs => src/TypeAst.hs +10 -1
@@ 28,7 28,7 @@ class TypeAst t where
    tbox :: t -> t

mainType :: TypeAst t => t
mainType = tfun tUnit tUnit
mainType = tfun tRealWorld (tTuple [tUnit, tRealWorld])

tByte :: TypeAst t => t
tByte = tprim (TNat 8)


@@ 45,6 45,15 @@ tStr' = ("Str", [])
tArray :: TypeAst t => t -> t
tArray a = tconst ("Array", [a])

tTuple :: TypeAst t => [t] -> t
tTuple = foldr tCons tUnit

tCons :: TypeAst t => t -> t -> t
tCons car cdr = tconst ("Cons", [car, cdr])

tRealWorld :: TypeAst t => t
tRealWorld = tconst ("RealWorld", [])

tUnit :: TypeAst t => t
tUnit = tconst tUnit'


A std/io.carth => std/io.carth +28 -0
@@ 0,0 1,28 @@
(import std)

(define: (io/for xs f)
    (forall (a) (Fun (Iter a)
                     (Fun a RealWorld [Unit RealWorld])
                     (Fun RealWorld [Unit RealWorld])))
  (fun (real-world) [Unit (foldl (fun (real-world a) (cadr (f a real-world))) real-world xs)]))

(define (io/pure a) (fun (real-world) [Unit real-world]))

(define (io/map f ma)
  (o> (perform-io ma) (map-car f)))

(define (io/bind f ma)
  (o> (perform-io ma) (uncurry (o> f perform-io))))

(define io/bindr (flip io/bind))

(define: (unsafe-perform-io ma)
    (forall (a) (Fun (Fun RealWorld [a RealWorld])
                     [a RealWorld]))
  (perform-io ma UnsafeRealWorld))

(define: perform-io
    (forall (a) (Fun (Fun RealWorld [a RealWorld])
                     RealWorld
                     [a RealWorld]))
  <|)

M std/std.carth => std/std.carth +6 -1
@@ 8,6 8,7 @@
(import array)
(import string)
(import queue)
(import io)

(define (car      [x . _])           x)
(define (cadr     [_ x . _])         x)


@@ 64,7 65,11 @@

;;; IO

(extern display-inline (Fun Str Unit))
(extern unsafe-display-inline (Fun Str Unit))

(define: (display-inline s real-world)
    (Fun Str RealWorld [Unit RealWorld])
  [(unsafe-display-inline s) real-world])

(define (display s)
  (display-inline (str-append s "\n")))

M test/bench/big-nested-struct-on-heap.carth => test/bench/big-nested-struct-on-heap.carth +2 -2
@@ 1,7 1,7 @@
(import std)

(define (main Unit)
  (for (range-from 0) big-allocation))
(define main
  (io/for (range-from 0) big-allocation))

(define (big-allocation n)
  (let ((a (A n n n n))

M test/tests/good/ackermann.carth => test/tests/good/ackermann.carth +1 -1
@@ 2,7 2,7 @@

(import std)

(define (main Unit)
(define main
  (display (show-nat (ackermann (cast 3) (cast 10)))))

(define: (ackermann m n) (Fun Nat Nat Nat)

M test/tests/good/factorial.carth => test/tests/good/factorial.carth +1 -1
@@ 2,7 2,7 @@

(import std)

(define (main Unit)
(define main
  (display (show-int (factorial 20))))

(define (factorial n)

M test/tests/good/fibonacci.carth => test/tests/good/fibonacci.carth +2 -2
@@ 2,8 2,8 @@

(import std)

(define (main Unit)
  (display (show-int (fib 92))))
(define (main real-world)
  (display (show-int (fib 92)) real-world))

(define fib
  (define (fib' a b n)

M test/tests/good/hello-world.carth => test/tests/good/hello-world.carth +1 -1
@@ 2,4 2,4 @@

(import std)

(define (main Unit) (display "Hello, World!"))
(define main (display "Hello, World!"))

M test/tests/good/sieve-of-eratosthenes.carth => test/tests/good/sieve-of-eratosthenes.carth +2 -2
@@ 2,9 2,9 @@

(import std)

(define (main Unit)
(define (main real-world)
  (let1 primes (sieve (range-from 2))
    (display (show-int (unwrap! (iter/nth (cast 1000) primes))))))
    (display (show-int (unwrap! (iter/nth (cast 1000) primes))) real-world)))

(define (sieve xs)
  (Iter (fun (_)