Improvements to erasure checking, fix to codegen issue

This commit is contained in:
2024-11-29 10:02:45 -08:00
parent 052bab81cb
commit 18e44cb7d3
18 changed files with 581 additions and 233 deletions

View File

@@ -32,28 +32,28 @@ data Maybe : U -> U where
Just : {a : U} -> a -> Maybe a
Nothing : {a : U} -> Maybe a
fromMaybe : {a} a Maybe a a
fromMaybe : a. a Maybe a a
fromMaybe a Nothing = a
fromMaybe _ (Just a) = a
data Either : U -> U -> U where
Left : {a b : U} -> a -> Either a b
Right : {a b : U} -> b -> Either a b
Left : {0 a b : U} -> a -> Either a b
Right : {0 a b : U} -> b -> Either a b
infixr 7 _::_
data List : U -> U where
Nil : {A} List A
_::_ : {A} A List A List A
Nil : A. List A
_::_ : A. A List A List A
infixl 7 _:<_
data SnocList : U U where
Lin : {A} SnocList A
_:<_ : {A} SnocList A A SnocList A
Lin : A. SnocList A
_:<_ : A. SnocList A A SnocList A
-- 'chips'
infixr 6 _<>>_
_<>>_ : {a} SnocList a List a List a
_<>>_ : a. SnocList a List a List a
Lin <>> ys = ys
(xs :< x) <>> ys = xs <>> x :: ys
@@ -61,13 +61,13 @@ Lin <>> ys = ys
-- inference? Figure out why.
-- Currently very noisy in generated code (if nothing else, optimize it out?)
infixr 0 _$_
_$_ : {a b : U} -> (a -> b) -> a -> b
_$_ : a b. (a -> b) -> a -> b
f $ a = f a
infixr 8 _×_
infixr 2 _,_
data _×_ : U U U where
_,_ : {A B} A B A × B
_,_ : A B. A B A × B
infixl 6 _<_
class Ord a where
@@ -81,14 +81,14 @@ instance Ord Nat where
-- Monad
class Monad (m : U U) where
bind : {a b} m a (a m b) m b
pure : {a} a m a
bind : {0 a b} m a (a m b) m b
pure : {0 a} a m a
infixl 1 _>>=_ _>>_
_>>=_ : {m} {{Monad m}} {a b} -> (m a) -> (a -> m b) -> m b
_>>=_ : {0 m} {{Monad m}} {0 a b} -> (m a) -> (a -> m b) -> m b
ma >>= amb = bind ma amb
_>>_ : {m} {{Monad m}} {a b} -> m a -> m b -> m b
_>>_ : {0 m} {{Monad m}} {0 a b} -> m a -> m b -> m b
ma >> mb = mb
-- Equality
@@ -108,10 +108,10 @@ sym Refl = Refl
-- Functor
class Functor (m : U U) where
map : {a b} (a b) m a m b
map : {0 a b} (a b) m a m b
infixr 4 _<$>_
_<$>_ : {f} {{Functor f}} {a b} (a b) f a f b
_<$>_ : {0 f} {{Functor f}} {0 a b} (a b) f a f b
f <$> ma = map f ma
instance Functor Maybe where
@@ -130,12 +130,12 @@ instance Functor SnocList where
infixl 3 _<*>_
class Applicative (f : U U) where
-- appIsFunctor : Functor f
return : {a} a f a
_<*>_ : {a b} -> f (a b) f a f b
return : {0 a} a f a
_<*>_ : {0 a b} -> f (a b) f a f b
infixr 2 _<|>_
class Alternative (m : U U) where
_<|>_ : {a} m a m a m a
_<|>_ : {0 a} m a m a m a
instance Alternative Maybe where
Nothing <|> x = x
@@ -266,11 +266,20 @@ instance Monad IO where
MkIORes a w => mab a w
pure a = \ w => MkIORes a w
pfunc putStrLn : String -> IO Unit := `(s) => (w) => {
class HasIO (m : U -> U) where
liftIO : a. IO a m a
instance HasIO IO where
liftIO a = a
pfunc primPutStrLn uses (MkIORes MkUnit) : String -> IO Unit := `(s) => (w) => {
console.log(s)
return MkIORes(Unit,MkUnit,w)
return MkIORes(undefined,MkUnit,w)
}`
putStrLn : io. {{HasIO io}} -> String -> io Unit
putStrLn s = liftIO (primPutStrLn s)
pfunc showInt : Int -> String := `(i) => String(i)`
class Show a where
@@ -285,8 +294,7 @@ instance Show Int where
pfunc ord : Char -> Int := `(c) => c.charCodeAt(0)`
infix 6 _<=_
pfunc _<=_ : Int -> Int -> Bool := `(x,y) => (x <= y) ? True : False`
pfunc _<=_ uses (True False) : Int -> Int -> Bool := `(x,y) => (x <= y) ? True : False`
pfunc unpack : String -> List Char
:= `(s) => {
@@ -296,8 +304,7 @@ pfunc unpack : String -> List Char
}`
foldl : {A B : U} -> (B -> A -> B) -> B -> List A -> B
foldl : A B. (B -> A -> B) -> B -> List A -> B
foldl f acc Nil = acc
foldl f acc (x :: xs) = foldl f (f acc x) xs
@@ -309,7 +316,7 @@ _∘_ : {A B C : U} -> (B -> C) -> (A -> B) -> A -> C
pfunc addInt : Int Int Int := `(x,y) => x + y`
pfunc mulInt : Int Int Int := `(x,y) => x * y`
pfunc subInt : Int Int Int := `(x,y) => x - y`
pfunc ltInt : Int Int Bool := `(x,y) => x < y ? True : False`
pfunc ltInt uses (True False) : Int Int Bool := `(x,y) => x < y ? True : False`
instance Mul Int where
x * y = mulInt x y
@@ -323,8 +330,8 @@ instance Sub Int where
instance Ord Int where
x < y = ltInt x y
printLn : {a} {{Show a}} a IO Unit
printLn a = putStrLn $ show a
printLn : {m} {{HasIO m}} {a} {{Show a}} a m Unit
printLn a = putStrLn (show a)
-- opaque JSObject
ptype JSObject