contractEffects.tri (2378B)
1 !import "prelude" !Local 2 3 -- --------------------------------------------------------------------------- 4 -- Contracts + interaction trees with `do` notation 5 -- 6 -- The `do` keyword takes a monadic bind operator. Here we use `bindM` from 7 -- `lib/contracts.tri` to sequence pure, contract-checked computations. 8 -- 9 -- checkM contract value -- lift a contract failure into the tree 10 -- exceptE tag value k -- a resumable failure carrying a continuation 11 -- handleM tag handler tree -- rewrite matching exceptions 12 -- runM tree -- interpret the tree into a Result 13 -- 14 -- A handler receives the exception value and the resumption continuation `k`. 15 -- It may resume by calling `k value`, or it may replace the failing action with 16 -- a new tree of its own. 17 -- --------------------------------------------------------------------------- 18 19 positive? = guardC "expected positive integer" (n : gte? n 1) 20 nonEmpty? = guardC "expected non-empty list" (xs : not? (emptyList? xs)) 21 22 -- Average a list. Fails with a contract exception if the list is empty. 23 average = (xs : 24 do bindM 25 _ <- checkM nonEmpty? xs 26 n <- pureM (length xs) 27 _ <- checkM positive? n 28 total <- pureM (sum xs) 29 pureM (div total n)) 30 31 -- A resumable config lookup. When the key is missing, callers can supply a 32 -- value by handling the "missing" exception. 33 lookupConfig = (key defaultValue : 34 exceptE "missing" key (resume : pureM defaultValue)) 35 36 -- A pipeline that averages a list and divides by a configured divisor. 37 pipeline = (xs : 38 do bindM 39 divisor <- lookupConfig "divisor" 1 40 avg <- average xs 41 scaled <- liftM (x : div x divisor) avg 42 pureM scaled) 43 44 -- Without a handler the missing-key exception reaches runM. 45 unhandled = runM (pipeline [10 20 30]) 46 -- < unhandled 47 -- > [t, "divisor"] 48 49 -- With a handler we replace the missing divisor with 2, so 20 / 2 = 10. 50 withHandler = runM (handleM "missing" (key k : pureM 2) (pipeline [10 20 30])) 51 -- < withHandler 52 -- > [t t, 10] 53 54 -- Handler can also use the original default by calling the resumption. 55 withResume = runM (handleM "missing" (key k : k 2) (pipeline [10 20 30])) 56 -- < withResume 57 -- > [t t, 20] 58 59 -- Contract failures still propagate through handlers for other tags. 60 bothFail = runM (handleM "missing" (key k : pureM 2) (pipeline [])) 61 -- < bothFail 62 -- > [t, "expected non-empty list"] 63 64 main = withHandler