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