James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
a4fcc1cb36ab9d345221065e0441632993a13842
tricu/lib/base.tri

386 lines
10 KiB
Plaintext
Raw Blame History

false = t
_ = t
true = t t
id a@_a =@_a a
const a@_a b@_b =@_a a
pair = t
if cond then else = t (t else (t t then)) t cond
y = ((mut wait fun : wait mut (x : fun (wait mut x)))
(x : x x)
(a0 a1 a2 : t (t a0) (t t a2) a1))
compose f@(Fn [_b] _c) g@(Fn [_a] _b) x@_a =@_c f (g x)
triage leaf stem fork = t (t leaf stem) fork
test = triage "Leaf" (_ : "Stem") (_ _ : "Fork")
matchBool = (ot of : triage
of
(_ : ot)
(_ _ : ot)
)
lAnd = (triage
(_ : false)
(_ x : x)
(_ _ x : x))
lOr = (triage
(x : x)
(_ _ : true)
(_ _ _ : true))
matchPair a = triage _ _ a
fst p = matchPair takeFirst p
where takeFirst a b = a
snd p = matchPair takeSecond p
where takeSecond a b = b
resultIsOk result =
matchResult (err rest : false) (val rest : true) result
resultIsErr result =
matchResult (err rest : true) (val rest : false) result
not? = matchBool false true
and? = matchBool id (_ : false)
or? = (x z :
matchBool
(matchBool true true z)
(matchBool true false z)
x)
xor? = (x z :
matchBool
(matchBool false true z)
(matchBool true false z)
x)
equal? = y (self : triage
(triage
true
(_ : false)
(_ _ : false))
(ax :
triage
false
(self ax)
(_ _ : false))
(ax ay :
triage
false
(_ : false)
(bx by : lAnd (self ax bx) (self ay by))))
succ = y (self :
triage
1
t
(triage
(t (t t))
(_ tail : t t (self tail))
t))
ok value rest = pair true (pair value rest)
err msg rest = pair false (pair msg rest)
matchResult errCase okCase result =
matchPair
(tag payload :
matchPair
(value rest :
matchBool
(okCase value rest)
(errCase value rest)
tag)
payload)
result
-- ---------------------------------------------------------------------------
-- Maybe / Option type
-- ---------------------------------------------------------------------------
nothing = t
just x = t x
matchMaybe nothingCase justCase maybe =
triage
nothingCase
justCase
(_ _ : nothingCase)
maybe
maybe default f m = matchMaybe default f m
maybeMap f@(Fn [_a] _b) m@(Maybe _a) =@(Maybe _b) matchMaybe nothing (compose just f) m
maybeBind m@(Maybe _a) f@(Fn [_a] (Maybe _b)) =@(Maybe _b) matchMaybe nothing f m
maybeOr default@_a m@(Maybe _a) =@_a matchMaybe default id m
maybe? = matchMaybe false (_ : true)
-- ---------------------------------------------------------------------------
-- Basic arithmetic
-- ---------------------------------------------------------------------------
ifLazy = (cond thenK elseK :
matchBool
(thenK t)
(elseK t)
cond)
andLazy? = (a bK :
ifLazy
a
bK
(_ : false))
pred = y (self : triage
0
(_ : 0)
(bit rest :
matchBool
(matchBool
0
(pair 0 rest)
(equal? rest 0))
(matchBool
0
(pair 1 (self rest))
(equal? rest 0))
bit))
isZero? = triage true (_ : false) (_ _ : false)
add = y (self x y :
triage
y
(_ : succ y)
(_ _ : succ (self (pred x) y))
x)
sub = y (self a b :
ifLazy
(isZero? b)
(_ : a)
(_ : self (pred a) (pred b)))
lte? = y (self a b :
ifLazy
(isZero? a)
(_ : true)
(_ :
ifLazy
(isZero? b)
(_ : false)
(_ : self (pred a) (pred b))))
gte? = a b :
lte? b a
lt? = a b :
and? (lte? a b) (not? (equal? a b))
gt? = a b :
lt? b a
mul = y (self a b :
ifLazy
(isZero? b)
(_ : 0)
(_ : add a (self a (pred b))))
-- ---------------------------------------------------------------------------
-- Result combinators
-- ---------------------------------------------------------------------------
mapResult = (f result :
matchResult
(code rest : err code rest)
(value rest : ok (f value) rest)
result)
bindResult = (result f :
matchResult
(code rest : err code rest)
(value rest : f value rest)
result)
resultOr = (default result :
matchResult
(_ _ : default)
(value _ : value)
result)
resultMapErr = (f result :
matchResult
(code rest : err (f code) rest)
(value rest : ok value rest)
result)
-- ---------------------------------------------------------------------------
-- View facts
-- ---------------------------------------------------------------------------
factsFact name provenance view = pair name (pair provenance view)
factsChecked = 0
factsTrusted = 1
factsUnchecked = 2
factsField tag value = pair tag value
factsRecord tag fields = pair tag fields
factsVar id = factsRecord 8 [(factsField 10 id)]
factsForall binders body =
factsRecord 9 [(factsField 11 binders) (factsField 12 body)]
factsFn args result =
factsRecord 1 [(factsField 0 args) (factsField 1 result)]
factsAny = factsRecord 0 []
factsRef symbol = factsRecord 2 [(factsField 2 symbol)]
factsBool = factsRef 0
factsString = factsRef 1
factsByte = factsRef 2
factsUnit = factsRef 3
factsMaybe elem = factsRecord 4 [(factsField 3 elem)]
factsList elem = factsRecord 3 [(factsField 3 elem)]
factsPair left right = factsRecord 5 [(factsField 4 left) (factsField 5 right)]
factsResult err ok = factsRecord 6 [(factsField 6 err) (factsField 7 ok)]
viewFacts =
[ (factsFact "pair" factsTrusted
(factsForall [0]
(factsFn
[(factsVar 0) (factsList (factsVar 0))]
(factsList (factsVar 0)))))
(factsFact "nothing" factsTrusted
(factsForall [0]
(factsMaybe (factsVar 0))))
(factsFact "just" factsTrusted
(factsForall [0]
(factsFn [(factsVar 0)] (factsMaybe (factsVar 0)))))
(factsFact "false" factsTrusted factsBool)
(factsFact "true" factsTrusted factsBool)
(factsFact "if" factsTrusted
(factsForall [0]
(factsFn [factsBool (factsVar 0) (factsVar 0)] (factsVar 0))))
(factsFact "triage" factsTrusted
(factsForall [0]
(factsFn [factsAny factsAny factsAny factsAny] (factsVar 0))))
(factsFact "test" factsTrusted factsString)
(factsFact "matchBool" factsTrusted
(factsForall [0]
(factsFn
[(factsVar 0) (factsVar 0) factsBool]
(factsVar 0))))
(factsFact "lAnd" factsTrusted
(factsFn [factsBool factsBool] factsBool))
(factsFact "lOr" factsTrusted
(factsFn [factsBool factsBool] factsBool))
(factsFact "matchPair" factsTrusted
(factsForall [0 1 2]
(factsFn
[(factsFn [(factsVar 0) (factsVar 1)] (factsVar 2))
(factsPair (factsVar 0) (factsVar 1))]
(factsVar 2))))
(factsFact "fst" factsTrusted
(factsForall [0 1]
(factsFn [(factsPair (factsVar 0) (factsVar 1))] (factsVar 0))))
(factsFact "snd" factsTrusted
(factsForall [0 1]
(factsFn [(factsPair (factsVar 0) (factsVar 1))] (factsVar 1))))
(factsFact "not?" factsTrusted
(factsFn [factsBool] factsBool))
(factsFact "and?" factsTrusted
(factsFn [factsBool factsBool] factsBool))
(factsFact "or?" factsTrusted
(factsFn [factsBool factsBool] factsBool))
(factsFact "xor?" factsTrusted
(factsFn [factsBool factsBool] factsBool))
(factsFact "equal?" factsTrusted
(factsForall [0]
(factsFn [(factsVar 0) (factsVar 0)] factsBool)))
(factsFact "succ" factsTrusted
(factsFn [factsByte] factsByte))
(factsFact "pred" factsTrusted
(factsFn [factsByte] factsByte))
(factsFact "isZero?" factsTrusted
(factsFn [factsByte] factsBool))
(factsFact "add" factsTrusted
(factsFn [factsByte factsByte] factsByte))
(factsFact "sub" factsTrusted
(factsFn [factsByte factsByte] factsByte))
(factsFact "lte?" factsTrusted
(factsFn [factsByte factsByte] factsBool))
(factsFact "gte?" factsTrusted
(factsFn [factsByte factsByte] factsBool))
(factsFact "lt?" factsTrusted
(factsFn [factsByte factsByte] factsBool))
(factsFact "gt?" factsTrusted
(factsFn [factsByte factsByte] factsBool))
(factsFact "mul" factsTrusted
(factsFn [factsByte factsByte] factsByte))
(factsFact "matchMaybe" factsTrusted
(factsForall [0 1]
(factsFn
[(factsVar 1)
(factsFn [(factsVar 0)] (factsVar 1))
(factsMaybe (factsVar 0))]
(factsVar 1))))
(factsFact "maybe" factsTrusted
(factsForall [0 1]
(factsFn
[(factsVar 1)
(factsFn [(factsVar 0)] (factsVar 1))
(factsMaybe (factsVar 0))]
(factsVar 1))))
(factsFact "maybe?" factsTrusted
(factsForall [0]
(factsFn [(factsMaybe (factsVar 0))] factsBool)))
(factsFact "ifLazy" factsTrusted
(factsForall [0]
(factsFn
[factsBool
(factsFn [factsUnit] (factsVar 0))
(factsFn [factsUnit] (factsVar 0))]
(factsVar 0))))
(factsFact "andLazy?" factsTrusted
(factsFn [factsBool (factsFn [factsUnit] factsBool)] factsBool))
(factsFact "ok" factsTrusted
(factsForall [0 1]
(factsFn [(factsVar 1) factsAny] (factsResult (factsVar 0) (factsVar 1)))))
(factsFact "err" factsTrusted
(factsForall [0 1]
(factsFn [(factsVar 0) factsAny] (factsResult (factsVar 0) (factsVar 1)))))
(factsFact "matchResult" factsTrusted
(factsForall [0 1 2]
(factsFn
[(factsFn [(factsVar 0) factsAny] (factsVar 2))
(factsFn [(factsVar 1) factsAny] (factsVar 2))
(factsResult (factsVar 0) (factsVar 1))]
(factsVar 2))))
(factsFact "resultIsOk" factsTrusted
(factsForall [0 1]
(factsFn [(factsResult (factsVar 0) (factsVar 1))] factsBool)))
(factsFact "resultIsErr" factsTrusted
(factsForall [0 1]
(factsFn [(factsResult (factsVar 0) (factsVar 1))] factsBool)))
(factsFact "mapResult" factsTrusted
(factsForall [0 1 2]
(factsFn
[(factsFn [(factsVar 1)] (factsVar 2))
(factsResult (factsVar 0) (factsVar 1))]
(factsResult (factsVar 0) (factsVar 2)))))
(factsFact "bindResult" factsTrusted
(factsForall [0 1 2]
(factsFn
[(factsResult (factsVar 0) (factsVar 1))
(factsFn [(factsVar 1)] (factsResult (factsVar 0) (factsVar 2)))]
(factsResult (factsVar 0) (factsVar 2)))))
(factsFact "resultOr" factsTrusted
(factsForall [0 1]
(factsFn [(factsVar 1) (factsResult (factsVar 0) (factsVar 1))] (factsVar 1))))
(factsFact "resultMapErr" factsTrusted
(factsForall [0 1 2]
(factsFn
[(factsFn [(factsVar 0)] (factsVar 2))
(factsResult (factsVar 0) (factsVar 1))]
(factsResult (factsVar 2) (factsVar 1)))))]
Reference in New Issue View Git Blame Copy Permalink