Improvements to erasure checking, fix to codegen issue
This commit is contained in:
@@ -15,36 +15,49 @@ _||_ : Bool → Bool → Bool
|
||||
True || _ = True
|
||||
False || b = b
|
||||
|
||||
infixl 6 _==_
|
||||
class Eq a where
|
||||
_==_ : a → a → Bool
|
||||
|
||||
data Nat : U where
|
||||
Z : Nat
|
||||
S : Nat -> Nat
|
||||
|
||||
data Maybe : U -> U where
|
||||
Just : {a : U} -> a -> Maybe a
|
||||
Nothing : {a : U} -> Maybe a
|
||||
instance Eq Nat where
|
||||
Z == Z = True
|
||||
S n == S m = n == m
|
||||
x == y = False
|
||||
|
||||
fromMaybe : {a} → a → Maybe a → a
|
||||
data Maybe : U -> U where
|
||||
Just : ∀ a. a -> Maybe a
|
||||
Nothing : ∀ a. Maybe 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
|
||||
|
||||
length : ∀ a. List a → Nat
|
||||
length Nil = Z
|
||||
length (x :: xs) = S (length xs)
|
||||
|
||||
|
||||
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
|
||||
|
||||
@@ -52,53 +65,36 @@ 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 _<_
|
||||
data Ord : U → U where
|
||||
MkOrd : {A} → (A → A → Bool) → Ord A
|
||||
class Ord a where
|
||||
_<_ : a → a → Bool
|
||||
|
||||
_<_ : {A} {{Ord A}} → A → A → Bool
|
||||
_<_ {{MkOrd cmp}} a b = cmp a b
|
||||
|
||||
cmpNat : Nat → Nat → Bool
|
||||
cmpNat Z Z = True
|
||||
cmpNat Z m = False
|
||||
cmpNat n Z = True
|
||||
cmpNat (S n) (S m) = True
|
||||
|
||||
OrdNat : Ord Nat
|
||||
OrdNat = MkOrd cmpNat
|
||||
instance Ord Nat where
|
||||
_ < Z = False
|
||||
Z < S _ = True
|
||||
S n < S m = n < m
|
||||
|
||||
-- Monad
|
||||
|
||||
-- TODO sugar for if then else (mixfix is too eager)
|
||||
|
||||
-- TODO stack with Applicative, etc?
|
||||
|
||||
data Monad : (U -> U) -> U where
|
||||
MkMonad : { M : U -> U } ->
|
||||
(bind : {A B : U} -> (M A) -> (A -> M B) -> M B) ->
|
||||
(pure : {A : U} -> A -> M A) ->
|
||||
Monad M
|
||||
class Monad (m : U → U) where
|
||||
bind : {0 a b} → m a → (a → m b) → m b
|
||||
pure : {0 a} → a → m a
|
||||
|
||||
infixl 1 _>>=_ _>>_
|
||||
_>>=_ : {a b : U} -> {m : U -> U} -> {{x : Monad m}} -> (m a) -> (a -> m b) -> m b
|
||||
_>>=_ {a} {b} {m} {{MkMonad bind' _}} ma amb = bind' {a} {b} ma amb
|
||||
_>>=_ : {0 m} {{Monad m}} {0 a b} -> (m a) -> (a -> m b) -> m b
|
||||
ma >>= amb = bind ma amb
|
||||
|
||||
_>>_ : {a b : U} -> {m : U -> U} -> {{x : Monad m}} -> m a -> m b -> m b
|
||||
_>>_ : {0 m} {{Monad m}} {0 a b} -> m a -> m b -> m b
|
||||
ma >> mb = mb
|
||||
|
||||
pure : {a : U} {m : U -> U} {{_ : Monad m}} -> a -> m a
|
||||
pure {_} {_} {{MkMonad _ pure'}} a = pure' a
|
||||
|
||||
-- Equality
|
||||
|
||||
infixl 1 _≡_
|
||||
@@ -114,114 +110,90 @@ sym : {A : U} -> {a b : A} -> a ≡ b -> b ≡ a
|
||||
sym Refl = Refl
|
||||
|
||||
-- Functor
|
||||
data Functor : (U → U) → U where
|
||||
MkFunctor : {m : U → U} → ({a b : U} → (a → b) → m a → m b) → Functor m
|
||||
|
||||
map : {m} {{Functor m}} → {a b} → (a → b) → m a → m b
|
||||
map {{MkFunctor f}} ma = f ma
|
||||
class Functor (m : U → U) where
|
||||
map : {0 a b} → (a → b) → m a → m b
|
||||
|
||||
infixr 4 _<$>_
|
||||
_<$>_ : {f : U → U} {{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
|
||||
map f Nothing = Nothing
|
||||
map f (Just a) = Just (f a)
|
||||
|
||||
mapMaybe : {a b} → (a → b) → Maybe a → Maybe b
|
||||
mapMaybe f Nothing = Nothing
|
||||
mapMaybe f (Just a) = Just (f a)
|
||||
instance Functor List where
|
||||
map f Nil = Nil
|
||||
map f (x :: xs) = f x :: map f xs
|
||||
|
||||
FunctorMaybe : Functor Maybe
|
||||
FunctorMaybe = MkFunctor mapMaybe
|
||||
instance Functor SnocList where
|
||||
map f Lin = Lin
|
||||
map f (xs :< x) = map f xs :< f x
|
||||
|
||||
|
||||
|
||||
-- Idris is lazy in second arg, we don't have that.
|
||||
data Alternative : (U → U) → U where
|
||||
MkAlt : {m : U → U} →
|
||||
({a} → m a → m a → m a) →
|
||||
Alternative m
|
||||
-- TODO this probably should depend on / entail Functor
|
||||
infixl 3 _<*>_
|
||||
class Applicative (f : U → U) where
|
||||
-- appIsFunctor : Functor f
|
||||
return : {0 a} → a → f a
|
||||
_<*>_ : {0 a b} -> f (a → b) → f a → f b
|
||||
|
||||
infixr 2 _<|>_
|
||||
_<|>_ : {m : U → U} {{Alternative m}} → {a} → m a → m a → m a
|
||||
_<|>_ {m} {{MkAlt f}} {a} x y = f x y
|
||||
class Alternative (m : U → U) where
|
||||
_<|>_ : {0 a} → m a → m a → m a
|
||||
|
||||
altMaybe : {a} → Maybe a → Maybe a → Maybe a
|
||||
altMaybe Nothing x = x
|
||||
altMaybe (Just x) _ = Just x
|
||||
|
||||
AltMaybe : Alternative Maybe
|
||||
AltMaybe = MkAlt altMaybe
|
||||
instance Alternative Maybe where
|
||||
Nothing <|> x = x
|
||||
Just x <|> _ = Just x
|
||||
|
||||
-- Semigroup
|
||||
|
||||
infixl 8 _<+>_
|
||||
data Semigroup : U → U where
|
||||
MkSemi : {a} → (a → a → a) → Semigroup a
|
||||
|
||||
_<+>_ : {a} {{Semigroup a}} → a → a → a
|
||||
_<+>_ {{MkSemi op}} x y = op x y
|
||||
|
||||
class Semigroup a where
|
||||
_<+>_ : a → a → a
|
||||
|
||||
infixl 7 _+_
|
||||
data Add : U → U where
|
||||
MkAdd : {A} → (A → A → A) → Add A
|
||||
|
||||
_+_ : {A} {{Add A}} → A → A → A
|
||||
_+_ {{MkAdd add}} x y = add x y
|
||||
class Add a where
|
||||
_+_ : a → a → a
|
||||
|
||||
infixl 8 _*_
|
||||
data Mul : U → U where
|
||||
MkMul : {A} →
|
||||
(A → A → A) →
|
||||
Mul A
|
||||
class Mul a where
|
||||
_*_ : a → a → a
|
||||
|
||||
_*_ : {A} {{Mul A}} → A → A → A
|
||||
_*_ {{MkMul mul}} x y = mul x y
|
||||
instance Add Nat where
|
||||
Z + m = m
|
||||
S n + m = S (n + m)
|
||||
|
||||
instance Mul Nat where
|
||||
Z * _ = Z
|
||||
S n * m = m + n * m
|
||||
|
||||
|
||||
-- TODO codata/copatterns might be nice here?
|
||||
-- AddNat : AddNat
|
||||
-- AddNat .add Z m = m
|
||||
-- AddNat .add (S n) m = S (self .add n m)
|
||||
|
||||
addNat : Nat → Nat → Nat
|
||||
addNat Z m = m
|
||||
addNat (S n) m = S (addNat n m)
|
||||
|
||||
AddNat : Add Nat
|
||||
AddNat = MkAdd addNat
|
||||
|
||||
mulNat : Nat → Nat → Nat
|
||||
mulNat Z _ = Z
|
||||
mulNat (S n) m = m + mulNat n m
|
||||
|
||||
MulNat : Mul Nat
|
||||
MulNat = MkMul mulNat
|
||||
|
||||
|
||||
-- TODO Sub
|
||||
infixl 7 _-_
|
||||
_-_ : Nat -> Nat -> Nat
|
||||
Z - m = Z
|
||||
n - Z = n
|
||||
S n - S m = n - m
|
||||
class Sub a where
|
||||
_-_ : a → a → a
|
||||
|
||||
instance Sub Nat where
|
||||
Z - m = Z
|
||||
n - Z = n
|
||||
S n - S m = n - m
|
||||
|
||||
infixr 7 _++_
|
||||
class Concat a where
|
||||
_++_ : a → a → a
|
||||
|
||||
ptype String
|
||||
ptype Int
|
||||
ptype Char
|
||||
|
||||
-- probably want to switch to Int or implement magic Nat
|
||||
pfunc length : String → Nat := "(s) => {
|
||||
let rval = Z
|
||||
for (let i = 0; i < s.length; s++) rval = S(rval)
|
||||
return rval
|
||||
}"
|
||||
pfunc sconcat : String → String → String := `(x,y) => x + y`
|
||||
instance Concat String where
|
||||
_++_ = sconcat
|
||||
|
||||
data Unit : U where
|
||||
MkUnit : Unit
|
||||
|
||||
ptype Array : U → U
|
||||
pfunc listToArray : {a : U} -> List a -> Array a := "
|
||||
pfunc listToArray : {a : U} -> List a -> Array a := `
|
||||
(a, l) => {
|
||||
let rval = []
|
||||
while (l.tag !== 'Nil') {
|
||||
@@ -230,17 +202,54 @@ pfunc listToArray : {a : U} -> List a -> Array a := "
|
||||
}
|
||||
return rval
|
||||
}
|
||||
"
|
||||
pfunc alen : {a : U} -> Array a -> Int := `(a,arr) => arr.length`
|
||||
pfunc aget : {a : U} -> Array a -> Int -> a := `(a, arr, ix) => arr[ix]`
|
||||
pfunc aempty : {a : U} -> Unit -> Array a := `() => []`
|
||||
`
|
||||
|
||||
pfunc alen : {0 a : U} -> Array a -> Int := `(a,arr) => arr.length`
|
||||
pfunc aget : {0 a : U} -> Array a -> Int -> a := `(a, arr, ix) => arr[ix]`
|
||||
pfunc aempty : {0 a : U} -> Unit -> Array a := `() => []`
|
||||
|
||||
pfunc arrayToList uses (Nil _::_) : {0 a} → Array a → List a := `(a,arr) => {
|
||||
let rval = Nil(a)
|
||||
for (let i = arr.length - 1;i >= 0; i--) {
|
||||
rval = _$3A$3A_(a, arr[i], rval)
|
||||
}
|
||||
return rval
|
||||
}`
|
||||
|
||||
|
||||
|
||||
-- for now I'll run this in JS
|
||||
pfunc lines : String → List String := `(s) => arrayToList(s.split('\n'))`
|
||||
|
||||
pfunc p_strHead : (s : String) -> Char := `(s) => s[0]`
|
||||
pfunc p_strTail : (s : String) -> String := `(s) => s[0]`
|
||||
|
||||
pfunc trim : String -> String := `s => s.trim()`
|
||||
pfunc split uses (Nil _::_) : String -> String -> List String := `(s, by) => {
|
||||
let parts = s.split(by)
|
||||
let rval = Nil(String)
|
||||
parts.reverse()
|
||||
parts.forEach(p => { rval = _$3A$3A_(undefined, p, rval) })
|
||||
return rval
|
||||
}`
|
||||
|
||||
pfunc slen : String -> Int := `s => s.length`
|
||||
pfunc sindex : String -> Int -> Char := `(s,i) => s[i]`
|
||||
|
||||
-- TODO represent Nat as number at runtime
|
||||
pfunc natToInt : Nat -> Int := `(n) => {
|
||||
let rval = 0
|
||||
while (n.tag === 'S') {
|
||||
n = n.h0
|
||||
rval++
|
||||
}
|
||||
return rval
|
||||
}`
|
||||
|
||||
pfunc fastConcat : List String → String := `(xs) => listToArray(undefined, xs).join('')`
|
||||
pfunc replicate : Nat -> Char → String := `() => abort('FIXME replicate')`
|
||||
|
||||
|
||||
pfunc replicate : Nat -> Char → String := `(n,c) => c.repeat(natToInt(n))`
|
||||
|
||||
-- I don't want to use an empty type because it would be a proof of void
|
||||
ptype World
|
||||
|
||||
data IORes : U -> U where
|
||||
@@ -249,16 +258,143 @@ data IORes : U -> U where
|
||||
IO : U -> U
|
||||
IO a = World -> IORes a
|
||||
|
||||
-- TODO - if I move w to the left, I get "extra pattern variable"
|
||||
-- because I'm not looking instide the IO b type, probably should force it.
|
||||
iobind : {a b : U} -> IO a -> (a -> IO b) -> IO b
|
||||
iobind ma mab = \ w => case ma w of
|
||||
(MkIORes a w) => mab a w
|
||||
instance Monad IO where
|
||||
bind ma mab = \ w => case ma w of
|
||||
MkIORes a w => mab a w
|
||||
pure a = \ w => MkIORes a w
|
||||
|
||||
iopure : {a : U} -> a -> IO a
|
||||
iopure a = \ w => MkIORes a w
|
||||
bindList : ∀ a b. List a → (a → List b) → List b
|
||||
|
||||
IOMonad : Monad IO
|
||||
IOMonad = MkMonad iobind iopure
|
||||
instance ∀ a. Concat (List a) where
|
||||
Nil ++ ys = ys
|
||||
(x :: xs) ++ ys = x :: (xs ++ ys)
|
||||
|
||||
pfunc putStrLn : String -> IO Unit := `(s) => (w) => console.log(s)`
|
||||
instance Monad List where
|
||||
pure a = a :: Nil
|
||||
bind Nil amb = Nil
|
||||
bind (x :: xs) amb = amb x ++ bind xs amb
|
||||
|
||||
class HasIO (m : U -> U) where
|
||||
liftIO : ∀ a. IO a → m a
|
||||
|
||||
instance HasIO IO where
|
||||
liftIO a = a
|
||||
|
||||
pfunc debugLog uses (MkIORes MkUnit) : ∀ a. a -> IO Unit := `(_,s) => (w) => {
|
||||
console.log(s)
|
||||
return MkIORes(undefined,MkUnit,w)
|
||||
}`
|
||||
|
||||
pfunc primPutStrLn uses (MkIORes MkUnit) : String -> IO Unit := `(s) => (w) => {
|
||||
console.log(s)
|
||||
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
|
||||
show : a → String
|
||||
|
||||
instance Show String where
|
||||
show a = a
|
||||
|
||||
instance Show Int where
|
||||
show = showInt
|
||||
|
||||
pfunc ord : Char -> Int := `(c) => c.charCodeAt(0)`
|
||||
|
||||
infix 6 _<=_
|
||||
pfunc _<=_ uses (True False) : Int -> Int -> Bool := `(x,y) => (x <= y) ? True : False`
|
||||
|
||||
pfunc unpack : String -> List Char
|
||||
:= `(s) => {
|
||||
let acc = Nil(Char)
|
||||
for (let i = s.length - 1; 0 <= i; i--) acc = _$3A$3A_(Char, s[i], acc)
|
||||
return acc
|
||||
}`
|
||||
|
||||
pfunc pack : List Char → String := `(cs) => {
|
||||
let rval = ''
|
||||
while (cs.tag === '_::_') {
|
||||
rval += cs.h1
|
||||
cs = cs.h2
|
||||
}
|
||||
|
||||
return rval
|
||||
}
|
||||
`
|
||||
|
||||
pfunc debugStr : ∀ a. a → String := `(_, obj) => {
|
||||
const go = (obj) => {
|
||||
if (obj?.tag) {
|
||||
let rval = '('+obj.tag
|
||||
for(let i=0;;i++) {
|
||||
let key = 'h'+i
|
||||
if (!(key in obj)) break
|
||||
rval += ' ' + go(obj[key])
|
||||
}
|
||||
return rval+')'
|
||||
} else {
|
||||
return JSON.stringify(obj)
|
||||
}
|
||||
}
|
||||
return go(obj)
|
||||
}`
|
||||
|
||||
pfunc stringToInt : String → Int := `(s) => {
|
||||
let rval = Number(s)
|
||||
if (isNaN(rval)) throw new Error(s + " is NaN")
|
||||
return rval
|
||||
}`
|
||||
|
||||
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
|
||||
|
||||
infixl 9 _∘_
|
||||
_∘_ : {A B C : U} -> (B -> C) -> (A -> B) -> A -> C
|
||||
(f ∘ g) x = f (g x)
|
||||
|
||||
|
||||
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 uses (True False) : Int → Int → Bool := `(x,y) => x < y ? True : False`
|
||||
|
||||
instance Mul Int where
|
||||
x * y = mulInt x y
|
||||
|
||||
instance Add Int where
|
||||
x + y = addInt x y
|
||||
|
||||
instance Sub Int where
|
||||
x - y = subInt x y
|
||||
|
||||
instance Ord Int where
|
||||
x < y = ltInt x y
|
||||
|
||||
printLn : {m} {{HasIO m}} {a} {{Show a}} → a → m Unit
|
||||
printLn a = putStrLn (show a)
|
||||
|
||||
-- opaque JSObject
|
||||
ptype JSObject
|
||||
|
||||
reverse : ∀ a. List a → List a
|
||||
reverse {a} = go Nil
|
||||
where
|
||||
go : List a → List a → List a
|
||||
go acc Nil = acc
|
||||
go acc (x :: xs) = go (x :: acc) xs
|
||||
|
||||
-- Like Idris1, but not idris2, we need {a} to put a in scope.
|
||||
span : ∀ a. (a -> Bool) -> List a -> List a × List a
|
||||
span {a} f xs = go xs Nil
|
||||
where
|
||||
go : List a -> List a -> List a × List a
|
||||
go Nil left = (reverse left, Nil)
|
||||
go (x :: xs) left = if f x
|
||||
then go xs (x :: left)
|
||||
else (reverse left, x :: xs)
|
||||
|
||||
Reference in New Issue
Block a user