~jojo/Carth

08291062a4735c88981482fcd803ce2b3a5bb5a7 — JoJo 1 year, 2 months ago 2ffd86d
Add IO newtype. Make main be of type IO

Better error messages and shorter to type than the whole realworld
function shebang
6 files changed, 46 insertions(+), 31 deletions(-)

M TODO.org
M src/Check.hs
M src/Codegen.hs
M src/TypeAst.hs
M std/io.carth
M std/std.carth
M TODO.org => TODO.org +1 -1
@@ 396,7 396,7 @@ Features and other stuff to do/implement in/around Carth.
  Would probably require some memoization mechanism so that we don't
  unnecessarily check, monomorphise, and compile stuff we don't need
  to.
* TODO Un-generalize module Selections
* NEXT Un-generalize module Selections
  Since we now use JIT instead of interpreter, only Codegen uses
  Selections, and we could make it simpler by inlining it.
* NEXT Type aliases

M src/Check.hs => src/Check.hs +17 -1
@@ 112,10 112,26 @@ builtinDataTypes' =
      , [TVImplicit 0, TVImplicit 1]
      , [("Cons", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]
      )
    , ("Unit", [], [("Unit", [])])
    , ("Unit", [], [unit'])
    , ("RealWorld", [], [("UnsafeRealWorld", [])])
    , ("Bool", [], [("False", []), ("True", [])])
    , ( "IO"
      , [TVImplicit 0]
      , [ ( "IO"
          , [ Inferred.TFun (tc ("RealWorld", [])) $ tc
                  ( "Cons"
                  , [ Inferred.TVar (TVImplicit 0)
                    , tc ("Cons", [tc ("RealWorld", []), tc unit'])
                    ]
                  )
            ]
          )
        ]
      )
    ]
  where
    tc = Inferred.TConst
    unit' = ("Unit", [])

assertNoRec
    :: Inferred.TypeDefs

M src/Codegen.hs => src/Codegen.hs +2 -1
@@ 201,7 201,8 @@ genMain = do
    Out basicBlocks _ _ _ <- execWriterT $ do
        emitDo' =<< callBuiltin "install_stackoverflow_handler" []
        emitDo (callIntern Nothing init_ [(null' typeGenericPtr, []), (litUnit, [])])
        f <- lookupVar (TypedVar "main" mainType)
        iof <- getLocal =<< lookupVar (TypedVar "main" mainType)
        f <- fmap VLocal $ emitAnonReg =<< extractvalue iof [0]
        _ <- app (Just NoTail) f (VLocal litRealWorld)
        commitFinalFuncBlock (ret (litI32 0))
    pure (GlobalDefinition (externFunc (mkName "main") [] i32 basicBlocks []))

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

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

tIO :: TypeAst t => t -> t
tIO a = tconst ("IO", [a])

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

M std/io.carth => std/io.carth +22 -16
@@ 1,28 1,34 @@
(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)]))
    (forall (a) (Fun (Iter a) (Fun a (IO Unit)) (IO Unit)))
  (IO (fun (real-world)
        [Unit (foldl (fun (real-world a) (cadr (perform-io (f a) real-world)))
                     real-world
                     xs)])))

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

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

(define (io/bind f ma)
  (o> (perform-io ma) (uncurry (o> f perform-io))))
  (o> 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]))
  <|)
    (forall (a) (Fun (IO a) a))
  (car (perform-io ma UnsafeRealWorld)))

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

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

(define (display-inline s)
  (io/pure (unsafe-display-inline s)))

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

M std/std.carth => std/std.carth +0 -11
@@ 63,17 63,6 @@

(extern str-append (Fun Str Str Str))

;;; IO

(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")))

;;; Function

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